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 &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;;; 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