src/fcall.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancements.                   ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11
  12 (in-package :maxima)
  13
  14 (macsyma-module fcall)
  15
  16 ;;; Bug-Fixes:
  17 ;;;
  18 ;;; 11/15/80    KMP     Remove *TRIED-TO-AUTOLOAD* as a global and replaced
  19 ;;;                     MFUNCTION-CALL with a trampoline function that calls
  20 ;;;                     MFUNCTION-CALL-AUX with this info since MFUNCTION-CALL
  21 ;;;                     was being screwed by the non-local nature of this var
  22 ;;;                     when calls to itself got nested.
  23 ;;;
  24
  25 ;;; This file is for macros, fsubrs, and subrs which are run time
  26 ;;; support for interpreted translated maxima code.
  27
  28 ;;; MFUNCTION-CALL is a macro in LIBMAX;TRANSQ
  29 ;;; This is an FSUBR for use in interpreted code.
  30 ;;; It should do quit a bit of checking for STATUS PUNT NIL lossage, etc.
  31 ;;; The macro will expand into code which will assume normal
  32 ;;; functional argument evaluation.
  33
  34 (defmvar $tr_warn_bad_function_calls t
  35   "Warn when strange kinds of function calls are going on in translated code.")
  36
  37 (defvar *tr-runtime-warned* nil
  38   "This is an alist of warnings which have been given")
  39
  40 (defmfun $tr_warnings_get ()
  41   `((mlist) ,@(mapcar #'(lambda (u) `((mlist) ,(car u) ,(cdr u)))  *tr-runtime-warned*)))
  42
  43 (defun mfunction-call-warn (f type)
  44   (cond ((assoc f *tr-runtime-warned* :test #'eq))
  45         (t
  46          (push (cons f type) *tr-runtime-warned*)
  47          (when $tr_warn_bad_function_calls
  48            (let ((tabl (cdr (assoc type '((macro . (macro-warnedp "Macros should be loaded when you are translating."))
  49                                          (undefined . (undefined-warnp "The function was totally undefined. Maybe you want to quote it."))
  50                                          (punt-nil . (punt-nil-warnp "If you want the value of the function name, use `apply'"))
  51                                          (mfexpr . (mfexpr-warnedp "MFEXPRS should be loaded at translating time. Use of them in translated code (nay, any code!), is NOT recommended however.")))
  52                                    :test #'eq))))
  53              (cond ((null tabl))
  54                    ((get f (car tabl)))
  55                    (t
  56                     (putprop f t (car tabl))
  57                     (terpri)
  58                     (finish-output)
  59                     (princ "Warning: ")
  60                     (mgrind f nil)
  61                     (princ " has a function or macro call which has not been translated properly.")
  62                     (cond ((cdr tabl)
  63                            (terpri)
  64                            (finish-output)
  65                            (princ (cadr tabl)))))))))))
  66
  67 (defun mapcar-eval (x)
  68   (mapcar #'eval x))
  69
  70 (defmacro mfunction-call (f &rest argl)
  71   (if (fboundp f)
  72       `(,f ,@ argl)
  73       ;;loses if the argl could not be evaluated but macsyma &quote functions
  74       ;;but the translator should be fixed so that if (mget f 'mfexprp) is t
  75       ;;then it doesn't translate as an mfunction-call.
  76       `(mfunction-call-aux ',f ',argl nil)))
  77
  78 (defun mfunction-call-aux (f argl autoloaded-already? &aux f-prop)
  79   (cond ((functionp f)
  80          (apply f (mapcar-eval argl)))
  81         ((macro-function f)
  82          (mfunction-call-warn f 'macro)
  83          (eval (cons f argl)))
  84         ((not (symbolp f)) (merror (intl:gettext "apply: expected symbol or function; found: ~M") f))
  85         ((setq f-prop (get f 'mfexpr*))
  86          (funcall f-prop (cons nil argl)))
  87         ((setq f-prop (mget f 'mexpr))
  88          (cond ((mget f 'mfexprp)
  89                 (mfunction-call-warn f 'mfexpr)
  90                 (meval (cons (list f) argl)))
  91                (t
  92                 (mlambda f-prop (mapcar-eval argl) f t nil))))
  93         ((setq f-prop (get f 'autoload))
  94          (cond (autoloaded-already?
  95                 (merror (intl:gettext "apply: function ~:@M undefined after loading file ~A") f (namestring (get f 'autoload))))
  96                (t
  97                 (funcall autoload (cons f f-prop))
  98                 (mfunction-call-aux f argl t))))
  99         ((boundp f)
 100          (mfunction-call-warn f 'punt-nil)
 101          (mapply (symbol-value f) (mapcar-eval argl) f))
 102         (t
 103          (mfunction-call-warn f 'undefined)
 104          `((,f) ,@(mapcar-eval argl)))))
 105
 106 (defquote trd-msymeval (&rest l)
 107   (let ((a-var? (car l)))
 108     (if (boundp a-var?)
 109         (eval a-var?) ;;; ouch!
 110         (setf (symbol-value a-var?) (if (cdr l) (eval (cadr l))  a-var?))))) ;; double ouch!
 111
 112 (defun maybe-msymeval (var)
 113   (if (boundp var)
 114       (symbol-value var)
 115       var))
 116
 117 ;;; These are the LAMBDA forms. They have macro properties that set
 118 ;;; up very different things in compiled code.
 119
 120 ;;; (FUNGEN&ENV-for-meval <eval vars list> <late eval vars list>  <EXP>)
 121 ;;won't work in cl.  fix later.
 122 (defquote fungen&env-for-meval (&rest args)
 123   (destructuring-let (((evl nil . body) args))
 124             ;;; all we want to do here is make sure that the EVL gets
 125             ;;; evaluated now so that we have some kind of compatibility
 126             ;;; with compiled code. we could just punt and pass the body.
 127                      `(($apply) ((mquote) ((lambda) ((mlist) ,@evl) ,@body))
 128                        ((mquote simp) ((mlist) ,@(mapcar-eval evl))))))
 129