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 '((fexpr . (fexpr-warnedp "This may be due to lack of enough translation data *print-base* info."))
  49                                          (macro . (macro-warnedp "Macros should be loaded when you are translating."))
  50                                          (undefined . (undefined-warnp "The function was totally undefined. Maybe you want to quote it."))
  51                                          (punt-nil . (punt-nil-warnp "If you want the value of the function name, use `apply'"))
  52                                          (mfexpr . (mfexpr-warnedp "MFEXPRS should be loaded at translating time. Use of them in translated code (nay, any code!), is NOT recommended however.")))
  53                                    :test #'eq))))
  54              (cond ((null tabl))
  55                    ((get f (car tabl)))
  56                    (t
  57                     (putprop f t (car tabl))
  58                     (terpri)
  59                     (finish-output)
  60                     (princ "Warning: ")
  61                     (mgrind f nil)
  62                     (princ " has a function or macro call which has not been translated properly.")
  63                     (cond ((cdr tabl)
  64                            (terpri)
  65                            (finish-output)
  66                            (princ (cadr tabl)))))))))))
  67
  68 (defun mapcar-eval (x)
  69   (mapcar #'eval x))
  70
  71 (defmacro mfunction-call (f &rest argl)
  72   (if (fboundp f)
  73       `(,f ,@ argl)
  74       ;;loses if the argl could not be evaluated but macsyma &quote functions
  75       ;;but the translator should be fixed so that if (mget f 'mfexprp) is t
  76       ;;then it doesn't translate as an mfunction-call.
  77       `(lispm-mfunction-call-aux ',f ',argl (list ,@ argl) nil)))
  78
  79 (defun lispm-mfunction-call-aux (f argl list-argl autoloaded-already? &aux f-prop)
  80   (cond ((functionp f)
  81          (apply f list-argl))
  82         ((macro-function f)
  83          (eval (cons f list-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 list-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                 (lispm-mfunction-call-aux f argl list-argl t))))
  99
 100         ((boundp f)
 101          (mfunction-call-warn f 'punt-nil)
 102          (mapply (eval f) (mapcar-eval argl) f))
 103         (t
 104          (mfunction-call-warn f 'undefined)
 105          `((,f) ,@ list-argl))))
 106
 107 (defquote trd-msymeval (&rest l)
 108   (let ((a-var? (car l)))
 109     (if (boundp a-var?)
 110         (eval a-var?) ;;; ouch!
 111         (setf (symbol-value a-var?) (if (cdr l) (eval (cadr l))  a-var?))))) ;; double ouch!
 112
 113 (defun maybe-msymeval (var)
 114   (if (boundp var)
 115       (symbol-value var)
 116       var))
 117
 118 ;;; These are the LAMBDA forms. They have macro properties that set
 119 ;;; up very different things in compiled code.
 120
 121 ;;; (FUNGEN&ENV-for-meval <eval vars list> <late eval vars list>  <EXP>)
 122 ;;won't work in cl.  fix later.
 123 (defquote fungen&env-for-meval (&rest args)
 124   (destructuring-let (((evl nil . body) args))
 125             ;;; all we want to do here is make sure that the EVL gets
 126             ;;; evaluated now so that we have some kind of compatibility
 127             ;;; with compiled code. we could just punt and pass the body.
 128                      `(($apply) ((mquote) ((lambda) ((mlist) ,@evl) ,@body))
 129                        ((mquote simp) ((mlist) ,@(mapcar-eval evl))))))
 130