home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / fcall.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  13.0 KB  |  401 lines
  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. (macsyma-module fcall)
  14.  
  15. (TRANSL-MODULE FCALL)
  16.  
  17. ;;; Bug-Fixes:
  18. ;;;
  19. ;;; 11/15/80    KMP    Remove *TRIED-TO-AUTOLOAD* as a global and replaced
  20. ;;;            MFUNCTION-CALL with a trampoline function that calls
  21. ;;;            MFUNCTION-CALL-AUX with this info since MFUNCTION-CALL
  22. ;;;            was being screwed by the non-local nature of this var
  23. ;;;            when calls to itself got nested.
  24. ;;;
  25.  
  26. ;;; This file is for macros, fsubrs, and subrs which are run time 
  27. ;;; support for interpreted translated macsyma code.
  28.  
  29. (defun _eval (x)
  30.   #+NIL (si:internal-eval x)
  31.   #-NIL (eval x))
  32.  
  33. ;;; #+(OR NIL LMI) This poor man's closures stuff should go, and get replaced
  34. ;;; by the real thing!
  35.  
  36. ;;; MFUNCTION-CALL is a macro in LIBMAX;TRANSQ
  37. ;;; This is an FSUBR for use in interpreted code.
  38. ;;; It should do quit a bit of checking for STATUS PUNT NIL lossage, etc.
  39. ;;; The macro will expand into code which will assume normal
  40. ;;; functional argument evaluation.
  41.  
  42. (DEFMVAR $TR_WARN_BAD_FUNCTION_CALLS T
  43.      "Warn when strange kinds of function calls are going on in
  44.      translated code.")
  45.  
  46. (DEFVAR *TR-RUNTIME-WARNED* NIL
  47.     "This is an alist of warnings which have been given")
  48.  
  49. (DEFMFUN $TR_WARNINGS_GET ()
  50.        `((MLIST) ,@(MAPCAR #'(LAMBDA (U)
  51.                      `((MLIST) ,(CAR U) ,(CDR U)))
  52.                *TR-RUNTIME-WARNED*)))
  53.  
  54.  
  55. (DEFUN MFUNCTION-CALL-WARN (F TYPE)
  56.        (COND ((ASSQ F *TR-RUNTIME-WARNED*))
  57.          (T
  58.           (PUSH (CONS F TYPE) *TR-RUNTIME-WARNED*)
  59.           (COND ($TR_WARN_BAD_FUNCTION_CALLS
  60.              (LET ((TABL (CDR (ASSQ TYPE '((FEXPR . (FEXPR-WARNEDP 
  61. "This may be due to lack of enough translation data *print-base* info."))
  62.                            (MACRO . (MACRO-WARNEDP 
  63. "Macros should to be loaded when you are translating."))
  64.                            (UNDEFINED . (UNDEFINED-WARNP
  65. "The function was totaly undefined. Maybe you want to quote it."))
  66.                            (PUNT-NIL . (PUNT-NIL-WARNP
  67. "If you want the value of the function name, use APPLY"))
  68.                            (MFEXPR . (MFEXPR-WARNEDP
  69. "MFEXPRS should be loaded at translating time. Use of them in
  70. translated code (nay, any code!), is NOT recommened however.")))))))
  71.               (COND ((NULL TABL))
  72.                 ((GET F (CAR TABL)))
  73.                 (T
  74.                  (PUTPROP F T (CAR TABL))
  75.                  (TERPRI)
  76.                  (PRINC "Warning: ")
  77.                  (MGRIND F NIL)
  78.                  (PRINC
  79.  " has a function or macro call which has not been
  80. translated properly.")
  81.                  (COND ((CDR TABL)
  82.                     (TERPRI)
  83.                     (PRINC (CADR TABL))))))))))))
  84.          
  85. (DEFUN MAPCAR-EVAL (X) (MAPCAR #'_EVAL X))
  86.  
  87. ;(defmacro max-funcall (f &rest args)
  88. ;  (cond ((fboundp f) `(,f ,@ args))
  89. ;    (t`(max-funcall-aux ',f ',args (list ,@ args)))))
  90. ;
  91. ;(defun max-funcall-aux (fn arglis-syms vals &aux mfun args)
  92. ;  (cond ((functionp fn)(apply fn vals))
  93. ;    ((fboundp fn)(fsignal "can't funcall a macro or special form"))
  94. ;    ((setq mfun (mget fn 'mexpr))
  95. ;     (show mfun)
  96. ;     (progv (setq args(cdr (second mfun))) vals
  97. ;       (show args vals)
  98. ;         (show (and  (boundp (car args)) (symbol-value (car args))))
  99. ;           (mlambda mfun vals fn t)))
  100. ;    (t (fsignal "unknown function call"))))
  101. ;
  102. ;(defun foo (xx)
  103. ;  (mfunction-call $ff xx))
  104.  
  105. #+cl
  106. (defmacro MFUNCTION-CALL  (f &rest ARGL)
  107.   (cond ((fboundp f)
  108.       `(,f ,@ argl))
  109.     (t  ;;loses if the argl could not be evaluated but macsyma "e functions
  110.         ;;but the translator should be fixed so that if (mget f 'mfexprp) is t
  111.         ;;then it doesn't translate as an mfunction-call.
  112.      `(lispm-MFUNCTION-CALL-AUX ', f ',ARGL (list ,@ argl) NIL))))
  113. #-cl
  114. (DEFUN MFUNCTION-CALL FEXPR (F+ARGL)
  115.        (MFUNCTION-CALL-AUX (CAR F+ARGL) (CDR F+ARGL) NIL))
  116.  
  117. (DEFUN LISPM-MFUNCTION-CALL-AUX (F ARGL list-argl AUTOLOADED-ALREADY? &aux f-prop)
  118.   (COND
  119.     ((functionp F)
  120.      (APPLY F list-argl))
  121.     ((macro-function f)  ;(SETQ F-PROP (GET F 'MACRO))
  122.      (eval (cons f list-argl)))
  123.     ((not (symbolp f)) (error "expected symbol or function"))
  124.     ((setq f-prop (get f 'mfexpr*))
  125.      ;;save a cons with (locf argl) not(cons nil argl)
  126.      (funcall f-prop (locf argl)))
  127.     ((SETQ F-PROP (MGET F 'MEXPR))
  128.      (COND ((MGET F 'MFEXPRP)
  129.         (MFUNCTION-CALL-WARN F 'MFEXPR)
  130.         (MEVAL (CONS (LIST F) ARGL)))
  131.        (T
  132.         (mlambda f-prop list-argl f nil nil))))
  133.     ((SETQ F-PROP (GET F 'AUTOLOAD))
  134.      (COND (AUTOLOADED-ALREADY?
  135.         (MERROR "~:@M, Function undefined after loading file:~A "
  136.             F
  137.             (NAMESTRING (GET F 'AUTOLOAD))))
  138.        
  139.        (T
  140.         (funcall autoload (cons f F-PROP))
  141.         (lispm-MFUNCTION-CALL-AUX F ARGL list-argl T))))
  142.     
  143.     ((BOUNDP F)
  144.      (MFUNCTION-CALL-WARN F 'PUNT-NIL)
  145.      (MAPPLY (_EVAL F) (MAPCAR-EVAL ARGL) F))
  146.     (T
  147.      (MFUNCTION-CALL-WARN F 'UNDEFINED)
  148.      `((,F) ,@ list-argl))))
  149.  
  150. #-cl
  151. (DEFUN MFUNCTION-CALL-AUX (F ARGL AUTOLOADED-ALREADY?)
  152.        (LET ((F-PROP))
  153.         (COND #+NIL
  154.           ((FBOUNDP F)
  155.            (APPLY F (MAPCAR-EVAL ARGL)))
  156.           ((SETQ F-PROP (GETL F '(EXPR LEXPR)))
  157.            (APPLY  (CADR F-PROP) (MAPCAR-EVAL ARGL)))
  158.           ((GETL F '(SUBR LSUBR))
  159.            (APPLY F (MAPCAR-EVAL ARGL)))
  160.           ((GETL F '(FEXPR FSUBR))
  161.            (MFUNCTION-CALL-WARN F 'FEXPR)
  162.            (APPLY  F ARGL))
  163.           ((SETQ F-PROP (GET F 'MACRO))
  164.            (MFUNCTION-CALL-WARN F 'MACRO)
  165.            (_EVAL (FUNCALL F-PROP (CONS F ARGL))))
  166.           ((SETQ F-PROP (MGET F 'MEXPR))
  167.            (COND ((MGET F 'MFEXPRP)
  168.               (MFUNCTION-CALL-WARN F 'MFEXPR)
  169.               (MEVAL (CONS (LIST F) ARGL)))
  170.              (T
  171.               (MAPPLY1 F-PROP (MAPCAR-EVAL ARGL) '|a translated fcall.| nil))))
  172.           ((SETQ F-PROP (GET F 'AUTOLOAD))
  173.            (COND (AUTOLOADED-ALREADY?
  174.               (MERROR "~:@M, Function undefined after loading file:~A "
  175.                   F
  176.                   (NAMESTRING (GET F 'AUTOLOAD))))
  177.                   
  178.              (T
  179.               (funcall autoload (cons f F-PROP))
  180.               (MFUNCTION-CALL-AUX F ARGL T))))
  181.           ((BOUNDP F)
  182.            (MFUNCTION-CALL-WARN F 'PUNT-NIL)
  183.            (MAPPLY1 (_EVAL F) (MAPCAR-EVAL ARGL) F nil))
  184.           (T
  185.            (MFUNCTION-CALL-WARN F 'UNDEFINED)
  186.            `((,F) ,@(MAPCAR-EVAL ARGL))))))
  187.  
  188. ;;; I think that that just about covers it.
  189.  
  190. ;;; This FEXPR may not work if it is not compiled.
  191. #-cl
  192. (defun TRD-MSYMEVAL fexpr ( L)
  193.        (LET ((A-VAR? (CAR L)))
  194.         (COND ((BOUNDP A-VAR?)
  195.            (_EVAL A-VAR?))   ;;; ouch!
  196.           (t
  197.            ;; double ouch!
  198.            (set A-VAR? (cond ((cdr l) (_EVAL (cadr l)))
  199.                      (t a-var?)))))))
  200. #+cl
  201. (defquote TRD-MSYMEVAL (&rest L)
  202.        (LET ((A-VAR? (CAR L)))
  203.         (COND ((BOUNDP A-VAR?)
  204.            (_EVAL A-VAR?))   ;;; ouch!
  205.           (t
  206.            ;; double ouch!
  207.            (set A-VAR? (cond ((cdr l) (_EVAL (cadr l)))
  208.                      (t a-var?)))))))
  209.  
  210. (DEFUN EXPT$ (A B)
  211.        (EXPT A B))
  212.  
  213. ;;; These are the LAMBDA forms. They have macro properties that set
  214. ;;; up very different things in compiled code.
  215.  
  216. ;;; (M-TLAMBDA ,@(CDR T-FORM))))
  217. ;;; (M-TLAMBDA& ,@(CDR T-FORM))))))
  218.  
  219.  
  220. (DEFUN MAKE-M-LAMBDA& (ARGL BODY)
  221.        (DO ((L NIL)
  222.         (LARGS ARGL (CDR LARGS))
  223.         (J 1 (f1+ J)))
  224.        ((NULL (CDR LARGS))
  225.         `(LAMBDA *N*
  226.              ((LAMBDA ,ARGL ,@BODY)
  227.               ,@(NREVERSE L)
  228.               (CONS '(MLIST) (LISTIFY (f- ,(f1- J) *N*))))))
  229.        (PUSH `(ARG ,J) L)))
  230.  
  231. #-cl 
  232. (DEFUN M-TLAMBDA FEXPR (ARGS)
  233.        (CONS 'LAMBDA ARGS))
  234.  
  235. #+(and (not cl) lispm )
  236. (defquote M-TLAMBDA (&rest ARGS)
  237.        (CONS 'LAMBDA ARGS))
  238.  
  239. (DEFVAR *FCALL-MEMORY* NIL
  240.     "This ALIST will never be very long. Considerably less hairy then
  241.     a hashing scheme, perhaps faster in normal use. In either case
  242.     there is the problem of garbage from red-defined functions.")
  243. #-cl
  244. (DEFUN M-TLAMBDA& FEXPR (ARGS)
  245.        (LET ((FORM (ASSQ ARGS *FCALL-MEMORY*)))
  246.         (COND (FORM (CDR FORM))
  247.           (T
  248.            (SETQ FORM (MAKE-M-LAMBDA& (CAR ARGS) (CDR ARGS)))
  249.            (PUSH (CONS ARGS FORM) *FCALL-MEMORY*)
  250.            FORM))))
  251.  
  252. #+(and (not cl)lispm)
  253. (defquote M-TLAMBDA& (&rest ARGS)
  254.        (LET ((FORM (ASSQ ARGS *FCALL-MEMORY*)))
  255.         (COND (FORM (CDR FORM))
  256.           (T
  257.            (SETQ FORM (MAKE-M-LAMBDA& (CAR ARGS) (CDR ARGS)))
  258.            (PUSH (CONS ARGS FORM) *FCALL-MEMORY*)
  259.            FORM))))
  260.  
  261. (DEFUN EVALQUOTE (EXP)
  262.        (SETQ EXP (_EVAL EXP))
  263.        (COND ((NUMBERP EXP) EXP)
  264.          (T `(QUOTE ,EXP))))
  265. #-cl
  266. (DEFUN M-TLAMBDA&ENV FEXPR (ARGS)
  267.        (LET (( ((REG-ARGL ENV-ARGL) . BODY)  ARGS))
  268.         `(LAMBDA ,REG-ARGL ((LAMBDA ,ENV-ARGL ,@BODY) ,@(MAPCAR 'EVALQUOTE
  269.                                     ENV-ARGL)))))
  270.  
  271. #+(and (not cl)lispm)
  272. (defquote M-TLAMBDA&ENV (&rest ARGS)
  273.        (LET (( ((REG-ARGL ENV-ARGL) . BODY)  ARGS))
  274.         `(LAMBDA ,REG-ARGL ((LAMBDA ,ENV-ARGL ,@BODY) ,@(MAPCAR 'EVALQUOTE
  275.                                     ENV-ARGL)))))
  276. #-cl
  277. (DEFUN M-TLAMBDA&ENV& FEXPR (ARGS)
  278.        (LET (( ((REG-ARGL ENV-ARGL) . BODY)  ARGS))
  279.         (make-M-LAMBDA& REG-ARGL `(((LAMBDA ,ENV-ARGL ,@BODY)
  280.                     ,@(MAPCAR 'EVALQUOTE ENV-ARGL))))))
  281.  
  282. #+(and (not cl) lispm ) ;;now defined by tranq.lisp  The optimizer method taken out.
  283. (defquote M-TLAMBDA&ENV& (&rest ARGS)
  284.        (LET (( ((REG-ARGL ENV-ARGL) . BODY)  ARGS))
  285.         (make-M-LAMBDA& REG-ARGL `(((LAMBDA ,ENV-ARGL ,@BODY)
  286.                     ,@(MAPCAR 'EVALQUOTE ENV-ARGL))))))
  287.  
  288. ;;; (FUNGEN&ENV-for-meval <eval vars list> <late eval vars list>  <EXP>)
  289. #-cl
  290. (DEFUN FUNGEN&ENV-FOR-MEVAL FEXPR (ARGS)
  291.        (LET (((EVL LEVL . BODY) ARGS))
  292.         ;;; all we want to do here is make sure that the EVL gets
  293.         ;;; evaluated now so that we have some kind of compatibility
  294.         ;;; with compiled code. we could just punt and pass the body.
  295.         `(($APPLY) ((MQUOTE) ((LAMBDA) ((MLIST) ,@EVL) ,@BODY))
  296.                ((MQUOTE SIMP) ((MLIST) ,@(MAPCAR-EVAL EVL))))))
  297.  
  298. ;;; (FUNGEN&ENV-for-meval <eval vars list> <late eval vars list>  <EXP>)
  299. ;;won't work in cl.  fix later.
  300. #+cl
  301. (defquote FUNGEN&ENV-FOR-MEVAL (&rest ARGS)
  302.        (LET (((EVL LEVL . BODY) ARGS))
  303.         ;;; all we want to do here is make sure that the EVL gets
  304.         ;;; evaluated now so that we have some kind of compatibility
  305.         ;;; with compiled code. we could just punt and pass the body.
  306.         `(($APPLY) ((MQUOTE) ((LAMBDA) ((MLIST) ,@EVL) ,@BODY))
  307.                ((MQUOTE SIMP) ((MLIST) ,@(MAPCAR-EVAL EVL))))))
  308.  
  309. ;;; (FUNGEN&ENV-FOR-MEVALSUMARG EVL VAR <translate-exp> <untranslated-exp>)
  310.  
  311. ;;; The following code depends on the fact that the argument to an
  312. ;;; FEXPR is always EQ, for a given instance of FEXPR call. Lets say
  313. ;;; that the efficiency of the code depends on that fact. We cannot use
  314. ;;; displacing macros because of the $SAVE problem which I really don't
  315. ;;; feel like fooling around with since it is an IN-CORE function, and
  316. ;;; totaly cryptic code.
  317. #-cl
  318. (DEFUN FUNGEN&ENV-FOR-MEVALSUMARG FEXPR (ARGS)
  319.        (LET ((RES (ASSQ ARGS *FCALL-MEMORY*)))
  320.         (COND ((NULL RES)
  321.            (LET (((EVL LEVL T-BODY M-BODY) ARGS))
  322.             (SETQ RES (GENSYM))
  323.             (PUTPROP RES
  324.                  (coerce
  325.                  `(LAMBDA (*IGNORED*)
  326.                       (PROG2 (MBIND ',EVL
  327.                             (GET ',RES 'SUMARG-ENV) NIL)
  328.                          (MEVALATOMS ',M-BODY)
  329.                          (MUNBIND ',EVL)))
  330.                  'function)
  331.                  'MEVALSUMARG-MACRO)
  332.             ;; Obsolete and replaced by the following form --wj
  333. ;;;             (PUTPROP RES
  334. ;;;                  `(LAMBDA ()
  335. ;;;                       (APPLY #'(LAMBDA ,EVL ,T-BODY)
  336. ;;;                          (GET ',RES 'SUMARG-ENV)))
  337. ;;;                  'EXPR)
  338.             (setf (symbol-function res)
  339.                   (coerce
  340.                    `(lambda ()
  341.                   (apply #'(lambda ,evl ,t-body)
  342.                      (get ',res 'sumarg-env)))
  343.                    'function))
  344.             (SETQ RES `(,ARGS ,RES ((,RES))))
  345.             (PUSH RES *FCALL-MEMORY*))))
  346.         (PUTPROP (CADR RES) (MAPCAR #'EVAL (CAR ARGS)) 'SUMARG-ENV)
  347.         (CADDR RES)))
  348.  
  349. ;;; (FUNGEN&ENV-FOR-MEVALSUMARG EVL VAR <translate-exp> <untranslated-exp>)
  350.  
  351. ;;; The following code depends on the fact that the argument to an
  352. ;;; FEXPR is always EQ, for a given instance of FEXPR call. Lets say
  353. ;;; that the efficiency of the code depends on that fact. We cannot use
  354. ;;; displacing macros because of the $SAVE problem which I really don't
  355. ;;; feel like fooling around with since it is an IN-CORE function, and
  356. ;;; totaly cryptic code.
  357.  
  358. #+cl
  359. (defquote FUNGEN&ENV-FOR-MEVALSUMARG (&rest ARGS)
  360.        (LET ((RES (ASSQ ARGS *FCALL-MEMORY*)))
  361.         (COND ((NULL RES)
  362.            (LET (((EVL LEVL T-BODY M-BODY) ARGS))
  363.             (SETQ RES (GENSYM))
  364.             (PUTPROP RES
  365.                  (coerce
  366.                  `(LAMBDA (*IGNORED*)
  367.                       (PROG2 (MBIND ',EVL
  368.                             (GET ',RES 'SUMARG-ENV) NIL)
  369.                          (MEVALATOMS ',M-BODY)
  370.                          (MUNBIND ',EVL)))
  371.                  'function)
  372.                  'MEVALSUMARG-MACRO)
  373.             ;; Obsolete and replaced by the following form --wj
  374. ;;;             (PUTPROP RES
  375. ;;;                  `(LAMBDA ()
  376. ;;;                       (APPLY #'(LAMBDA ,EVL ,T-BODY)
  377. ;;;                          (GET ',RES 'SUMARG-ENV)))
  378. ;;;                  'EXPR)
  379.             (setf (symbol-function res)
  380.                   (coerce
  381.                    `(lambda ()
  382.                   (apply #'(lambda ,evl ,t-body)
  383.                      (get ',res 'sumarg-env)))
  384.                    'function))
  385.             (SETQ RES `(,ARGS ,RES ((,RES))))
  386.             (PUSH RES *FCALL-MEMORY*))))
  387.         (PUTPROP (CADR RES) (MAPCAR #'EVAL (CAR ARGS)) 'SUMARG-ENV)
  388.         (CADDR RES)))
  389.  
  390. #-cl
  391. (DEFUN M-TLAMBDA-I FEXPR (ARGS)
  392.        `(LAMBDA ,@(CDDR ARGS)))
  393.  
  394. #+cl
  395. (defquote M-TLAMBDA-I (&rest ARGS)
  396.        `(LAMBDA ,@(CDDR ARGS)))
  397.  
  398. #+MACLISP
  399. (DEFUN COMPILE-FORMS-TO-COMPILE-QUEUE FEXPR (FORM) FORM)
  400.  
  401.