1;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;; 2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3;;; The data in this file contains enhancments. ;;;;; 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 "e 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;;; These are the LAMBDA forms. They have macro properties that set 114;;; up very different things in compiled code. 115 116;;; (FUNGEN&ENV-for-meval <eval vars list> <late eval vars list> <EXP>) 117;;won't work in cl. fix later. 118(defquote fungen&env-for-meval (&rest args) 119 (destructuring-let (((evl nil . body) args)) 120 ;;; all we want to do here is make sure that the EVL gets 121 ;;; evaluated now so that we have some kind of compatibility 122 ;;; with compiled code. we could just punt and pass the body. 123 `(($apply) ((mquote) ((lambda) ((mlist) ,@evl) ,@body)) 124 ((mquote simp) ((mlist) ,@(mapcar-eval evl)))))) 125 126