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 / mlisp.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  99.1 KB  |  2,724 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. (in-package "MAXIMA")
  10. ;    ** (c) Copyright 1982 Massachusetts Institute of Technology **
  11.  
  12. (macsyma-module mlisp)
  13.  
  14. #-(or cl NIL)
  15. (EVAL-WHEN (EVAL COMPILE) (SETQ OLD-IBASE *read-base* *read-base* 10.))
  16. #+cl
  17. (EVAL-WHEN (EVAL COMPILE) (SETQ OLD-read-base *read-BASE* *read-base* 10.))
  18.  
  19. (declare-top (SPECIAL MSPECLIST MPROPLIST BINDLIST LOCLIST BVARS NOUNSFLAG putl
  20.           NOITEMS DERIVFLAG DERIVLIST MPROGP MDOP EVP AEXPRP MLOCP $LABELS
  21.           $VALUES $FUNCTIONS $ARRAYS $RULES $GRADEFS $DEPENDENCIES $ALIASES
  22.           $MYOPTIONS $PROPS GENVAR $MAXPOSEX $MAXNEGEX $EXPOP $EXPON
  23.           $FLOAT $NUMER ARYP MSUMP STATE-PDL EVARRP $SETVAL NOUNL
  24.           $SETCHECKBREAK $REFCHECK DEBUG REFCHKL BAKTRCL MAPLP
  25.           $NOREPEAT $DETOUT $DOALLMXOPS $DOSCMXOPS OPERS FACTLIST OPEXPRP
  26.           $TRANSLATE $TRANSRUN $MAPERROR OUTARGS1 OUTARGS2 FMAPLVL MOPL
  27.           $POWERDISP $SUBSCRMAP $DISPFLAG $OPTIONSET DSKSETP FEXPRERRP
  28.           $FEATURES ALPHABET $%ENUMER $INFEVAL $SAVEDEF $%% %E-VAL
  29.           $MAPPRINT FEATUREL OUTFILES FUNDEFSIMP MFEXPRP TRANSP
  30.           SFINDEX MSPECLIST2 ENVLIST $MACROS LINEL $RATFAC $RATWTLVL
  31.           $OPERATORS NOEVALARGS $PIECE $PARTSWITCH *GCDL*
  32.           SCANMAPP))
  33. (declare-top (unspecial args))
  34. #-cl (proclaim ' (GENPREFIX %LS))
  35. #-cl(proclaim '     (*EXPR RATF $FLOAT))
  36. #-cl(proclaim '     (*LEXPR MAP1 MMAPCAR FMAPL1 OUTERMAP1 $INPART LINEL $DIFF $INTEGRATE
  37.          $LDISP $RATVARS $RATWEIGHT))
  38. (declare-top     (FIXNUM N I J NNEED NGIVEN NCELLS NITEMS LISPSUB INDX FMAPLVL EVFLG 
  39.              LINEL SFINDEX #-cl (HASHER)))
  40. ;  NNEED to be flushed
  41.  
  42. (SETQ MSPECLIST NIL BINDLIST NIL LOCLIST NIL MPROPLIST NIL $%ENUMER NIL
  43.       $FLOAT NIL NOUNL NIL $REFCHECK NIL SCANMAPP NIL MAPLP NIL
  44.       MPROGP NIL EVP NIL MDOP NIL MLOCP NIL PUTL NIL
  45.       $SUBSCRMAP NIL $TRANSLATE NIL $TRANSRUN T $SAVEDEF T AEXPRP NIL
  46.       $MAPERROR T FMAPLVL 0 $OPTIONSET NIL 
  47.       $SETCHECKBREAK NIL DSKSETP NIL ARYP NIL MSUMP NIL EVARRP NIL
  48.       $INFEVAL NIL FACTLIST NIL $MAPPRINT T FUNDEFSIMP NIL
  49.       MFEXPRP T NOUNSFLAG NIL OPEXPRP NIL ;$OPERATORS NIL
  50.       SFINDEX 1 MSPECLIST2 NIL ENVLIST NIL TRANSP NIL NOEVALARGS NIL
  51.       $PIECE '$PIECE $SETVAL '$SETVAL FEXPRERRP NIL RULEFCNL NIL
  52.       FEATUREL (PURCOPY '($INTEGER $NONINTEGER $EVEN $ODD
  53.               $RATIONAL $IRRATIONAL $REAL $IMAGINARY
  54.               $COMPLEX $ANALYTIC $INCREASING $DECREASING
  55.               $ODDFUN $EVENFUN $POSFUN $COMMUTATIVE $LASSOCIATIVE
  56.               $RASSOCIATIVE $SYMMETRIC $ANTISYMMETRIC))
  57.       $FEATURES (CONS '(MLIST SIMP) (APPEND FEATUREL NIL)))
  58.  
  59. ;; These three variables are what get stuck in array slots as magic
  60. ;; unbound objects.  They are for T, FIXNUM, and FLONUM type arrays
  61. ;; respectively.
  62.  
  63. (DEFVAR MUNBOUND '|#####|)
  64.  
  65. ;; The most negative fixnum.  Sign bit is on and all other bits are zero.
  66. ;; Assumes two's complement arithmetic.
  67. (DEFVAR FIXUNBOUND
  68.   #+(or cl NIL) MOST-NEGATIVE-FIXNUM
  69.   #-(or NIL cl) (ROT 1 -1))
  70.  
  71. ;; The PDP10 floating point representation is:
  72. ;; 1 bit sign, 8 bit exponent, 27 bit mantissa
  73. ;; If positive, exponent is excess 128.  If negative, exponent is one's
  74. ;; complement of excess 128.
  75. ;; If positive normalized, mantissa is between 2^26 and 2^27-1.  If negative,
  76. ;; two's complement.  See RAT;FLOAT for more details.
  77.  
  78. ;; I think this is supposed to be the most negative flonum.  It's close,
  79. ;; but not quite.  The smallest is (FSC (ROT 3 -1) 0).
  80.  
  81. #+PDP10
  82. (DEFVAR FLOUNBOUND (FSC (f- 2 (LSH -1 -1)) 0))
  83.  
  84. ;; H6180 floating point representation is:
  85. ;; 8 bit exponent, 1 bit sign, 27 bit mantissa
  86. ;; The 8 bit exponent is viewed as two's complement, between 2^7-1 and -2^7.
  87. ;; The 28 bit mantissa is viewed as two's complement, between -1 and 1-2^-27.
  88. ;; The most negative flonum is given below.  The most positive flonum
  89. ;; is its logical complement.
  90.  
  91. #+H6180
  92. (DEFVAR FLOUNBOUND (FSC (LOGIOR (LSH 1 35.) (LSH 1 27.)) 0))
  93.  
  94. ;; Too bad there's no general way of getting the most negative flonum in
  95. ;; a relatively machine-independent manner.
  96.  
  97. #+LISPM
  98. (DEFVAR FLOUNBOUND '*FLOUNBOUND-DOESNT-MATTER-ANYWAY*)
  99.  
  100. #+(or cl NIL)
  101. (DEFVAR FLOUNBOUND MOST-NEGATIVE-DOUBLE-FLOAT)
  102.  
  103. (DEFMVAR MUNBINDP NIL
  104.   "Used for safely MUNBINDing incorrectly-bound variables."
  105.   NO-RESET)
  106. (DEFMVAR $SETCHECK NIL)
  107.  
  108. (MAPC #'(LAMBDA (X) (SET X (NCONS '(MLIST SIMP))))
  109.       '($VALUES $FUNCTIONS $MACROS $ARRAYS $MYOPTIONS $RULES $PROPS))
  110.  
  111.  
  112. (DEFMFUN MAPPLY1 (FN ARGS FNNAME form)
  113.   (declare( special aryp) (object fn))
  114.  (COND ;((AND $OPERATORS (MNUMP FN)) (MUL2 FN (CAR ARGS)))
  115.        ((ATOM FN) 
  116.     (cond
  117.      #-cl                ; #+(or cl nil)
  118.      ((and (symbolp fn) (fboundp fn)
  119.            (not (consp symbol-function fn)))
  120.       (apply  fn args))
  121.      #+(or cl nil)
  122.      ((ATOM FN) 
  123.       (cond
  124.        #+(or cl nil)
  125.        ((functionp fn)
  126.         (APPLY FN ARGS))
  127.       
  128.        #+cl;;better be a macro or an array.
  129.        ((fboundp fn)
  130.         (if (macro-function fn)
  131.             (progn (merror "~M is a lisp level macro and cannot be applied at maxima level" fn) (eval (cons fn  args)))
  132.           (mapply1 (symbol-function fn) args fn form)))
  133.        
  134.       ((symbol-array fn)
  135.        (mapply1 (symbol-array fn) args fn form))
  136.       (t
  137.        (SETQ FN (GETOPR FN)) (BADFUNCHK FNNAME FN NIL)
  138.        (LET ((NOEVALARGS T)) (MEVAL (CONS (NCONS FN) ARGS)))))
  139.      )))
  140.        #+cl
  141.        ((functionp fn)
  142.     (apply fn args))
  143.        #+cl
  144.        ((EQ (CAR FN) 'LAMBDA) (APPLY (COERCE FN 'FUNCTION) ARGS))
  145.        #-cl
  146.        ((EQ (CAR FN) 'LAMBDA) (APPLY FN ARGS))
  147.        #+(and Lispm (not cl))
  148.        ((memq (CAR FN)
  149.           '(NAMED-LAMBDA si:digested-lambda)) (APPLY FN ARGS))
  150.        #-cl
  151.        ((AND (EQ (CAAR FN) 'MFILE)
  152.          (SETQ FN (EVAL (DSKGET (CADR FN) (CADDR FN) 'VALUE NIL)))
  153.          NIL))
  154.        ((EQ (CAAR FN) 'LAMBDA) (MLAMBDA FN ARGS FNNAME T form))
  155.        ((EQ (CAAR FN) 'MQUOTE) (CONS (CDR FN) ARGS))
  156.        ((AND ARYP (MEMQ (CAAR FN) '(MLIST $MATRIX)))
  157.     (IF (NOT (OR (= (LENGTH ARGS) 1)
  158.              (AND (EQ (CAAR FN) '$MATRIX) (= (LENGTH ARGS) 2))))
  159.         (MERROR "Wrong number of indices:~%~M" (CONS '(MLIST) ARGS)))
  160.     (DO ((ARGS1 ARGS (CDR ARGS1)))
  161.         ((NULL ARGS1) (LET (($PIECE $PIECE) ($PARTSWITCH 'MAPPLY))
  162.                    (APPLY #'$INPART (CONS FN ARGS))))
  163.         (UNLESS (fixnump (car args1))
  164.             (IF EVARRP (THROW 'EVARRP 'NOTEXIST))
  165.             (MERROR "Subscript must be an integer:~%~M" (CAR ARGS1)))))
  166.        (ARYP (CONS '(MQAPPLY ARRAY) (CONS FN ARGS)))
  167.        ((MEMQ 'array (CDAR FN)) (CONS '(MQAPPLY) (CONS FN ARGS)))
  168.        (T (BADFUNCHK FNNAME FN T))))
  169.  
  170. #-NIL
  171. ;; the last argument to mapply1 for the lineinfo is not correct here..
  172. (DEFMFUN MCALL N (MAPPLY1 (ARG 1) (LISTIFY (f- 1 N)) (ARG 1) nil))
  173.  
  174. #+NIL
  175. (DEFMFUN MCALL (FN &REST ARGS)
  176.   (MAPPLY1 FN ARGS FN nil))
  177.  
  178. #-NIL
  179. (declare-top (MAPEX T))  ; To avoid the overuse of pdls in this highly recursive 
  180.              ; part of the evaluator.
  181.  
  182. (DEFUN MEVALARGS (ARGS)
  183.  (COND (NOEVALARGS (SETQ NOEVALARGS NIL) ARGS) (T (MAPCAR #'MEVAL ARGS))))
  184.  
  185. ;Function Call stack each element is
  186. ; (fname . bindlist) where bindlist was the value at time of entry.
  187. ; So you can use this to compute what the bindings were at any
  188. ; function call.
  189. (defvar *mlambda-call-stack* (make-array 30 :fill-pointer 0 :adjustable t ))
  190.  
  191. #-NIL 
  192. (declare-top (MAPEX NIL))
  193.  
  194. (DEFUN MLAMBDA (FN ARGS FNNAME NOEVAL form)
  195.   (COND ((NOT ($LISTP (CADR FN)))
  196.      (MERROR "First argument to LAMBDA must be a list:~%~M" (CADR FN))))
  197.   (SETQ NOEVALARGS NIL)
  198.   (let ((PARAMS  (CDADR FN))( MLOCP  T))
  199.     (SETQ LOCLIST (CONS NIL LOCLIST))
  200.     (DO ((A) (P))
  201.     ((OR (NULL PARAMS) (AND (NULL ARGS) (NOT (MDEFLISTP PARAMS))))
  202.      (SETQ ARGS (NRECONC A ARGS) PARAMS (NRECONC P PARAMS)))
  203.       (COND ((MDEFLISTP PARAMS)
  204.          (SETQ PARAMS (CDAR PARAMS) ARGS (NCONS (CONS '(MLIST) ARGS)))))
  205.       (COND ((AND MFEXPRP (MQUOTEP (CAR PARAMS)))
  206.          (SETQ A (CONS (CAR ARGS) A) P (CONS (CADAR PARAMS) P)))
  207.         ((ATOM (CAR PARAMS))
  208.          (SETQ P (CONS (CAR PARAMS) P)
  209.            A (CONS (COND (NOEVAL (CAR ARGS))
  210.                  (T (MEVAL (CAR ARGS)))) A)))
  211.         (T (MERROR "Illegal LAMBDA parameter:~%~M" (CAR PARAMS))))
  212.       (SETQ ARGS (CDR ARGS) PARAMS (CDR PARAMS)))
  213. ;    (MBINDING (PARAMS ARGS FNNAME)
  214. ;          (PROG1 (LET ((AEXPRP (AND AEXPRP (NOT (ATOM (CADDR FN)))
  215. ;                    (EQ (CAAR (CADDR FN)) 'LAMBDA))))
  216. ;               (COND ((NULL (CDDR FN))
  217. ;                  (MERROR "No LAMBDA body present"))
  218. ;                 ((CDDDR FN) (MEVALN (CDDR FN)))
  219. ;                 (T (MEVAL (CADDR FN)))))
  220. ;             ;; the MUNLOCAL should be unwind-protected,  I can't
  221. ;             ;; see how I can work it into the MBINDING macro
  222. ;             ;; at this time. Too bad for the losers who use it.
  223. ;             (MUNLOCAL)))
  224.     ;; we expand the above, and also add stuff for the call stack.
  225.     ;; we also move munlocal into the unwind protect.
  226.     (let (FINISH2033 (FINISH2032 params) (ar *mlambda-call-stack*))
  227.       (declare (type (vector t) ar))
  228.       (UNWIND-PROTECT
  229.        (PROGN
  230.     (or (f> (array-total-size ar) (f+ (fill-pointer ar) 10))
  231.         (adjust-array ar (f+ (array-total-size ar) 50)
  232.               :fill-pointer (fill-pointer ar)))
  233.     (vector-push bindlist ar)
  234.     ;; rather than pushing all on baktrcl it might be good
  235.     ;; to make a *last-form* global that is set in meval1
  236.     ;; and is pushed here.  
  237.     ;(vector-push baktrcl ar)
  238.     (vector-push form ar)
  239.     (vector-push params ar)
  240.     (vector-push args ar)
  241.     (vector-push fnname ar)
  242.     (MBIND FINISH2032 ARGS FNNAME)
  243.     (SETQ FINISH2033 T)
  244.     (PROG1 (LET ((AEXPRP (AND AEXPRP (NOT (ATOM (CADDR FN)))
  245.                   (EQ (CAAR (CADDR FN)) 'LAMBDA))))
  246.             (COND
  247.              ((NULL (CDDR FN)) (MERROR "No LAMBDA body present"))
  248.              ((CDDDR FN) (MEVALN (CDDR FN)))
  249.              (T (MEVAL (CADDR FN)))))
  250.             nil ))
  251.        (IF FINISH2033 (progn (incf (fill-pointer *mlambda-call-stack*) -5)
  252.                  (MUNLOCAL)
  253.                  (MUNBIND FINISH2032)
  254.                  ))))
  255.  
  256.     ))
  257.  
  258.  
  259. (Defmspec MPROGN (FORM) (MEVALN (CDR FORM)))
  260.  
  261. (DEFMFUN MEVALN (L) ;; called in a few places externally.
  262.  (DO ((BODY L (CDR BODY)) ($%% '$%%)) ((NULL (CDR BODY)) (MEVAL (CAR BODY)))
  263.      (SETQ $%% (MEVAL (CAR BODY)))))
  264.  
  265. ;(DEFMSPEC DOLIST (FORM)  ; temporary
  266. ; (SETF (CAR FORM) '(MPROGN)) (MEVAL FORM))
  267.  
  268. (DEFUN MQAPPLY1 (FORM)
  269.     (declare (special aryp))
  270.  (LET (((FN . ARGL) (CDR FORM)) (AEXPRP))
  271.       (COND ((NOT (MQUOTEP FN)) (SETQ FN (MEVAL FN))))
  272.       (COND ((ATOM FN) (MEVAL (CONS (CONS FN ARYP) ARGL)))
  273.         ((EQ (CAAR FN) 'LAMBDA)
  274.          (COND (ARYP (MERROR "Improper array call"))
  275.            (T (MLAMBDA FN ARGL (CADR FORM) NOEVALARGS form))))
  276.         (T (MAPPLY1 FN (MEVALARGS ARGL) (CADR FORM) form)))))
  277.  
  278. (DEFMFUN MEVAL (FORM) (SIMPLIFYA (MEVAL1 FORM) NIL))
  279. ;;temporary hack to see what's going on:
  280. (DEFMFUN safe-MGETL (ATOM INDS) (and (symbolp atom)
  281.   (LET ((PROPS (GET ATOM 'MPROPS))) (AND PROPS (GETL PROPS INDS)))))
  282. (DEFMFUN safe-MGET (ATOM INDS) (and (symbolp atom)
  283.   (LET ((PROPS (GET ATOM 'MPROPS))) (AND PROPS (GETf (cdr PROPS) INDS)))))
  284.  
  285. (defvar *last-meval1-form* nil)
  286.  
  287. (DEFMFUN MEVAL1 (FORM)
  288.   (declare (special  nounl *break-points* *break-step*))
  289.   (COND ((ATOM FORM)
  290.      (PROG (VAL)
  291.        (COND ((NOT (SYMBOLP FORM)) (RETURN FORM))
  292.          ((AND $NUMER (SETQ VAL (SAFE-MGET FORM '$NUMER))
  293.                (OR (NOT (EQ FORM '$%E)) $%ENUMER))
  294.           (RETURN (MEVAL1 VAL)))
  295.          ((NOT (BOUNDP FORM))
  296.           (IF (SAFE-GET FORM 'BINDTEST)
  297.               (MERROR "~:M unbound variable" FORM)
  298.               (RETURN FORM)))
  299.          ((MFILEP (SETQ VAL (SYMBOL-VALUE FORM)))
  300.           (SETQ VAL
  301.             (EVAL (DSKGET (CADR VAL) (CADDR VAL) 'VALUE NIL)))))
  302.        (WHEN (AND $REFCHECK (MEMQ FORM (CDR $VALUES))
  303.               (NOT (MEMQ FORM REFCHKL)))
  304.          (SETQ REFCHKL (CONS FORM REFCHKL))
  305.          (MTELL "~:M has value.~%" FORM))
  306.        (RETURN VAL)))
  307.     ((OR (AND (ATOM (CAR FORM))
  308.           (SETQ FORM (CONS (NCONS (CAR FORM)) (CDR FORM))))
  309.          (ATOM (CAAR FORM)))
  310.      (LET ((BAKTRCL BAKTRCL) TRANSP) 
  311.        (PROG (U ARYP)
  312.          (declare (special aryp))
  313.          ;;(COND ((EQ DEBUG '$ALL) (SETQ BAKTRCL (CONS FORM BAKTRCL))))
  314.                  (setq *last-meval1-form* form)
  315.          (SETQ ARYP (MEMQ 'array (CDAR FORM))) 
  316.          (COND ((AND (NOT OPEXPRP) (NOT ARYP) 
  317.              (MEMQ (CAAR FORM) '(MPLUS MTIMES MEXPT MNCTIMES)))
  318.             (GO C))
  319.            ;; dont bother pushing mplus and friends on baktrcl
  320.            ;; should maybe even go below aryp.
  321.            ((AND debug
  322.              (PROGN
  323.               ;(SETQ BAKTRCL (CONS FORM BAKTRCL))
  324.               ;; if wanting to step, the *break-points*
  325.               ;; variable will be set to a vector (possibly empty).
  326.               (when (and *break-points*
  327.                      (or (null  *break-step*)
  328.                      (null (funcall *break-step* form))))
  329.                 (let ((ar *break-points*))
  330.                   (declare (type (vector t) ar))
  331.                 (sloop for i below (fill-pointer ar)
  332.                        when (eq (car (aref ar i)) form)
  333.                        do (*break-points* form)
  334.                        (loop-finish))))
  335.                 NIL)))
  336.            ((AND $SUBSCRMAP ARYP
  337.              (DO ((X (MARGS FORM) (CDR X)))
  338.                  ((OR (NULL X) (MXORLISTP (CAR X))) X)))
  339.             (SETQ NOEVALARGS NIL) (RETURN (SUBGEN FORM)))
  340.            ((EQ (CAAR FORM) 'MQAPPLY) (RETURN (MQAPPLY1 FORM))))
  341.          (BADFUNCHK (CAAR FORM) (CAAR FORM) NIL)
  342.         A    (SETQ U (OR (SAFE-GETL (CAAR FORM) '(NOUN))
  343.                  (AND NOUNSFLAG (EQ (GETCHAR (CAAR FORM) 1) '%)
  344.                   (NOT (OR (GETL-FUN (CAAR FORM)
  345.                              '(SUBR FSUBR LSUBR))
  346.                        (SAFE-GETL (CAAR FORM)
  347.                          '(MFEXPR* MFEXPR*S))))
  348.                   (PROG2 ($VERBIFY (CAAR FORM))
  349.                      (SAFE-GETL (CAAR FORM) '(NOUN))))
  350.                  (AND (NOT ARYP) $TRANSRUN
  351.                   (SETQ TRANSP
  352.                     (OR (SAFE-MGETL (CAAR FORM) '(T-MFEXPR))
  353.                         (SAFE-GETL (CAAR FORM)
  354.                           '(TRANSLATED-MMACRO)))))
  355.                  (AND (NOT ARYP)
  356.                   (SETQ U
  357.                     (OR (SAFE-MGET (CAAR FORM) 'TRACE)
  358.                         (AND $TRANSRUN
  359.                          (SAFE-GET (CAAR FORM) 'TRANSLATED)
  360.                          (NOT (SAFE-MGET (CAAR FORM)
  361.                                 'LOCAL-FUN))
  362.                          (SETQ TRANSP T) (CAAR FORM))))
  363.                   (GETL-FUN U '(EXPR SUBR LSUBR)))
  364.                  (COND (ARYP (SAFE-MGETL (CAAR FORM) '(HASHAR ARRAY)))
  365.                    ((SAFE-MGETL (CAAR FORM) '(MEXPR MMACRO)))
  366.                    ((SAFE-MGETL (CAAR FORM) '(T-MFEXPR)))
  367.                    (T (OR (SAFE-GETL (CAAR FORM)
  368.                         '(MFEXPR* MFEXPR*S))
  369.                       (GETL-FUN (CAAR FORM)
  370.                             '(SUBR FSUBR EXPR FEXPR macro
  371.                                LSUBR)))))))
  372.          (COND ((NULL U) (GO B))
  373.            ((AND (MEMQ (CAR U) '(MEXPR MMACRO)) (MFILEP (CADR U)))
  374.             (SETQ U (LIST (CAR U)
  375.                   (DSKGET (CADADR U) (CAR (CDDADR U))
  376.                       (CAR U) NIL))))
  377.            ((AND (MEMQ (CAR U) '(ARRAY HASHAR)) (MFILEP (CADR U)))
  378.             (I-$UNSTORE (NCONS (CAAR FORM)))
  379.             (RETURN (MEVAL1 FORM))))
  380.          (RETURN 
  381.           (COND ((EQ (CAR U) 'HASHAR) 
  382.              (HARRFIND (CONS (CAR FORM) (MEVALARGS (CDR FORM)))))
  383.             ((MEMQ (CAR U) '(FEXPR FSUBR))
  384.              (IF FEXPRERRP
  385.              (MERROR "Attempt to call ~A ~A from MACSYMA level.~
  386.                  ~%Send a bug note."
  387.                  (CAR U) (CAAR FORM)))
  388.              (SETQ NOEVALARGS NIL) (APPLY (CAAR FORM) (CDR FORM)))
  389.             ((OR (AND (EQ (CAR U) 'SUBR)
  390.                   (PROG2 (MARGCHK (CAAR FORM) (CDR FORM)) T))
  391.              (EQ (CAR U) 'LSUBR))
  392. ;               ((MEMQ (CAR U) '(SUBR LSUBR))
  393. ;            (MARGCHK (CAAR FORM) (CDR FORM)))
  394.              (APPLY (CAAR FORM) (MEVALARGS (CDR FORM))))
  395.  
  396.             ((EQ (CAR U) 'NOUN)
  397. ;            (MARGCHK (CAAR FORM) (CDR FORM))
  398.              (COND ((OR (MEMQ (CAAR FORM) NOUNL) NOUNSFLAG)
  399.                 (SETQ FORM (CONS (CONS (CADR U) (CDAR FORM))
  400.                          (CDR FORM)))
  401.                 (GO A))
  402.                (ARYP (GO B))
  403.                ((MEMQ (CAAR FORM) '(%SUM %PRODUCT))
  404.                 (SETQ U (DO%SUM (CDR FORM) (CAAR FORM))
  405.                   NOEVALARGS NIL)
  406.                 (CONS (NCONS (CAAR FORM)) U))
  407.                (T (MEVAL2 (MEVALARGS (CDR FORM)) FORM))))
  408.             ((EQ (CAR U) 'array)
  409.              (ARRFIND (CONS (CAR FORM) (MEVALARGS (CDR FORM)))))
  410.             ((EQ (CAR U) 'MEXPR)
  411.              (MLAMBDA (CADR U) (CDR FORM) (CAAR FORM) NOEVALARGS form))
  412.             ((MEMQ (CAR U) '(MMACRO TRANSLATED-MMACRO))
  413.              (SETQ NOEVALARGS NIL)
  414.              (MEVAL (MMACRO-APPLY (CADR U) FORM)))
  415.             ((EQ (CAR U) 'MFEXPR*)
  416.              (SETQ NOEVALARGS NIL)  (APPLY (CADR U) (NCONS FORM)))
  417.             #+cl
  418.             ((eq (car u) 'macro)
  419.              (setq noevalargs nil)
  420.              (setq form (cons(caar form) (cdr form)))
  421. ;             (setf (car form) (caar form) )
  422.               (eval form)
  423.              )
  424.             #+Maclisp
  425.             ((EQ (CAR U) 'MFEXPR*S)
  426.              (SETQ NOEVALARGS NIL)
  427.              ;; use macsyma Trace if you want to trace this call.
  428.              (SUBRCALL T (CADR U) FORM))
  429.             ((EQ (CAR U) 'T-MFEXPR) (APPLY (CADR U) (CDR FORM)))
  430.             (T (MARGCHK (CAAR FORM) (CDR FORM))
  431.                (APPLY (CADR U) (MEVALARGS (CDR FORM))))))
  432.         B   #+(OR PDP10 Multics Franz NIL cl)
  433.          (IF (AND (NOT ARYP) (LOAD-FUNCTION (CAAR FORM) T)) (GO A))
  434.          (BADFUNCHK (CAAR FORM) (CAAR FORM) NIL)
  435.          (IF (SYMBOLP (CAAR FORM))
  436.          (SETQ U (BOUNDP (CAAR FORM)))
  437.          (RETURN (MEVAL1-EXTEND FORM)))
  438.         C   (COND ((OR (NULL U)
  439.                (AND (SAFE-GET (CAAR FORM) 'OPERATORS) (NOT ARYP))
  440.                (EQ (CAAR FORM) (SETQ U (SYMBOL-VALUE (CAAR FORM)))))
  441.                (SETQ FORM (MEVAL2 (MEVALARGS (CDR FORM)) FORM))
  442.                (RETURN (OR (AND (SAFE-MGET (CAAR FORM) 'ATVALUES)
  443.                     (AT1 FORM)) FORM)))
  444.               ((AND ARYP (SAFE-GET (CAAR FORM) 'NONARRAY))
  445.                (RETURN (CONS (CONS (CAAR FORM) ARYP)
  446.                      (MEVALARGS (CDR FORM)))))
  447.               ((ATOM U)
  448.                (BADFUNCHK (CAAR FORM) U NIL)
  449.                (SETQ FORM (CONS (CONS (GETOPR U) ARYP) (CDR FORM)))
  450.                (GO A))
  451.               ((EQ (CAAR U) 'LAMBDA)
  452.                (IF ARYP
  453.                (MERROR "Improper array call")
  454.                (RETURN (MLAMBDA U (CDR FORM)
  455.                         (CAAR FORM) NOEVALARGS form))))
  456.               (T (RETURN (MAPPLY1 U (MEVALARGS (CDR FORM))
  457.                      (CAAR FORM) form)))))))
  458.     (T (MAPPLY1 (CAAR FORM) (MEVALARGS (CDR FORM)) (CAAR FORM) form))))
  459.  
  460. ;;old def. had some unsafe plist accesses.
  461. ;(DEFMFUN MEVAL1 (FORM)
  462. ;  (declare (special  nounl))
  463. ;  (COND ((ATOM FORM)
  464. ;     (PROG (VAL)
  465. ;       (COND ((NOT (SYMBOLP FORM)) (RETURN FORM))
  466. ;         ((AND $NUMER (SETQ VAL (MGET FORM '$NUMER))
  467. ;               (OR (NOT (EQ FORM '$%E)) $%ENUMER))
  468. ;          (RETURN (MEVAL1 VAL)))
  469. ;         ((NOT (BOUNDP FORM))
  470. ;          (IF (GET FORM 'BINDTEST)
  471. ;              (MERROR "~:M unbound variable" FORM)
  472. ;              (RETURN FORM)))
  473. ;         ((MFILEP (SETQ VAL (SYMBOL-VALUE FORM)))
  474. ;          (SETQ VAL
  475. ;            (EVAL (DSKGET (CADR VAL) (CADDR VAL) 'VALUE NIL)))))
  476. ;       (WHEN (AND $REFCHECK (MEMQ FORM (CDR $VALUES))
  477. ;              (NOT (MEMQ FORM REFCHKL)))
  478. ;         (SETQ REFCHKL (CONS FORM REFCHKL))
  479. ;         (MTELL "~:M has value.~%" FORM))
  480. ;       (RETURN VAL)))
  481. ;    ((OR (AND (ATOM (CAR FORM))
  482. ;          (SETQ FORM (CONS (NCONS (CAR FORM)) (CDR FORM))))
  483. ;         (ATOM (CAAR FORM)))
  484. ;     (LET ((BAKTRCL BAKTRCL) TRANSP) 
  485. ;       (PROG (U ARYP)
  486. ;         (declare (special aryp))
  487. ;         (COND ((EQ DEBUG '$ALL) (SETQ BAKTRCL (CONS FORM BAKTRCL))))
  488. ;         (SETQ ARYP (MEMQ 'array (CDAR FORM))) 
  489. ;         (COND ((AND (NOT OPEXPRP) (NOT ARYP) 
  490. ;             (MEMQ (CAAR FORM) '(MPLUS MTIMES MEXPT MNCTIMES)))
  491. ;            (GO C))
  492. ;           ((AND $SUBSCRMAP ARYP
  493. ;             (DO ((X (MARGS FORM) (CDR X)))
  494. ;                 ((OR (NULL X) (MXORLISTP (CAR X))) X)))
  495. ;            (SETQ NOEVALARGS NIL) (RETURN (SUBGEN FORM)))
  496. ;           ((EQ (CAAR FORM) 'MQAPPLY) (RETURN (MQAPPLY1 FORM))))
  497. ;         (BADFUNCHK (CAAR FORM) (CAAR FORM) NIL)
  498. ;        A    (SETQ U (OR (GETL (CAAR FORM) '(NOUN))
  499. ;                 (AND NOUNSFLAG (EQ (GETCHAR (CAAR FORM) 1) '%)
  500. ;                  (NOT (OR (GETL-FUN (CAAR FORM)
  501. ;                             '(SUBR FSUBR LSUBR))
  502. ;                       (GETL (CAAR FORM)
  503. ;                         '(MFEXPR* MFEXPR*S))))
  504. ;                  (PROG2 ($VERBIFY (CAAR FORM))
  505. ;                     (GETL (CAAR FORM) '(NOUN))))
  506. ;                 (AND (NOT ARYP) $TRANSRUN
  507. ;                  (SETQ TRANSP
  508. ;                    (OR (MGETL (CAAR FORM) '(T-MFEXPR))
  509. ;                        (GETL (CAAR FORM)
  510. ;                          '(TRANSLATED-MMACRO)))))
  511. ;                 (AND (NOT ARYP)
  512. ;                  (SETQ U
  513. ;                    (OR (MGET (CAAR FORM) 'TRACE)
  514. ;                        (AND $TRANSRUN
  515. ;                         (GET (CAAR FORM) 'TRANSLATED)
  516. ;                         (NOT (MGET (CAAR FORM)
  517. ;                                'LOCAL-FUN))
  518. ;                         (SETQ TRANSP T) (CAAR FORM))))
  519. ;                  (GETL-FUN U '(EXPR SUBR LSUBR)))
  520. ;                 (COND (ARYP (MGETL (CAAR FORM) '(HASHAR ARRAY)))
  521. ;                   ((MGETL (CAAR FORM) '(MEXPR MMACRO)))
  522. ;                   ((MGETL (CAAR FORM) '(T-MFEXPR)))
  523. ;                   (T (OR (GETL (CAAR FORM)
  524. ;                        '(MFEXPR* MFEXPR*S))
  525. ;                      (GETL-FUN (CAAR FORM)
  526. ;                            '(SUBR FSUBR EXPR FEXPR macro
  527. ;                               LSUBR)))))))
  528. ;;#+cl     (cond ((eq (car u) 'macro) (show u) (setf (cadr u) (cdadr u))))
  529. ;         (COND ((NULL U) (GO B))
  530. ;           ((AND (MEMQ (CAR U) '(MEXPR MMACRO)) (MFILEP (CADR U)))
  531. ;            (SETQ U (LIST (CAR U)
  532. ;                  (DSKGET (CADADR U) (CAR (CDDADR U))
  533. ;                      (CAR U) NIL))))
  534. ;           ((AND (MEMQ (CAR U) '(ARRAY HASHAR)) (MFILEP (CADR U)))
  535. ;            (I-$UNSTORE (NCONS (CAAR FORM)))
  536. ;            (RETURN (MEVAL1 FORM))))
  537. ;         (RETURN 
  538. ;          (COND ((EQ (CAR U) 'HASHAR) 
  539. ;             (HARRFIND (CONS (CAR FORM) (MEVALARGS (CDR FORM)))))
  540. ;            ((MEMQ (CAR U) '(FEXPR FSUBR))
  541. ;             (IF FEXPRERRP
  542. ;             (MERROR "Attempt to call ~A ~A from MACSYMA level.~
  543. ;                 ~%Send a bug note."
  544. ;                 (CAR U) (CAAR FORM)))
  545. ;             (SETQ NOEVALARGS NIL) (APPLY (CAAR FORM) (CDR FORM)))
  546. ;            ((OR (AND (EQ (CAR U) 'SUBR)
  547. ;                  (PROG2 (MARGCHK (CAAR FORM) (CDR FORM)) T))
  548. ;             (EQ (CAR U) 'LSUBR))
  549. ;;               ((MEMQ (CAR U) '(SUBR LSUBR))
  550. ;;            (MARGCHK (CAAR FORM) (CDR FORM)))
  551. ;             (APPLY (CAAR FORM) (MEVALARGS (CDR FORM))))
  552. ;
  553. ;            ((EQ (CAR U) 'NOUN)
  554. ;;            (MARGCHK (CAAR FORM) (CDR FORM))
  555. ;             (COND ((OR (MEMQ (CAAR FORM) NOUNL) NOUNSFLAG)
  556. ;                (SETQ FORM (CONS (CONS (CADR U) (CDAR FORM))
  557. ;                         (CDR FORM)))
  558. ;                (GO A))
  559. ;               (ARYP (GO B))
  560. ;               ((MEMQ (CAAR FORM) '(%SUM %PRODUCT))
  561. ;                (SETQ U (DO%SUM (CDR FORM) (CAAR FORM))
  562. ;                  NOEVALARGS NIL)
  563. ;                (CONS (NCONS (CAAR FORM)) U))
  564. ;               (T (MEVAL2 (MEVALARGS (CDR FORM)) FORM))))
  565. ;            ((EQ (CAR U) 'array)
  566. ;             (ARRFIND (CONS (CAR FORM) (MEVALARGS (CDR FORM)))))
  567. ;            ((EQ (CAR U) 'MEXPR)
  568. ;             (MLAMBDA (CADR U) (CDR FORM) (CAAR FORM) NOEVALARGS form))
  569. ;            ((MEMQ (CAR U) '(MMACRO TRANSLATED-MMACRO))
  570. ;             (SETQ NOEVALARGS NIL)
  571. ;             (MEVAL (MMACRO-APPLY (CADR U) FORM)))
  572. ;            ((EQ (CAR U) 'MFEXPR*)
  573. ;             (SETQ NOEVALARGS NIL)  (APPLY (CADR U) (NCONS FORM)))
  574. ;            #+cl
  575. ;            ((eq (car u) 'macro)
  576. ;             (setq noevalargs nil)
  577. ;             (setq form (cons(caar form) (cdr form)))
  578. ;;             (setf (car form) (caar form) )
  579. ;              (eval form)
  580. ;             )
  581. ;            #+Maclisp
  582. ;            ((EQ (CAR U) 'MFEXPR*S)
  583. ;             (SETQ NOEVALARGS NIL)
  584. ;             ;; use macsyma Trace if you want to trace this call.
  585. ;             (SUBRCALL T (CADR U) FORM))
  586. ;            ((EQ (CAR U) 'T-MFEXPR) (APPLY (CADR U) (CDR FORM)))
  587. ;            (T (MARGCHK (CAAR FORM) (CDR FORM))
  588. ;               (APPLY (CADR U) (MEVALARGS (CDR FORM))))))
  589. ;        B   #+(OR PDP10 Multics Franz NIL cl)
  590. ;         (IF (AND (NOT ARYP) (LOAD-FUNCTION (CAAR FORM) T)) (GO A))
  591. ;         (BADFUNCHK (CAAR FORM) (CAAR FORM) NIL)
  592. ;         (IF (SYMBOLP (CAAR FORM))
  593. ;         (SETQ U (BOUNDP (CAAR FORM)))
  594. ;         (RETURN (MEVAL1-EXTEND FORM)))
  595. ;        C   (COND ((OR (NULL U)
  596. ;               (AND (GET (CAAR FORM) 'OPERATORS) (NOT ARYP))
  597. ;               (EQ (CAAR FORM) (SETQ U (SYMBOL-VALUE (CAAR FORM)))))
  598. ;               (SETQ FORM (MEVAL2 (MEVALARGS (CDR FORM)) FORM))
  599. ;               (RETURN (OR (AND (MGET (CAAR FORM) 'ATVALUES)
  600. ;                    (AT1 FORM)) FORM)))
  601. ;              ((AND ARYP (GET (CAAR FORM) 'NONARRAY))
  602. ;               (RETURN (CONS (CONS (CAAR FORM) ARYP)
  603. ;                     (MEVALARGS (CDR FORM)))))
  604. ;              ((ATOM U)
  605. ;               (BADFUNCHK (CAAR FORM) U NIL)
  606. ;               (SETQ FORM (CONS (CONS (GETOPR U) ARYP) (CDR FORM)))
  607. ;               (GO A))
  608. ;              ((EQ (CAAR U) 'LAMBDA)
  609. ;               (IF ARYP
  610. ;               (MERROR "Improper array call")
  611. ;               (RETURN (MLAMBDA U (CDR FORM)
  612. ;                        (CAAR FORM) NOEVALARGS))))
  613. ;              (T (RETURN (MAPPLY1 U (MEVALARGS (CDR FORM))
  614. ;                     (CAAR FORM))))))))
  615. ;    (T (MAPPLY1 (CAAR FORM) (MEVALARGS (CDR FORM)) (CAAR FORM)))))
  616. ;   
  617. ;;; This function substitutes for the use of GETL on the
  618. ;;; EXPR, FEXPR, MACRO, SUBR, FSUBR, LSUBR, or ARRAY property.
  619. ;;; Note: This function used to be incompatible with GETL simply
  620. ;;;       to save two conses per function call in MEVAL, but considering
  621. ;;;       the amount of consing going on elsewere (e.g. the variable binding!)
  622. ;;;       and considering the #+LISPM grossness this introduced, it was
  623. ;;;       a bad idea. N.B. If you want efficiency in macsyma evaluation
  624. ;;;       use the Macsyma->lisp translator. -gjc
  625. ;;; DEFICIENCIES: Functions with some args "E and some args not
  626. ;;; will fail unless MEVAL is changed to call fexprs by (EVAL `(,FOO ,@L))
  627. ;;; instead of (APPLY FOO L). However: Officially everything uses 
  628. ;;; DEFMSPEC now, there are no fexprs.
  629. ;;;; **** This should be rewritten to use the new function FUNCTIONP. ****
  630. ;
  631. ;;;;from the doe tape:
  632. ;;#+LISPM
  633. ;;(DEFUN GETL-LM-FCN-PROP (SYM PROPS)
  634. ;;  (PROG (FN RPROP ARGS-INFO)
  635. ;;    (SETQ RPROP
  636. ;;      (AND (FBOUNDP SYM)
  637. ;;           (SELECT (%DATA-TYPE (SETQ FN (SYMBOL-FUNCTION SYM)))
  638. ;;         (DTP-SYMBOL (RETURN (GETL-LM-FCN-PROP FN PROPS)))
  639. ;;         (DTP-LIST (COND ((MEMQ (CAR FN) '(MACRO SUBST))
  640. ;;                  'MACRO FN)
  641. ;;                 ((EQ (CAR FN) 'NAMED-LAMBDA)
  642. ;;                  (IF (MEMQ '"E (CADDR FN))
  643. ;;                      'FEXPR 'EXPR))
  644. ;;                 ((EQ (CAR FN) 'LAMBDA)
  645. ;;                  (IF (MEMQ '"E (CADR FN)) 'FEXPR 'EXPR))
  646. ;;                 (T (ERROR () "Unknown definition of ~S -- ~S"
  647. ;;                        SYM FN))))
  648. ;;         (DTP-ARRAY-POINTER 'ARRAY)
  649. ;;         ((DTP-FEF-POINTER DTP-U-ENTRY)
  650. ;;          (SETQ ARGS-INFO (%ARGS-INFO FN))
  651. ;;          (COND ((BIT-TEST (f+ %ARG-DESC-QUOTED-REST
  652. ;;                      %ARG-DESC-FEF-QUOTE-HAIR)
  653. ;;                   ARGS-INFO)
  654. ;;             'FSUBR)
  655. ;;            ((NOT (= (LDB %%ARG-DESC-MIN-ARGS ARGS-INFO)
  656. ;;                 (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO)))
  657. ;;             'LSUBR)
  658. ;;            (T 'SUBR)))
  659. ;;         (T (ERROR () "Unknown object in function cell of ~S -- ~S"
  660. ;;                SYM FN)))))
  661. ;;    (RETURN (AND RPROP
  662. ;;         (MEMQ RPROP PROPS)
  663. ;;         (LIST RPROP FN)))))
  664. ;;
  665. ;
  666. ;
  667. ;;altered by wfs to fix the translated saved definitions so they work
  668. ;#+LISPM 
  669. ;(DEFUN GETL-LM-FCN-PROP (SYM PROPS)
  670. ;  (PROG (FN RPROP ARGS-INFO)
  671. ;    (cond  ((symbolp sym)
  672. ;        (cond ((get sym 'translated)
  673. ;               (setq fn (getl sym props)))))
  674. ;           ;;case of compiled function.
  675. ;           ((functionp sym)(setq fn sym))  
  676. ;           (t nil))
  677. ;    (SETQ RPROP
  678. ;          (AND (or fn (FBOUNDP SYM))
  679. ;           (let ((funct  (COND ((NULL FN)
  680. ;                    (SETQ FN (SYMBOL-FUNCTION SYM)))
  681. ;                       (T FN))))
  682. ;             (COND ((ml-typep funct 'symbol)
  683. ;                (RETURN (GETL-LM-FCN-PROP FN PROPS)))
  684. ;               ((ml-typep funct 'list)
  685. ;                (COND ((zl-MEMBER (CAR FN) '(MACRO SUBST special)) 'MACRO)
  686. ;                  ((EQ (CAR FN) 'NAMED-LAMBDA)
  687. ;                   (IF (MEMQ '"E (CADDR FN)) 'FEXPR 'EXPR))
  688. ;                  ((eq (car fn) 'si:digested-lambda)
  689. ;                   'subr)
  690. ;                  ((AND (MEMQ (CAR FN) PROPS)
  691. ;                    (zl-MEMBER (CAADR FN) '(NAMED-LAMBDA ))) 
  692. ;                   (RETURN FN))
  693. ;                  ((EQ (CAR FN) 'LAMBDA)
  694. ;                   (IF (MEMQ '"E (CADR FN)) 'FEXPR 'EXPR))
  695. ;                  (T (ERROR  "Unknown definition of ~S -- ~S" SYM FN))))
  696. ;               ((ml-typep funct 'array)
  697. ;                'array)
  698. ;               ((ml-typep funct 'COMPILED-FUNCTION)
  699. ;                (SETQ ARGS-INFO (%ARGS-INFO FN))
  700. ;                #+ti
  701. ;                (COND ((ldb-test %%arg-desc-quoted-rest args-info) 'fsubr)
  702. ;                  ((ldb-test %%arg-desc-fef-quote-hair args-info) 'fsubr)
  703. ;                  ((NOT (= (LDB %%ARG-DESC-MIN-ARGS ARGS-INFO)
  704. ;                       (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO)))
  705. ;                   'LSUBR)
  706. ;                  (T 'SUBR))
  707. ;                #-ti
  708. ;                (COND ((BIT-TEST (DPB 1 %%ARG-DESC-QUOTED 0) ARGS-INFO) 'FSUBR)
  709. ;                  ((NOT (= (LDB %%ARG-DESC-MIN-ARGS ARGS-INFO)
  710. ;                       (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO)))
  711. ;                   'LSUBR)
  712. ;                  (T 'SUBR)))
  713. ;               ( t            ;(TYPEP funct 'T)
  714. ;                (ERROR  "Unknown object in function cell of ~S -- ~S"
  715. ;                    SYM FN))))))
  716. ;    (RETURN (AND RPROP
  717. ;             (MEMQ RPROP PROPS)
  718. ;             (LIST RPROP FN)))))
  719. ;
  720.  
  721. ;;the following is fine but we don't need it.
  722. ;(defun maxima-symbol-function (sym &aux tem fn)
  723. ; (check-arg sym symbolp "symbol")
  724. ; (cond ((fboundp sym)
  725. ;    (setq fn (symbol-function sym))
  726. ;    (cond ((functionp fn)(values fn 'subr))
  727. ;          ;;really just suitable for apply I think.
  728. ;              ((macro-function sym)(values fn 'macro))
  729. ;          ((arrayp fn)(values fn 'array))
  730. ;          (t (error "unknown fn"))))
  731. ;       ((setq tem (symbol-array sym))
  732. ;    (values tem 'array))
  733. ;       ((setq tem (get sym 'mfexpr*))
  734. ;    (values tem 'mfexpr*))
  735. ;       (t nil)))
  736.  
  737. ;(DEFUN GETL-LM-FCN-PROP (SYM PROPS)
  738. ;  (check-arg sym symbolp "symbol")
  739. ;  (and (fboundp sym) (multiple-value-bind (fn typ) (maxima-symbol-function sym)
  740. ;               (cond ((memq typ props)(list typ fn))
  741. ;                 ((eq typ 'lambda)(list 'subr fn))
  742. ;                 (t nil)))))
  743.  
  744. ;
  745. ;(DEFUN GETL-LM-FCN-PROP (SYM PROPS &aux fn typ)
  746. ;  (check-arg sym symbolp "symbol")
  747. ;  (cond ((fboundp sym)
  748. ;     (setq fn (symbol-function sym))
  749. ;     (cond
  750. ;       #+lucid
  751. ;       ((macro-function sym)
  752. ;        (setq typ 'macro))
  753. ;       ((functionp fn)
  754. ;        ;;this is what we did but do we want if 'subr not in props??
  755. ;         (return-from GETL-LM-FCN-PROP (list 'subr fn)))
  756. ;        ((macro-function sym)
  757. ;         (setq typ 'macro))
  758. ;        #+lispm ((arrayp fn)(values fn 'array))
  759. ;        (t (error "unknown fn"))))
  760. ;    ((setq fn (symbol-array sym))
  761. ;     (setq typ 'array))
  762. ;    ((setq fn (get sym 'mfexpr*))
  763. ;     (setq typ 'mfexpr*)))
  764. ;  (and typ (member typ props :test 'eq) (list typ fn)))    
  765. ;
  766. (DEFUN GETL-LM-FCN-PROP (SYM PROPS &aux fn typ)
  767.   (check-arg sym symbolp "symbol")
  768.   (setq fn sym)
  769.   (cond
  770.     ((functionp fn)
  771.      (setq typ 'subr))
  772.     ((macro-function sym)
  773.      (setq typ 'macro))
  774.     #+lispm ((arrayp fn)(values fn 'array))
  775.     ((setq fn (symbol-array sym))
  776.      (setq typ 'array))
  777.     ((setq fn (get sym 'mfexpr*))
  778.      (setq typ 'mfexpr*)))
  779.   (and typ (member typ props :test 'eq) (list typ fn)))    
  780.  
  781.  
  782. ;;#+LISPM
  783. ;;(DEFUN GETL-LM-FCN-PROP (SYM PROPS)
  784. ;;  (PROG (FN RPROP ARGS-INFO)
  785. ;;    (SETQ RPROP
  786. ;;      (AND (FBOUNDP SYM)
  787. ;;           (TYPECASE (SETQ FN (SYMBOL-FUNCTION SYM))
  788. ;;         (:SYMBOL (RETURN (GETL-LM-FCN-PROP FN PROPS)))
  789. ;;         (:LIST (COND ((MEMQ (CAR FN) '(MACRO SUBST)) 'MACRO)
  790. ;;                  ((EQ (CAR FN) 'NAMED-LAMBDA)
  791. ;;                   (IF (MEMQ '"E (CADDR FN))
  792. ;;                   'FEXPR 'EXPR))
  793. ;;                  ((EQ (CAR FN) 'LAMBDA)
  794. ;;                   (IF (MEMQ '"E (CADR FN)) 'FEXPR 'EXPR))
  795. ;;                  (T (ERROR () "Unknown definition of ~S -- ~S"
  796. ;;                     SYM FN))))
  797. ;;         (:ARRAY (kw array))
  798. ;;         (:COMPILED-FUNCTION
  799. ;;          (SETQ ARGS-INFO (%ARGS-INFO FN))
  800. ;;          (COND ((BIT-TEST #-3600 (f+ %ARG-DESC-QUOTED-REST
  801. ;;                         %ARG-DESC-FEF-QUOTE-HAIR)
  802. ;;                   #+3600 (DPB 1 SI:%%ARG-DESC-QUOTED 0)
  803. ;;                   ARGS-INFO)
  804. ;;             'FSUBR)
  805. ;;            ((NOT (= (LDB %%ARG-DESC-MIN-ARGS ARGS-INFO)
  806. ;;                 (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO)))
  807. ;;             'LSUBR)
  808. ;;            (T 'SUBR)))
  809. ;;         (T (ERROR () "Unknown object in function cell of ~S -- ~S"
  810. ;;                SYM FN)))))
  811. ;;    (RETURN (AND RPROP
  812. ;;         (MEMQ RPROP PROPS)
  813. ;;         (LIST RPROP FN)))))
  814.  
  815.  
  816. ;#+NIL
  817. ;(DEFUN GETL-NIL-FCN-PROP (SYM PROPS)
  818. ;  (IF (FBOUNDP SYM)
  819. ;      (LET* ((F (SYMBOL-FUNCTION SYM))
  820. ;         (PROP (IF (ATOM F)
  821. ;               (IF (EQ (TYPE-OF F) 'SUBR) 'SUBR 'EXPR)
  822. ;               (CAR F))))
  823. ;    (IF (MEMQ PROP PROPS) (LIST PROP F)))))
  824. ;    (RETURN (AND RPROP (MEMQ RPROP PROPS) (LIST RPROP FN)))))
  825.  
  826. #+NIL
  827. (defun getl-nil-fcn-prop (sym props)
  828.   (and (fboundp sym)
  829.        (let* ((f (symbol-function sym))
  830.           (prop (if (atom f)
  831.             (if (ml-typep f (kw COMPILED-FUNCTION)) 'subr 'expr)
  832.             (car f))))
  833.      (when (memq prop '(defmacro subst)) (setq prop 'macro))
  834.      (if (memq prop props) (list prop f)))))
  835.  
  836. (DEFMFUN MEVAL2 (NEWARGS OLD)
  837.   (declare (special aryp))
  838.  (LET ((NEW (CONS (CAR OLD) NEWARGS)) NOSIMP)
  839.       (COND ((NOT (MEMQ 'SIMP (CDAR OLD)))
  840.          (IF (AND (NOT (EQ (CAAR NEW) 'MLIST)) (EQUAL NEW OLD)) OLD NEW))
  841.         ((PROG2 (SETQ NOSIMP (NOT (GET (CAAR NEW) 'OPERATORS))) (ALIKE1 NEW OLD))
  842.          (IF NOSIMP OLD (CONS (DELSIMP (CAR OLD)) (CDR OLD))))
  843.         (NOSIMP (IF ARYP NEW (CONS (CONS (CAAR NEW) '(SIMP)) NEWARGS)))
  844.         (T (CONS (CONS (CAAR NEW) ARYP) NEWARGS)))))
  845.  
  846. (DEFUN MPARAMS (VARS)
  847.   (MAPCAR #'(LAMBDA (X) (COND ((ATOM X) X)
  848.                   ((ATOM (CADR X)) (CADR X))
  849.                   (T (CADADR X))))
  850.       (CDR VARS)))
  851.  
  852. (DEFMFUN MOP (FORM) (IF (EQ (CAAR FORM) 'MQAPPLY) (CADR FORM) (CAAR FORM)))
  853.     
  854. (DEFMFUN MARGS (FORM) (IF (EQ (CAAR FORM) 'MQAPPLY) (CDDR FORM) (CDR FORM)))
  855.  
  856. (DEFUN BADFUNCHK (NAME VAL FLAG)
  857.  (IF (OR FLAG (NUMBERP VAL) (MEMQ VAL '(T NIL $%E $%PI $%I)))
  858. ;    (OR FLAG (AND (NOT $OPERATORS)
  859. ;           (OR (NUMBERP VAL) (MEMQ VAL '(T NIL $%E $%PI $%I)))))
  860.      (IF (AND (ATOM NAME) (NOT (EQUAL VAL NAME)))
  861.      (MERROR "~:M evaluates to ~M~
  862.           ~%Improper name or value in functional position."
  863.          NAME VAL)
  864.      (MERROR "Improper name or value in functional position:~%~M"
  865.          VAL))))
  866.  
  867. #+MacLisp
  868. (DEFUN MARGCHK (FN ARGS) 
  869.  (LET (EXPR)
  870.       (OR (NOT (OR (SETQ EXPR (GET FN 'EXPR)) (GET FN 'SUBR)))
  871.       (NOT (ARGS FN))
  872.       (CAR (ARGS FN))
  873.       (LET ((NNEED (CDR (ARGS FN))) (NGIVEN (LENGTH ARGS)))
  874.            (WHEN (NOT (= NNEED NGIVEN))
  875.              (IF (AND EXPR (NOT (MGET FN 'TRACE))
  876.                   (OR (NULL (CADR EXPR)) (NOT (ATOM (CADR EXPR)))))
  877.              (SETQ FN (CONS (NCONS FN) (CADR EXPR))))
  878.              (MERROR "Too ~M arguments supplied to ~M:~%~M"
  879.                  (IF (< NNEED NGIVEN) '|&many| '|&few|)
  880.                  FN
  881.                  (CONS '(MLIST) ARGS)))))))
  882.  
  883. #+Franz
  884. (defun margchk (fn args)
  885.    (let (expr argdesc)
  886.       (or (not (symbolp fn))
  887.       (not (getd fn))
  888.       (null (setq argdesc (car (get fn 'fcn-info))))
  889.       (let ((minimum (car argdesc))
  890.         (maximum (cdr argdesc))
  891.         (ngiven (length args)))
  892.          (cond ((or (and maximum (> ngiven maximum))
  893.             (and minimum (< ngiven minimum)))
  894.             (merror "Too ~M arguments supplied to ~M:~%~M"
  895.                 (cond ((> ngiven maximum) '|&many|)
  896.                   (t '|&few|))
  897.                 fn
  898.                 (cons '(mlist) args))))))))
  899.  
  900.  
  901.  
  902. ;;      (LET ((NNEED (car argdesc)) (NGIVEN (LENGTH ARGS)))
  903. ;         (cond ((NOT (= NNEED NGIVEN))
  904. ;            (MERROR "Too ~M arguments supplied to ~M:~%~M"
  905. ;                (cond ((< NNEED NGIVEN) '|&many|)
  906. ;                  (t '|&few|))
  907. ;                FN
  908. ;                (CONS '(MLIST) ARGS))))))))
  909. ;#+LISPM
  910. ;(DEFUN MARGCHK (FN ARGS &AUX ARG-DESC MIN-NARGS MAX-NARGS ACTUAL-NARGS)
  911. ;  (AND (SYMBOLP FN)
  912. ;       (FBOUNDP FN)
  913. ;       (PROGN (SETQ ARG-DESC (ARGS-INFO FN)
  914. ;            MIN-NARGS (LDB %%ARG-DESC-MIN-ARGS ARG-DESC)
  915. ;            MAX-NARGS (LDB %%ARG-DESC-MAX-ARGS ARG-DESC)
  916. ;            ACTUAL-NARGS (LENGTH ARGS))
  917. ;          (OR (< ACTUAL-NARGS MIN-NARGS)
  918. ;          (AND (ZEROP (LOGAND #-3600 (f+ %ARG-DESC-QUOTED-REST %ARG-DESC-EVALED-REST)
  919. ;;;                      #+3600 (DPB 1 SI:%%ARG-DESC-REST-ARG 0)
  920. ;                        #+(or lispm 3600)
  921. ;                    (DPB 1 SI:%%ARG-DESC-REST-ARG 0)
  922. ;                      ARG-DESC))     ; has a rest argument means
  923. ;               (> ACTUAL-NARGS MAX-NARGS)))) ; don't check max args.
  924. ;       (MERROR "Too ~M arguments supplied to ~M:~%~M"
  925. ;           (IF (< ACTUAL-NARGS MIN-NARGS) '|&few| '|&many|)
  926. ;           `((,FN) ,@(ARGLIST FN))
  927. ;           `((MLIST) ,@ARGS))))
  928.  
  929.  
  930.  
  931.  
  932.  
  933. (DEFMFUN MBIND (LAMVARS FNARGS FNNAME)
  934.   (DO ((VARS LAMVARS (CDR VARS)) (ARGS FNARGS (CDR ARGS)))
  935.       ((COND ((AND VARS ARGS) NIL)
  936.          ((AND (NULL VARS) (NULL ARGS)))
  937.          (T (MERROR "Too ~M arguments supplied to ~M:~%~M"
  938.                 (IF VARS '|&few| '|&many|)
  939.                 (IF FNNAME (CONS (NCONS FNNAME) LAMVARS)
  940.                    '|&a function|)
  941.                 (CONS '(MLIST) FNARGS)))))
  942.       (LET ((VAR (CAR VARS)))
  943.     (IF (NOT (SYMBOLP VAR))
  944.         (MERROR "Only symbolic atoms can be bound:~%~M" VAR))
  945. #-Franz (WITHOUT-TTY-INTERRUPTS
  946.      (LET ((BL (CONS VAR BINDLIST))
  947.            (ML (CONS (IF (BOUNDP VAR) (SYMBOL-VALUE VAR) MUNBOUND)
  948.               MSPECLIST)))
  949.        (SETQ BINDLIST BL MSPECLIST ML)))
  950. #+Franz (SETQ BINDLIST (CONS VAR BINDLIST))
  951. #+Franz (SETQ MSPECLIST (CONS (IF (BOUNDP VAR) (SYMBOL-VALUE VAR) MUNBOUND)
  952.               MSPECLIST))
  953.     (MSET VAR (CAR ARGS)))))
  954.  
  955. (DEFMFUN MUNBIND (VARS)
  956.  (DOLIST (VAR (REVERSE VARS))
  957.      (COND ((EQ (CAR MSPECLIST) MUNBOUND)
  958.         (MAKUNBOUND VAR) (DELQ VAR $VALUES 1))
  959.            (T (LET ((MUNBINDP T)) (MSET VAR (CAR MSPECLIST)))))
  960.      (SETQ MSPECLIST (CDR MSPECLIST) BINDLIST (CDR BINDLIST))))
  961.  
  962. ;This takes the place of something like
  963. ; (DELETE (ASSOC (NCONS VAR) $DEPENDENCIES) $DEPENDENCIES 1)
  964. ;(defun mfunction-delete (var fn-a-list)
  965. ;  (sys:delete var fn-a-list :count 1
  966. ;          :test #'(lambda (var elt)
  967. ;            (declare (optimize (speed 3) (safety 0)))
  968. ;            (and elt (consp (setq elt (car elt)))
  969. ;                 (eq (car elt) var) (null (cdr elt))))))
  970.  
  971. (defun mfunction-delete (var fn-a-list)
  972.   (zl-DELETE (zl-ASSOC (ncons var) fn-a-list) fn-a-list 1))
  973.  
  974.  
  975.  
  976. (DEFMSPEC MLOCAL (L)
  977.  (SETQ LOCLIST (CONS NIL LOCLIST))
  978.  (LET ((MLOCP T)) (MEVAL `(($LOCAL) ,@(CDR L)))))
  979.  
  980. (DEFMSPEC $LOCAL (L) (SETQ L (CDR L))
  981.  (IF (NOT MLOCP) (MERROR "Improper call to LOCAL"))
  982.  (NOINTERRUPT 'TTY)
  983.  (DOLIST (VAR L)
  984.      (COND ((NOT (symbolp VAR))
  985.         (NOINTERRUPT NIL) (IMPROPER-ARG-ERR VAR '$LOCAL))
  986.            ((AND (MGET VAR 'array)
  987.              #+MacLisp (GET VAR 'array)
  988.              #+cl (arrayp (symbol-array var))
  989.              )
  990.         (NOINTERRUPT NIL)
  991.         (MERROR "Attempt to bind a complete array ~M" VAR)))
  992.      (SETQ MPROPLIST (CONS (GET VAR 'MPROPS) MPROPLIST)
  993.            FACTLIST (CONS (GET VAR 'DATA) FACTLIST))
  994.      (DOLIST (FACT (CAR FACTLIST)) (PUTPROP FACT -1 'ULABS))
  995.       (progn
  996.      (mfunction-delete var $functions)
  997.      (mfunction-delete var $macros)
  998.      (mfunction-delete var $dependencies))
  999.      (DELQ VAR $ARRAYS 1)
  1000.      (ZL-REMPROP VAR 'MPROPS)
  1001.      (ZL-REMPROP VAR 'DATA))
  1002.  (RPLACA LOCLIST (REVERSE L))
  1003.  (SETQ MLOCP NIL)
  1004.  (NOINTERRUPT NIL)
  1005.  '$DONE)
  1006.  
  1007.  
  1008. (DEFUN MUNLOCAL NIL
  1009.  (NOINTERRUPT 'TTY)
  1010.  (DOLIST (VAR (CAR LOCLIST))
  1011.    (let ((MPROP  (CAR MPROPLIST))( Y  NIL)( FACT  (CAR FACTLIST)))
  1012.        (REMCOMPARY VAR)
  1013.        (CPUT VAR MPROP 'MPROPS)
  1014.        (COND ((SETQ Y (old-GET MPROP 'MEXPR))
  1015.           (ADD2LNC (CONS (NCONS VAR) (CDADR Y)) $FUNCTIONS))
  1016.          (T (mfunction-delete var $functions)))
  1017.        (COND ((SETQ Y (old-GET MPROP 'MMACRO))
  1018.           (ADD2LNC (CONS (NCONS VAR) (CDADR Y)) $MACROS))
  1019.          (T (mfunction-delete var $macros)))
  1020.        (COND ((OR (old-GET MPROP 'array) (old-GET MPROP 'HASHAR))
  1021.           (ADD2LNC VAR $ARRAYS))
  1022.          (T (DELQ VAR $ARRAYS 1)))
  1023.        (COND ((SETQ Y (OLD-GET MPROP 'DEPENDS))
  1024.           (ADD2LNC (CONS (NCONS VAR) Y) $DEPENDENCIES))
  1025.          (T (mfunction-delete var $dependencies)))
  1026.        (REMPROPCHK VAR)
  1027.        (MAPC #'REMOV (GET VAR 'DATA))
  1028.        (CPUT VAR FACT 'DATA)
  1029.        (DOLIST (U FACT) (ZL-REMPROP U 'ULABS))
  1030.        (SETQ MPROPLIST (CDR MPROPLIST) FACTLIST (CDR FACTLIST))))
  1031.  (SETQ LOCLIST (CDR LOCLIST))
  1032.  (NOINTERRUPT NIL))
  1033.  
  1034. (declare-top (MACROS T))
  1035. ;;do we really need this??
  1036. ;;since its incompatible with the special definition
  1037.  
  1038.  
  1039. ;(defmacro msetq (&rest l) `(mset ',(first l) ,(second l)))
  1040.  
  1041. (defmacro msetq (a b) `(mset ',a ,b))
  1042.  
  1043.         ;; A "run-time macro" needed by MATCOM/MATRUN.
  1044. (declare-top (MACROS NIL))
  1045. ;;works with the defms
  1046. (DEFMSPEC MSETQ (L)
  1047.   (TWOARGCHECK L)
  1048.   (MSET (SIMPLIFYA (CADR L) NIL) (MEVAL (CADDR L))))
  1049.  
  1050. (DEFUN MSET (X Y)
  1051.    (declare (object y x))
  1052.     (PROG NIL
  1053.           (COND ((OR (NULL $SETCHECK)
  1054.                      (EQ $SETCHECK '$SETCHECK)))
  1055.                 ((AND (OR (ATOM $SETCHECK)
  1056.                           (MEMALIKE X (CDR $SETCHECK))
  1057.                           (AND (NOT (ATOM X))
  1058.                                (MEMALIKE (CAAR X) (CDR $SETCHECK))))
  1059.                       (NOT (EQ X Y)))
  1060.                  (DISPLA (LIST '(MTEXT) (DISP2 X) '| set to | Y))
  1061.                  (IF $SETCHECKBREAK
  1062.                      (LET (($SETVAL Y))
  1063.                           (MERRBREAK T)
  1064.                           (SETQ Y $SETVAL)))))
  1065.           (COND ((ATOM X)
  1066.                  (WHEN (OR (NOT (SYMBOLP X))
  1067.                            (MEMQ X '(T NIL))
  1068.                            (MGET X '$NUMER)
  1069.                            (char= (GETCHARN X 1) #\&))
  1070.                        (IF MUNBINDP (RETURN NIL))
  1071.                        (IF (MGET X '$NUMER)
  1072.                            (MERROR "~:M improper value assignment to a numerical quantity" X)
  1073.                            (MERROR "~:M improper value assignment" X)))
  1074.                  (LET ((F (GET X 'ASSIGN)))
  1075.                       (IF (AND F (OR (NOT (EQ X Y))
  1076.                                      (MEMQ F '(NEVERSET READ-ONLY-ASSIGN))))
  1077.                           (IF (EQ (FUNCALL F X Y) 'MUNBINDP) (RETURN NIL))))
  1078.                  (COND ((AND (NOT (BOUNDP X))
  1079.                              (NOT DSKSETP))
  1080.                         (ADD2LNC X $VALUES))
  1081.                        ((AND (NOT (EQ X Y))
  1082.                              (OPTIONP X))
  1083.                         (IF $OPTIONSET (MTELL "~:M option is being set.~%" X))
  1084.                         (IF (NOT (EQ X '$LINENUM)) (ADD2LNC X $MYOPTIONS))))
  1085.                  (RETURN (SET X Y)))
  1086.                 ((MEMQ 'ARRAY (CDAR X))
  1087.                  (RETURN (ARRSTORE X Y)))
  1088.                 ((AND $SUBSCRMAP (MEMQ (CAAR X) '(MLIST $MATRIX)))
  1089.                  (RETURN (OUTERMAP1 'MSET X Y)))
  1090.                 (T (MERROR "Improper value assignment:~%~M" X)))))
  1091.  
  1092.  
  1093.  
  1094. (DEFMSPEC $EV (L) (SETQ L (CDR L))
  1095.  (LET ((EVP T) (NOUNL NOUNL) ($FLOAT $FLOAT) ($NUMER $NUMER)
  1096.        ($EXPOP $EXPOP) ($EXPON $EXPON) ($DOALLMXOPS $DOALLMXOPS)
  1097.        ($DOSCMXOPS $DOSCMXOPS) (DERIVFLAG DERIVFLAG) ($DETOUT $DETOUT)
  1098.        (NOUNSFLAG NOUNSFLAG) (RULEFCNL RULEFCNL))
  1099.    (IF (AND (CDR L) (NULL (CDDR L)) (EQ (CAR L) '$%E) (EQ (CADR L) '$NUMER))
  1100.        (SETQ L (APPEND L '($%ENUMER))))
  1101.    (DO ((L (CDR L) (CDR L)) (BNDVARS) (BNDVALS) (LOCVARS) (EXP (CAR L))
  1102.     (SUBSL) (EVFLG 0) (RATF) (DERIVLIST) (EVFUNL) (FUNCL) (PREDFLG)
  1103.     (NOEVAL (MEMQ '$NOEVAL (CDR L))))
  1104.        ((NULL L)
  1105.     (MBINDING (BNDVARS BNDVARS)
  1106.           (MEVAL `((MLOCAL) ,@LOCVARS))
  1107.           (LET ($TRANSLATE) (MAPC #'MEVAL1 FUNCL))
  1108.           (LET ($NUMER) (SETQ EXP (MEVALATOMS EXP)))
  1109.           (IF ($RATP EXP) (SETQ RATF T EXP ($RATDISREP EXP)))
  1110.           (IF (SPECREPP EXP) (SETQ EXP (SPECDISREP EXP)))
  1111.           (WHEN SUBSL
  1112.             (SETQ EXP (SIMPLIFY EXP))
  1113.             (DOLIST (ITEM SUBSL)
  1114.                 (SETQ EXP (MAXIMA-SUBSTITUTE (MEVAL (CAR ITEM))
  1115.                               (MEVAL (CDR ITEM))
  1116.                               EXP)))))
  1117.     (MBINDING (BNDVARS BNDVALS)
  1118.           (IF (AND $NUMER NOEVAL $%ENUMER)
  1119.               (SETQ EXP (MAXIMA-SUBSTITUTE %E-VAL '$%E EXP)))
  1120.           (SETQ EXP (IF NOEVAL
  1121.                 (RESIMPLIFY EXP)
  1122.                 (SIMPLIFY (IF PREDFLG (MEVALP EXP) (MEVAL1 EXP)))))
  1123.           (IF (OR (> EVFLG 0) $INFEVAL)
  1124.               (PROG (EXP1)
  1125.                 (SETQ EXP (SPECREPCHECK EXP))
  1126.                LOOP (DO ((L EVFUNL (CDR L)) (EXP2 EXP))
  1127.                 ((NULL L) (SETQ EXP1 (MEVAL EXP2)))
  1128.                 (SETQ EXP2 (LIST (NCONS (CAR L)) EXP2)))
  1129.                 (DOLIST (ITEM SUBSL)
  1130.                     (SETQ EXP1 (MAXIMA-SUBSTITUTE (MEVAL (CAR ITEM))
  1131.                                (MEVAL (CDR ITEM))
  1132.                                EXP1)))
  1133.                 (COND ((OR (AND (NOT $INFEVAL)
  1134.                         (= (SETQ EVFLG (f1- EVFLG)) 0))
  1135.                        (PROG2 (SETQ EXP1 (SPECREPCHECK EXP1))
  1136.                           (ALIKE1 EXP EXP1)))
  1137.                    (SETQ EXP EXP1))
  1138.                   (T (SETQ EXP EXP1) (GO LOOP)))))
  1139.           (IF (AND RATF (NOT $NUMER) (NOT $FLOAT))
  1140.               (SETQ EXP (LET ($NOREPEAT) (RATF EXP)))))
  1141.     (MUNLOCAL)
  1142.     EXP)
  1143.        (IF (NOT (OR (ATOM (CAR L))
  1144.             (MEMQ 'array (CDAAR L))
  1145.             (MEMQ (CAAAR L) '(MQUOTE MSETQ MLIST MEQUAL MDEFINE MSET
  1146.                       MDEFMACRO $EXPAND $LOCAL $DERIVLIST))))
  1147.        (SETQ L (CONS (MEVAL (CAR L)) (CDR L))))
  1148.        (COND ((OR (ATOM (CAR L)) (MEMQ 'array (CDAAR L)) (EQ (CAAAR L) 'MQUOTE))
  1149.           (OR (AND (SYMBOLP (CAR L))
  1150.                (COND ((EQ (CAR L) '$EVAL) (SETQ EVFLG (f1+ EVFLG)))
  1151.                  ((MEMQ (CAR L) '($NOEVAL $RESCAN)))
  1152.                  ((EQ (CAR L) '$DETOUT)
  1153.                   (SETQ $DOALLMXOPS NIL $DOSCMXOPS NIL $DETOUT T))
  1154.                  ((EQ (CAR L) '$NUMER) (SETQ $NUMER T $FLOAT T))
  1155.                  ((EQ (CAR L) '$NOUNS) (SETQ NOUNSFLAG T))
  1156.                  ((EQ (CAR L) '$PRED) (SETQ PREDFLG T))
  1157.                  ((EQ (CAR L) '$EXPAND)
  1158.                   (SETQ $EXPOP $MAXPOSEX $EXPON $MAXNEGEX))
  1159.                  ((EQ (CAR L) '%DERIVATIVE)
  1160.                   (SETQ DERIVFLAG T DERIVLIST NIL))
  1161.                  ((GET (CAR L) 'EVFLAG)
  1162.                   (SETQ BNDVARS (CONS (CAR L) BNDVARS)
  1163.                     BNDVALS (CONS (GET (CAR L) 'EVFLAG) BNDVALS)))
  1164.                  ((GET (CAR L) 'EVFUN)
  1165.                   (SETQ EXP (EVFUNMAKE (CAR L) EXP)
  1166.                     EVFUNL (NCONC EVFUNL (NCONS (CAR L)))))))
  1167.           (LET ((FL (MEVAL (CAR L))))
  1168.                (COND ((SYMBOLP FL)
  1169.                   (COND ((EQ FL '$DIFF)
  1170.                      (SETQ L (LIST* NIL '$DEL (CDR L))))
  1171.                     ((EQ FL '$RISCH)
  1172.                      (SETQ L (LIST* NIL '$INTEGRATE (CDR L)))))
  1173.                   (SETQ NOUNL (CONS ($NOUNIFY FL) NOUNL)))
  1174.                  ((NUMBERP FL) (IMPROPER-ARG-ERR (CAR L) '$EV))
  1175.                  ((EQ (CAAR FL) 'MLIST)
  1176.                   (SETQ L (APPEND FL (CDR L))))
  1177.                  ((MEMQ (CAAR FL)
  1178.                     '(MSETQ MEQUAL MDEFINE MDEFMACRO MSET))
  1179.                   (SETQ L (LIST* NIL FL (CDR L))))
  1180.                  (T (IMPROPER-ARG-ERR (CAR L) '$EV))))))
  1181.          ((NOT (MEMQ (CAAAR L) '(MSETQ MLIST MEQUAL MDEFINE MDEFMACRO
  1182.                      $EXPAND $LOCAL $DERIVLIST MSET)))
  1183.           (IMPROPER-ARG-ERR (CAR L) '$EV))
  1184.          ((EQ (CAAAR L) '$EXPAND)
  1185.           (COND ((NULL (CDAR L)) (SETQ $EXPOP $MAXPOSEX $EXPON $MAXNEGEX))
  1186.             ((NULL (CDDAR L)) (SETQ $EXPOP (CADAR L) $EXPON $MAXNEGEX))
  1187.             (T (SETQ $EXPOP (CADAR L) $EXPON (CADDAR L)))))
  1188.          ((MEMQ (CAAAR L) '(MDEFINE MDEFMACRO))
  1189.           (LET ((FUN (CADAR L)) $use_fast_arrays)
  1190.         (IF (EQ (CAAR FUN) 'MQAPPLY) (SETQ FUN (CADR FUN)))
  1191.         (SETQ FUN ($VERBIFY (CAAR FUN)))
  1192.         (SETQ FUNCL (NCONC FUNCL (NCONS (CAR L)))
  1193.               LOCVARS (APPEND LOCVARS (NCONS FUN)))
  1194.         (IF (RULECHK FUN) (SETQ RULEFCNL (CONS FUN RULEFCNL)))))
  1195.          ((EQ (CAAAR L) '$LOCAL) (SETQ LOCVARS (APPEND LOCVARS (CDAR L))))
  1196.          ((EQ (CAAAR L) '$DERIVLIST) (SETQ DERIVFLAG T DERIVLIST (CDAR L)))
  1197.          ((AND (EQ (CAAAR L) 'MSET)
  1198.            (SETQ L (CONS (LIST '(MSETQ) (MEVAL (CADAR L)) (CADDAR L))
  1199.                  (CDR L)))
  1200.            NIL))
  1201.          ((MEMQ (CAAAR L) '(MSETQ MEQUAL))
  1202.           (IF (AND (MSETQP (CAR L)) (MSETQP (CADDAR L)))
  1203.           (SETQ L (NCONC (|:SPREAD| (CAR L)) (CDR L))))
  1204.           (IF (OR NOEVAL (NOT (ATOM (CADAR L))))
  1205.           (SETQ SUBSL (NCONC SUBSL (LIST (CONS (CADDAR L) (CADAR L))))))
  1206.           (IF (ATOM (CADAR L))
  1207.           (SETQ BNDVARS (CONS (CADAR L) BNDVARS)
  1208.             BNDVALS (CONS (MEVAL (SPECREPCHECK (CADDAR L))) BNDVALS))))
  1209.          (T (SETQ L (APPEND (CAR L) (CDR L))))))))
  1210.  
  1211. (DEFMFUN MEVALATOMS (EXP)
  1212.  (COND ((ATOM EXP) (MEVAL1 EXP))
  1213.        ((MEMQ 'array (CDAR EXP))
  1214.     (LET (EXP1)
  1215.       (LET ((EVARRP T)) (SETQ EXP1 (CATCH 'EVARRP (MEVAL1 EXP))))
  1216.       (IF (EQ EXP1 'NOTEXIST)
  1217.           (CONS (CAR EXP) (MAPCAR #'MEVALATOMS (CDR EXP)))
  1218.           EXP1)))
  1219.        ((EQ (CAAR EXP) 'MQUOTE) (CADR EXP))
  1220.        ((MEMQ (CAAR EXP) '(MSETQ $DEFINE))
  1221.     (LIST (CAR EXP) (CADR EXP) (MEVALATOMS (CADDR EXP))))
  1222.        ((OR (AND (EQ (CAAR EXP) '$EV)
  1223.          (CDR EXP)
  1224.          (OR (NULL (CDDR EXP)) (EQUAL (CDDR EXP) '($EVAL))))
  1225.         (EQ (CAAR EXP) 'MPROGN))
  1226.     (CONS (CAR EXP) (CONS (MEVALATOMS (CADR EXP)) (CDDR EXP))))
  1227.        ((MEMQ (CAAR EXP) '($SUM $PRODUCT %SUM %PRODUCT))
  1228.     (IF MSUMP
  1229.        (MEVAL EXP)
  1230.        (LIST (CAR EXP) (CADR EXP) (CADDR EXP)
  1231.          (MEVALATOMS (CADDDR EXP)) (MEVALATOMS (CAR (CDDDDR EXP))))))
  1232.        ((AND (EQ (CAAR EXP) '$%TH) (EQ (ml-typep (SIMPLIFY (CADR EXP))) 'fixnum))
  1233.     (MEVAL1 EXP))
  1234.        ((PROG2 (AUTOLDCHK (CAAR EXP))
  1235.            (AND (OR (GETL-FUN (CAAR EXP) '(FSUBR FEXPR))
  1236.             (GETL (CAAR EXP) '(MFEXPR* MFEXPR*S)))
  1237.             (NOT (GET (CAAR EXP) 'EVOK))))
  1238.     EXP)
  1239.        ((MGETL (CAAR EXP) '(MFEXPRP T-MFEXPR))
  1240.     (CONS (CAR EXP)
  1241.           (DO ((A (OR (CDR (MGET (CAAR EXP) 'T-MFEXPR))
  1242.               (CDADR (MGET (CAAR EXP) 'MEXPR)))
  1243.               (CDR A))
  1244.            (B (CDR EXP) (CDR B)) (L))
  1245.           ((NOT (AND A B)) (NREVERSE L))
  1246.           (COND ((MDEFLISTP A)
  1247.              (RETURN (NRECONC L (IF (MQUOTEP (CADAR A))
  1248.                         B
  1249.                         (MAPCAR #'MEVALATOMS B)))))
  1250.             ((MQUOTEP (CAR A)) (SETQ L (CONS (CAR B) L)))
  1251.             (T (SETQ L (CONS (MEVALATOMS (CAR B)) L)))))))
  1252.        ((OR (EQ (CAAR EXP) 'MMACROEXPANDED)
  1253.         (AND $TRANSRUN (GET (CAAR EXP) 'TRANSLATED-MMACRO))
  1254.         (MGET (CAAR EXP) 'MMACRO))
  1255.     (MEVALATOMS (MMACROEXPAND EXP)))
  1256.        (T (CONS (CAR EXP) (MAPCAR #'MEVALATOMS (CDR EXP))))))
  1257.  
  1258. (PROG1 '(EVOK properties)
  1259.        (MAPC #'(LAMBDA (X) (PUTPROP X T 'EVOK))
  1260.          '($MAP $MAPLIST $FULLMAP $MATRIXMAP $FULLMAPL $OUTERMAP $SCANMAP
  1261.            $APPLY)))
  1262.  
  1263. (DEFUN EVFUNMAKE (FUN EXP)
  1264.  (IF (MSETQP EXP)
  1265.      (LIST (CAR EXP) (CADR EXP) (EVFUNMAKE FUN (CADDR EXP)))
  1266.      (LIST (NCONS FUN) EXP)))
  1267.  
  1268. (DEFUN |:SPREAD| (X)
  1269.  (DO ((VAL (DO ((X X (CADDR X))) (NIL)
  1270.            (IF (NOT (MSETQP (CADDR X))) (RETURN (CADDR X)))))
  1271.       (X X (CADDR X)) (L))
  1272.      ((NOT (MSETQP X)) L)
  1273.      (SETQ L (CONS (LIST (CAR X) (CADR X) VAL) L))))
  1274.  
  1275. (DEFMFUN MSETQP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MSETQ)))
  1276.  
  1277. (DEFMFUN MQUOTEP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MQUOTE)))
  1278.  
  1279. (DEFMSPEC MQUOTE (FORM) (CADR FORM))
  1280.  
  1281. (DEFMFUN $SUBVARP (X) (AND (NOT (ATOM X)) (MEMQ 'array (CDAR X)) T))
  1282.  
  1283. (DEFMFUN MSETERR (X Y)
  1284.  (IF MUNBINDP
  1285.      'MUNBINDP
  1286.      (MERROR "Attempt to set ~:M to ~M~%Improper value assignment" X Y)))
  1287.  
  1288. (PROG1 '(ASSIGN properties)
  1289.        (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ASSIGN))
  1290.          '(($LINEL MSETCHK) (*read-base* MSETCHK) (*print-base* MSETCHK) (MODULUS MSETCHK)
  1291.            ($INFOLISTS NEVERSET) ($TRACE NEVERSET) ($RATWEIGHTS MSETCHK)
  1292.            ($RATVARS MSETCHK) ($SETCHECK MSETCHK) ($GCD MSETCHK)
  1293.            ($DOTASSOC MSETCHK) ($RATWTLVL MSETCHK) ($RATFAC MSETCHK)
  1294.            ($ALL NEVERSET) ($NUMER NUMERSET) ($FORTINDENT MSETCHK)
  1295.            ($GENSUMNUM MSETCHK) ($GENINDEX MSETCHK) ($FPPRINTPREC MSETCHK)
  1296.             ($FLOATWIDTH MSETCHK) ($PARSEWINDOW MSETCHK) ($OPTIMPREFIX MSETCHK)
  1297.            ($TTYINTNUM MSETCHK))))
  1298.  
  1299. (DEFMFUN MSETCHK (X Y)
  1300.  (COND ((MEMQ X '(*read-base* *print-base*))
  1301.     (COND #-NIL ((EQ Y 'ROMAN))
  1302.           ((OR (NOT (FIXNUMP Y)) (< Y 2) (> Y 35)) (MSETERR X Y))
  1303.           ((EQ X '*read-base*)
  1304.            #+MacLisp (IF (< Y 11) (SSTATUS + NIL) (SSTATUS + T)))))
  1305.        ((MEMQ X '($LINEL $FORTINDENT $GENSUMNUM $FPPRINTPREC $FLOATWIDTH
  1306.           $PARSEWINDOW $TTYINTNUM))
  1307.     (IF (NOT (fixnump y)) (MSETERR X Y))
  1308.     #+MacLisp
  1309.     (WHEN (EQ X '$LINEL)
  1310.       (LINEL T (LINEL NIL Y))
  1311.       (DOLIST (FILE OUTFILES) (LINEL FILE Y))
  1312.       (SETQ LINEL Y))
  1313.     #+(or cl Franz) (if (eq x '$linel) (setq linel y))
  1314.     (COND ((AND (MEMQ X '($FORTINDENT $GENSUMNUM $FLOATWIDTH $TTYINTNUM)) (< Y 0))
  1315.            (MSETERR X Y))
  1316.           ((AND (EQ X '$PARSEWINDOW) (< Y -1)) (MSETERR X Y))
  1317.           ((AND (EQ X '$FPPRINTPREC) (OR (< Y 0) (= Y 1))) (MSETERR X Y))))
  1318.        ((MEMQ X '($GENINDEX $OPTIMPREFIX)) (IF (NOT (SYMBOLP Y)) (MSETERR X Y)))
  1319.        ((EQ X '$DOTASSOC) (CPUT 'MNCTIMES Y 'ASSOCIATIVE))
  1320.        ((EQ X 'MODULUS)
  1321.     (COND ((NULL Y))
  1322.           ((INTEGERP Y)
  1323.            (IF (OR (NOT (PRIMEP Y)) (zl-MEMBER Y '(1 0 -1)))
  1324.            (MTELL "Warning: MODULUS being set to ~:M, a non-prime.~%" Y)))
  1325.           (T (MSETERR X Y))))
  1326.        ((EQ X '$SETCHECK)
  1327.     (IF (NOT (OR (MEMQ Y '($ALL T NIL)) ($LISTP Y))) (MSETERR X Y)))
  1328.        ((EQ X '$GCD) (IF (NOT (OR (NULL Y) (MEMQ Y *GCDL*))) (MSETERR X Y)))
  1329.        ((EQ X '$RATVARS)
  1330.     (IF ($LISTP Y) (APPLY #'$RATVARS (CDR Y)) (MSETERR X Y)))
  1331.        ((EQ X '$RATFAC)
  1332.     (IF (AND Y $RATWTLVL)
  1333.         (MERROR "RATFAC and RATWTLVL may not both be used at the same time.")))
  1334.        ((EQ X '$RATWEIGHTS)
  1335.     (COND ((NOT ($LISTP Y)) (MSETERR X Y))
  1336.           ((NULL (CDR Y)) (KILL1 '$RATWEIGHTS))
  1337.           (T (APPLY #'$RATWEIGHT (CDR Y)))))
  1338.        ((EQ X '$RATWTLVL)
  1339.     (IF (AND Y (NOT (FIXNUMP Y))) (MSETERR X Y))
  1340.     (IF (AND Y $RATFAC)
  1341.         (MERROR "RATFAC and RATWTLVL may not both be used at the same time.")))))
  1342.  
  1343. (DEFMFUN NUMERSET (ASSIGN-VAR Y)
  1344.  ASSIGN-VAR  ; ignored
  1345.  (MSET '$FLOAT Y))
  1346.  
  1347. (DEFMFUN NEVERSET (X ASSIGN-VAL)
  1348.  ASSIGN-VAL  ; ignored
  1349.  (IF MUNBINDP 'MUNBINDP (MERROR "Improper value assignment to ~:M" X)))
  1350.  
  1351. (DEFMFUN MMAPEV (L)
  1352.  (IF (NULL (CDDR L))
  1353.      (MERROR "~:M called with fewer than two arguments." (CAAR L)))
  1354.  (LET ((OP (GETOPR (MEVAL (CADR L)))))
  1355.       (AUTOLDCHK OP)
  1356.       (BADFUNCHK (CADR L) OP NIL)
  1357.       (CONS OP (MAPCAR #'MEVAL (CDDR L)))))
  1358.  
  1359. (DEFMSPEC $MAP (L) (APPLY #'MAP1 (MMAPEV L)))
  1360.  
  1361. (DEFMFUN MAP1 N
  1362.  (DO ((I N (f1- I))
  1363.       (ARGI (SETARG N (FORMAT1 (ARG N))) (FORMAT1 (ARG (f1- I))))
  1364.       (OP (OR (MAPATOM (ARG N)) (MOP (ARG N))))
  1365.       (FLAG (MAPATOM (ARG N))
  1366.         (OR FLAG (SETQ FLAG (MAPATOM ARGI))
  1367.         (AND (NOT MAPLP) (NOT (ALIKE1 (MOP ARGI) OP)))))
  1368.       (ARGL NIL (CONS ARGI ARGL))
  1369.       (CDRL NIL (OR FLAG (CONS (MARGS ARGI) CDRL))))
  1370.      ((= I 1) (IF FLAG 
  1371.           (COND ((NOT $MAPERROR) 
  1372.              (IF $MAPPRINT (MTELL "MAP is doing an APPLY.~%"))
  1373.              (FUNCER (ARG 1) ARGL))
  1374.             ((AND (= N 2) (MAPATOM (ARG 2)))
  1375.              (IMPROPER-ARG-ERR (ARG 2) '$MAP))
  1376.             (T (MERROR "Arguments to MAPL not uniform - cannot map.")))
  1377.           (MCONS-OP-ARGS
  1378.             OP #+NIL (APPLY #'MMAPCAR (ARG 1) CDRL)
  1379.                #-NIL (APPLY #'MMAPCAR (CONS (ARG 1) CDRL)))))))
  1380.  
  1381. (DEFMSPEC $MAPLIST (L)
  1382.  (LET ((MAPLP T) RES)
  1383.       (SETQ RES (apply #'MAP1 (MMAPEV L)))
  1384.       (COND ((ATOM RES) (LIST '(MLIST) RES))
  1385.         ((EQ (CAAR RES) 'MLIST) RES)
  1386.         (T (CONS '(MLIST) (MARGS RES))))))
  1387.  
  1388. (DEFMFUN MMAPCAR N 
  1389.  (DO ((ANS NIL (CONS (FUNCER (ARG 1) ARGL) ANS))
  1390.       (ARGL NIL NIL))
  1391.      ((DO ((I N (f1- I))) ((= I 1) NIL)
  1392.       (WHEN (NULL (ARG I))
  1393.         (WHEN (OR (< I N) (DO ((J 2 (f1+ J))) ((= J N) NIL)
  1394.                       (IF (ARG J) (RETURN T))))
  1395.               (IF $MAPERROR
  1396.               (MERROR "Arguments to MAPL are not of the same length."))
  1397.               (IF $MAPPRINT (MTELL "MAP is truncating.~%")))
  1398.         (RETURN T))
  1399.       (SETQ ARGL (CONS (CAR (ARG I)) ARGL))
  1400.       (SETARG I (CDR (ARG I))))
  1401.       (NREVERSE ANS))))
  1402.  
  1403. (DEFUN MAPATOM (X) (OR (SYMBOLP X) (MNUMP X) ($SUBVARP X)))
  1404.  
  1405. (DEFMFUN $MAPATOM (X) (IF (MAPATOM (SPECREPCHECK X)) T))
  1406.  
  1407. (DEFMSPEC $FULLMAP (L) (SETQ L (MMAPEV L)) (FMAP1 (CAR L) (CDR L) NIL))
  1408.  
  1409. (DEFUN FMAP1 (FN ARGL FMAPCAARL)
  1410.  (SETQ ARGL (MAPCAR #'FORMAT1 ARGL))
  1411.  (DO ((OP (OR (MAPATOM (CAR ARGL)) (MOP (CAR ARGL))))
  1412.       (FMAPLVL (f1- FMAPLVL)) (CDR1 ARGL (CDR CDR1)) (ARGI NIL NIL)
  1413.       (CDRL NIL (CONS (MARGS (CAR CDR1)) CDRL)))
  1414.      ((NULL CDR1)
  1415.       (DO ((ANS NIL (CONS (IF BOTTOM (FUNCER FN CARARGL)
  1416.                      (FMAP1 FN CARARGL FMAPCAARL))
  1417.               ANS))
  1418.        (CARARGL NIL NIL) (CDRARGL NIL NIL)
  1419.        (CDRL CDRL CDRARGL) (BOTTOM NIL NIL)
  1420.        (DONE (WHEN (MEMQ NIL CDRL)
  1421.                (WHEN (DOLIST (E CDRL) (IF E (RETURN T)))
  1422.                  (IF $MAPERROR
  1423.                  (MERROR
  1424.                   "FULLMAP found arguments with incompatible structure."))
  1425.                  (IF $MAPPRINT (MTELL "FULLMAP is truncating.~%")))
  1426.                T)))
  1427.       (DONE (MCONS-OP-ARGS OP (NREVERSE ANS)))
  1428.       (DO ((OP (OR (SETQ BOTTOM (OR (ZEROP FMAPLVL) (MAPATOM (CAAR CDRL))))
  1429.                (MOP (CAAR CDRL))))
  1430.            (ELEML CDRL (CDR ELEML)) (CAARELEML NIL NIL))
  1431.           ((NULL ELEML)
  1432.            (WHEN (AND DONE (DOLIST (E CDRARGL) (IF E (RETURN T))))
  1433.              (IF $MAPERROR
  1434.              (MERROR "FULLMAP found arguments with incompatible structure."))
  1435.              (IF $MAPPRINT (MTELL "FULLMAP is truncating.~%"))))
  1436.           (SETQ CAARELEML (CAAR ELEML))
  1437.           (OR BOTTOM
  1438.           (SETQ BOTTOM
  1439.             (OR (MAPATOM CAARELEML)
  1440.                 (NOT (ALIKE1 OP (MOP CAARELEML)))
  1441.                 (AND FMAPCAARL (NOT (EQ (CAAR CAARELEML) FMAPCAARL))))))
  1442.           (OR DONE (SETQ DONE (NULL (CDAR ELEML))))
  1443.           (SETQ CARARGL (NCONC (NCONS CAARELEML) CARARGL)
  1444.             CDRARGL (NCONC CDRARGL (NCONS (CDAR ELEML)))))))
  1445.      (SETQ ARGI (CAR CDR1))
  1446.      (IF (OR (MAPATOM ARGI)
  1447.          (NOT (ALIKE1 OP (MOP ARGI)))
  1448.          (AND FMAPCAARL (NOT (EQ (CAAR ARGI) FMAPCAARL))))
  1449.      (COND ($MAPERROR (MERROR "Incorrect call to FULLMAP."))
  1450.            (T (IF $MAPPRINT (MTELL "FULLMAP is doing an APPLY.~%"))
  1451.           (RETURN (FUNCER FN ARGL)))))))
  1452.  
  1453. (DEFMSPEC $MATRIXMAP (L) (LET ((FMAPLVL 2)) (APPLY #'FMAPL1 (MMAPEV L))))
  1454.  
  1455. (DEFMSPEC $FULLMAPL (L) (APPLY #'FMAPL1 (MMAPEV L)))
  1456.  
  1457. (DEFMFUN FMAPL1 N
  1458.  (LET ((HEADER '(MLIST)) ARGL)
  1459.       (SETQ ARGL (FMAP1 (ARG 1)
  1460.             (MAPCAR
  1461.              #'(LAMBDA (Z)
  1462.                 (COND ((NOT (MXORLISTP Z))
  1463.                    (MERROR "Argument to FULLMAPL is not a list or matrix."))
  1464.                   ((EQ (CAAR Z) '$MATRIX)
  1465.                    (SETQ HEADER '($MATRIX))
  1466.                    (CONS '(MLIST SIMP) (CDR Z)))
  1467.                   (T Z)))
  1468.              (CDR (LISTIFY N)))
  1469.             'MLIST))
  1470.       (IF (DOLIST (E (CDR ARGL)) (IF (NOT ($LISTP E)) (RETURN T)))
  1471.       ARGL
  1472.       (CONS HEADER (CDR ARGL)))))
  1473.  
  1474. (DEFMSPEC $OUTERMAP (L)
  1475.  (APPLY (IF (= (LENGTH L) 3) #'FMAPL1 #'OUTERMAP1) (MMAPEV L)))
  1476.  
  1477. (DEFMFUN OUTERMAP1 N 
  1478.  (LET (OUTARGS1 OUTARGS2)
  1479.       (COND ((MXORLISTP (ARG 2))
  1480.          (SETQ OUTARGS1 (NCONS (ARG 1)) OUTARGS2 (LISTIFY (f- 2 N)))
  1481.          (FMAPL1 'OUTERMAP2 (ARG 2)))
  1482.         (T (DO ((I 3 (f1+ I)))
  1483.            ((> I N) (FUNCER (ARG 1) (LISTIFY (f- 1 N))))
  1484.            (WHEN (MXORLISTP (ARG I))
  1485.              (SETQ OUTARGS1 (LISTIFY (f1- I))
  1486.                    OUTARGS2 (IF (< I N) (LISTIFY (f- I N))))
  1487.              (RETURN (FMAPL1 'OUTERMAP2 (ARG I)))))))))
  1488.  
  1489. (DEFMFUN OUTERMAP2 N
  1490.   (IF (NOT (ZEROP N))
  1491.       (APPLY #'OUTERMAP1 (APPEND OUTARGS1 (LISTIFY 1) OUTARGS2))))
  1492.  
  1493. (DEFMFUN FUNCER (FN ARGS)
  1494.   (COND ((AND (NOT OPEXPRP) (MEMQ FN '(MPLUS MTIMES MEXPT MNCTIMES)))
  1495.      (SIMPLIFY (CONS (NCONS FN) ARGS)))
  1496.     ((OR (MEMQ FN '(OUTERMAP2 CONSTFUN))
  1497.          (AND $TRANSRUN (SYMBOLP FN) (GET FN 'TRANSLATED)
  1498.           (NOT (MGET FN 'LOCAL-FUN)) (FBOUNDP FN)))
  1499.      (APPLY FN (MAPCAR #'SIMPLIFY ARGS)))
  1500.     (T (MAPPLY1 FN (MAPCAR #'SIMPLIFY ARGS) FN
  1501.            nil ;; try to get more info to pass
  1502.            ))))
  1503.  
  1504. (DEFMSPEC $QPUT (L) (SETQ L (CDR L))
  1505.  (IF (NOT (= (LENGTH L) 3)) (WNA-ERR '$QPUT))
  1506.  ($PUT (CAR L) (CADR L) (CADDR L)))
  1507.  
  1508. (DEFMFUN $GET (ATOM IND) (PROP1 '$GET ATOM NIL IND))
  1509.  
  1510. (DEFMFUN $REM (ATOM IND) (PROP1 '$REM ATOM NIL IND))
  1511.  
  1512. (DEFMFUN $PUT (ATOM VAL IND)
  1513.  (PROG1 (PROP1 '$PUT ATOM VAL IND) (ADD2LNC ATOM $PROPS)))
  1514.  
  1515. (DEFUN PROP1 (FUN ATOM VAL IND)
  1516.  (NONSYMCHK ATOM FUN) (NONSYMCHK IND FUN)
  1517.  (LET ((U (MGET ATOM '$PROPS)))
  1518.       (COND ((EQ FUN '$GET) (AND U (old-GET U IND)))
  1519.         ((EQ FUN '$REM) (AND U (ZL-REMPROP U IND) '$DONE))
  1520.         ((NOT U) (MPUTPROP ATOM (LIST NIL IND VAL) '$PROPS) VAL)
  1521.         (T (PUTPROP U VAL IND)))))
  1522.  
  1523. (DEFMSPEC $DECLARE (L) (SETQ L (CDR L))
  1524.  (IF (ODDP (LENGTH L)) (MERROR "DECLARE takes an even number of arguments."))
  1525.  (DO ((L L (CDDR L)) (VARS) (FLAG NIL NIL)) ((NULL L) '$DONE)
  1526.      (COND (($LISTP (CADR L))
  1527.         (DO ((L1 (CDADR L) (CDR L1))) ((IF (NULL L1) (SETQ FLAG T)))
  1528.         (MEVAL `(($DECLARE) ,(CAR L) ,(CAR L1)))))
  1529.        ((NONSYMCHK (CADR L) '$DECLARE))
  1530.        (T (SETQ VARS (DECLSETUP (CAR L) '$DECLARE))))
  1531.      (COND (FLAG)
  1532.        ((MEMQ (CADR L) '($EVFUN $EVFLAG $SPECIAL $NONARRAY $BINDTEST))
  1533.         (DECLARE1 VARS T (STRIPDOLLAR (CADR L)) NIL))
  1534.        ((EQ (CADR L) '$NOUN)
  1535.         (DOLIST (VAR VARS) (ALIAS (GETOPR VAR) ($NOUNIFY VAR))))
  1536.        ((MEMQ (CADR L) '($CONSTANT $NONSCALAR $SCALAR $MAINVAR))
  1537.         (DECLARE1 VARS T (CADR L) T))
  1538.        ((MEMQ (CADR L) OPERS)
  1539.         (IF (MEMQ (CADR L) (CDR $FEATURES)) (DECLARE1 VARS T (CADR L) 'KIND))
  1540.         (DECLARE1 (MAPCAR #'GETOPR VARS) T (CADR L) 'OPERS))
  1541.        ((MEMQ (CADR L) (CDR $FEATURES)) (DECLARE1 VARS T (CADR L) 'KIND))
  1542.        ((EQ (CADR L) '$FEATURE)
  1543.         (DOLIST (VAR VARS) (NONSYMCHK VAR '$DECLARE) (ADD2LNC VAR $FEATURES)))
  1544.        ((EQ (CADR L) '$ALPHABETIC) (DECLARE1 VARS T T '$ALPHABETIC))
  1545.        (T (MERROR "Unknown property to DECLARE: ~:M" (CADR L))))))
  1546.  
  1547. (DEFUN DECLARE1 (VARS VAL PROP MPROPP)
  1548.  (DOLIST (VAR VARS)
  1549.      (SETQ VAR (GETOPR VAR))
  1550.      (NONSYMCHK VAR '$DECLARE)
  1551.      (COND ((EQ MPROPP 'KIND) (DECLAREKIND VAR PROP))
  1552.            ((EQ MPROPP 'OPERS)
  1553.         (PUTPROP (SETQ VAR (LINCHK VAR)) T PROP) (PUTPROP VAR T 'OPERS)
  1554.         (IF (NOT (GET VAR 'OPERATORS)) (PUTPROP VAR 'SIMPARGS1 'OPERATORS)))
  1555.            ((EQ MPROPP '$ALPHABETIC)
  1556.         (PUTPROP (SETQ VAL (STRIPDOLLAR VAR)) T 'ALPHABET)
  1557.         (ADD2LNC (GETCHARN VAL 1) ALPHABET))
  1558.            ((EQ PROP 'SPECIAL)(proclaim (list 'special var))
  1559.         (FLUIDIZE VAR))
  1560.            (MPROPP
  1561.         (IF (AND (MEMQ PROP '($SCALAR $NONSCALAR))
  1562.              (MGET VAR (IF (EQ PROP '$SCALAR) '$NONSCALAR '$SCALAR)))
  1563.             (MERROR "Inconsistent Declaration: ~:M"
  1564.                 `(($DECLARE) ,VAR ,PROP)))
  1565.         (MPUTPROP VAR VAL PROP))
  1566.            (T (PUTPROP VAR VAL PROP)))
  1567.      (IF (AND (GET VAR 'OP) (OPERATORP1 VAR)
  1568.           (NOT (MEMQ (SETQ VAR (GET VAR 'OP)) (CDR $PROPS))))
  1569.          (SETQ MOPL (CONS VAR MOPL)))
  1570.      (ADD2LNC (GETOP VAR) $PROPS)))
  1571.  
  1572. (DEFUN LINCHK (VAR)
  1573.  (IF (MEMQ VAR '($SUM $INTEGRATE $LIMIT $DIFF $TRANSPOSE)) ($NOUNIFY VAR) VAR))
  1574.  
  1575. (DEFMSPEC $REMOVE (FORM) (I-$REMOVE (CDR FORM)))
  1576.  
  1577. (DEFMFUN I-$REMOVE (L)
  1578.  (IF (ODDP (LENGTH L)) (MERROR "REMOVE takes an even number of arguments."))
  1579.  (DO ((L L (CDDR L)) (VARS) (FLAG NIL NIL)) ((NULL L) '$DONE)
  1580.      (COND (($LISTP (CADR L))
  1581.         (DO ((L1 (CDADR L) (CDR L1))) ((IF (NULL L1) (SETQ FLAG T)))
  1582.          (I-$REMOVE (LIST (CAR L) (CAR L1)))))
  1583.        ((NONSYMCHK (CADR L) '$REMOVE))
  1584.        (T (SETQ VARS (DECLSETUP (CAR L) '$REMOVE))))
  1585.      (COND (FLAG)
  1586.        ((EQ (CADR L) '$VALUE) (I-$REMVALUE VARS))
  1587.        ((EQ (CADR L) '$FUNCTION)
  1588. ;;*** MERGE LOSSAGE ***
  1589. ;;*** File R20:AUX:<ATP.SCHELTER.MACSYMA>MLISP.LISP.14 has:
  1590.         (REMOVE1 (MAPCAR #'REM-VERBIFY VARS) 'MEXPR T $FUNCTIONS T))
  1591.        ((EQ (CADR L) '$MACRO)
  1592.         (REMOVE1 (MAPCAR #'REM-VERBIFY VARS) 'MMACRO T $MACROS T))
  1593. ;;*** File R20:PS:<MACSYM.LSP-TEMP>MLISP.LSP.1 has:
  1594.         ;;(REMOVE1 (MAPCAR #'$VERBIFY VARS) 'MEXPR T $FUNCTIONS T))
  1595.        ;;((EQ (CADR L) '$MACRO)
  1596.         ;;(REMOVE1 (MAPCAR #'$VERBIFY VARS) 'MMACRO T $MACROS T))
  1597.        
  1598.        ((EQ (CADR L) '$ARRAY) (MEVAL `(($REMARRAY) ,@VARS)))
  1599.        ((MEMQ (CADR L) '($ALIAS $NOUN)) (REMALIAS1 VARS (EQ (CADR L) '$ALIAS)))
  1600.        ((EQ (CADR L) '$MATCHDECLARE) (REMOVE1 VARS 'MATCHDECLARE T T NIL))
  1601.        ((EQ (CADR L) '$RULE) (REMRULE VARS))
  1602.        ((MEMQ (CADR L) '($EVFUN $EVFLAG $SPECIAL $NONARRAY $BINDTEST
  1603.                  $AUTOLOAD $ASSIGN))
  1604.         (REMOVE1 VARS (STRIPDOLLAR (CADR L)) NIL T NIL))
  1605.        ((MEMQ (CADR L) '($MODE $MODEDECLARE)) (REMOVE1 VARS 'MODE NIL 'FOO NIL))
  1606.        ((EQ (CADR L) '$ATVALUE) (REMOVE1 VARS 'ATVALUES T T NIL))
  1607.        ((MEMQ (CADR L) '($CONSTANT $NONSCALAR $SCALAR $MAINVAR $NUMER $ATOMGRAD))
  1608.         (REMOVE1 VARS (CADR L) T T NIL))
  1609.        ((MEMQ (CADR L) OPERS) (REMOVE1 (MAPCAR #'LINCHK VARS) (CADR L) NIL T NIL))
  1610.        ((MEMQ (CADR L) (CDR $FEATURES)) (REMOVE1 VARS (CADR L) NIL T NIL))
  1611.        ((EQ (CADR L) '$FEATURE) (DOLIST (VAR VARS) (DELQ VAR $FEATURES 1)))
  1612.        ((MEMQ (CADR L) '($ALPHABETIC $TRANSFUN))
  1613.         (REMOVE1 VARS (CADR L) NIL T NIL))
  1614.        ((MEMQ (CADR L) '($GRADEF $GRAD)) (REMOVE1 VARS 'GRAD NIL $GRADEFS T))
  1615.        ((MEMQ (CADR L) '($DEPENDENCY $DEPEND $DEPENDS))
  1616.         (REMOVE1 VARS 'DEPENDS T $DEPENDENCIES T))
  1617.        ((MEMQ (CADR L) '($OP $OPERATOR)) (REMOVE1 VARS '$OP NIL 'FOO NIL))
  1618.        ((MEMQ (CADR L) '($DEFTAYLOR $TAYLORDEF)) (REMOVE1 VARS 'SP2 NIL T NIL))
  1619.        (T (MERROR "Unknown property to REMOVE: ~:M" (CADR L))))))
  1620.  
  1621. (DEFUN DECLSETUP (X FN)
  1622.  (COND ((ATOM X) (NCONS X))
  1623.        ((EQ (CAAR X) '$NOUNIFY) (NCONS (MEVAL X)))
  1624.        ((EQ (CAAR X) 'MLIST)
  1625.     (MAPCAR #'(LAMBDA (VAR)
  1626.            (COND ((ATOM VAR) VAR)
  1627.              ((EQ (CAAR VAR) '$NOUNIFY) (MEVAL VAR))
  1628.              (T (IMPROPER-ARG-ERR VAR FN))))
  1629.         (CDR X)))
  1630.        (T (IMPROPER-ARG-ERR X FN))))
  1631.  
  1632. (DEFMFUN REMOVE1 (VARS PROP MPROPP INFO FUNP)
  1633.  (DO ((VARS VARS (CDR VARS)) (ALLFLG)) ((NULL VARS))
  1634.      (NONSYMCHK (CAR VARS) '$REMOVE)
  1635.      (COND ((AND (EQ (CAR VARS) '$ALL) (NULL ALLFLG))
  1636.         (SETQ VARS (APPEND VARS (COND ((ATOM INFO) (CDR $PROPS))
  1637.                       (FUNP (MAPCAR #'CAAR (CDR INFO)))
  1638.                       (T (CDR INFO))))
  1639.           ALLFLG T))
  1640.        (T
  1641.         (let ((VAR  (GETOPR (CAR VARS)))( FLAG  NIL))
  1642.         
  1643.           (COND (MPROPP (MREMPROP VAR PROP)
  1644.                   (WHEN (MEMQ PROP '(MEXPR MMACRO))
  1645.                     (MREMPROP VAR 'MLEXPRP)
  1646.                     (MREMPROP VAR 'MFEXPRP)
  1647.                     (IF (NOT (GET VAR 'TRANSLATED))
  1648.                     (ARGS VAR NIL))
  1649.                     (IF (MGET VAR 'TRACE)
  1650.                     (MACSYMA-UNTRACE VAR))))
  1651.               ((EQ PROP '$OP) (KILL-OPERATOR VAR))
  1652.               ((EQ PROP '$ALPHABETIC)
  1653.                (ZL-REMPROP (SETQ PROP (STRIPDOLLAR VAR)) 'ALPHABET)
  1654.                (zl-DELETE (GETCHARN PROP 1) ALPHABET 1))
  1655.               ((EQ PROP '$TRANSFUN)
  1656.                (REMOVE-TRANSL-FUN-PROPS VAR)
  1657.                (REMOVE-TRANSL-ARRAY-FUN-PROPS VAR))
  1658.               ((OR (SETQ FLAG (MEMQ PROP (CDR $FEATURES))) (MEMQ PROP OPERS))
  1659.                (IF FLAG (UNKIND VAR PROP))
  1660.                (ZL-REMPROP VAR PROP)
  1661.                (IF (NOT (GETL VAR (DELQ PROP (copy-top-level OPERS) 1)))
  1662.                (ZL-REMPROP VAR 'OPERS)))
  1663.               (T (ZL-REMPROP VAR PROP)))
  1664.         (COND ((EQ INFO T) (REMPROPCHK VAR))
  1665.               ((EQ INFO 'FOO))
  1666.               (FUNP ;(DELETE (ASSOC (NCONS VAR) INFO) INFO 1)
  1667.                 (mfunction-delete var info))
  1668.               (T (DELQ VAR INFO 1))))
  1669.             ))))
  1670.  
  1671. (DEFUN REMOVE-TRANSL-FUN-PROPS (FUN)
  1672.  (IF (MGET FUN 'TRACE) (MACSYMA-UNTRACE FUN))
  1673.  (WHEN (AND (GET FUN 'TRANSLATED) (NOT (EQ $SAVEDEF '$ALL)))
  1674.        #+Maclisp
  1675.        (DO ((PROPS '(EXPR SUBR LSUBR FEXPR FSUBR) (CDR PROPS)))
  1676.        ((NULL PROPS))
  1677.        (ZL-REMPROP FUN (CAR PROPS)))
  1678.        #-Maclisp
  1679.        (FMAKUNBOUND FUN)
  1680.        (ZL-REMPROP FUN 'TRANSLATED-MMACRO)
  1681.        (MREMPROP FUN 'T-MFEXPR)
  1682.        (ZL-REMPROP FUN 'FUNCTION-MODE)
  1683.        #-(or CL NIL)
  1684.        (IF (NOT (MGETL FUN '(MEXPR MMACRO))) (ARGS FUN NIL))
  1685.        (IF (NOT (GETL FUN '(A-EXPR A-SUBR))) (ZL-REMPROP FUN 'TRANSLATED))))
  1686.  
  1687. (DEFUN REMOVE-TRANSL-ARRAY-FUN-PROPS (FUN)
  1688.  (WHEN (AND (GET FUN 'TRANSLATED) (NOT (EQ $SAVEDEF '$ALL)))
  1689.        (ZL-REMPROP FUN 'A-EXPR)
  1690.        (ZL-REMPROP FUN 'A-SUBR)
  1691.        (IF (NOT (FBOUNDP FUN)) (ZL-REMPROP FUN 'TRANSLATED))))
  1692.  
  1693. (DEFMFUN REMPROPCHK (VAR)
  1694.  (IF (AND (NOT (MGETL VAR '($CONSTANT $NONSCALAR $SCALAR $MAINVAR $NUMER
  1695.                MATCHDECLARE $ATOMGRAD ATVALUES T-MFEXPR)))
  1696.       (NOT (GETL VAR '(EVFUN EVFLAG TRANSLATED NONARRAY BINDTEST
  1697.                OPR SP2 OPERATORS OPERS SPECIAL DATA
  1698.                ALPHABET AUTOLOAD MODE))))
  1699.      (DELQ VAR $PROPS 1)))
  1700.  
  1701. (DEFUN REM-VERBIFY (FNNAME) (NONSYMCHK FNNAME '$REMOVE) ($VERBIFY FNNAME))
  1702.  
  1703.  
  1704.  
  1705. (DEFMSPEC $REMFUNCTION (L) (SETQ L (CDR L))
  1706.   (COND ((MEMQ '$ALL L)
  1707.      (SETQ L (NCONC (MAPCAR #'CAAR (CDR $FUNCTIONS))
  1708.                 (MAPCAR #'CAAR (CDR $MACROS)))))
  1709.     (T (SETQ L (MAPCAR #'REM-VERBIFY L))
  1710.        (DO ((L1 L (CDR L1))) ((NULL L1) T)
  1711.          (IF (NOT (OR (zl-ASSOC (NCONS (CAR L1)) (CDR $FUNCTIONS))
  1712.               (zl-ASSOC (NCONS (CAR L1)) (CDR $MACROS))))
  1713.          (RPLACA L1 NIL)))))
  1714.   (REMOVE1 L 'MEXPR T $FUNCTIONS T)
  1715.   (REMOVE1 L 'MMACRO T $MACROS T)
  1716.   (CONS '(MLIST) L))
  1717.  
  1718. ;; (SETQ L (MAPCAR #'$VERBIFY L))
  1719. ; (DO L1 L (CDR L1) (NULL L1)
  1720. ;     (COND ((EQ (CAR L1) '$ALL)
  1721. ;          (LET ((ZZ (DELQ '$ALL L1)))
  1722. ;        (RPLACA (RPLACD L1 (CDR ZZ)) (CAR ZZ)))
  1723. ;          (NCONC L (MAPCAR #'CAAR (CDR $FUNCTIONS))
  1724. ;             (MAPCAR #'CAAR (CDR $MACROS))))
  1725. ;       ((NOT (OR (ASSOC (NCONS (CAR L1)) (CDR $FUNCTIONS))
  1726. ;             (ASSOC (NCONS (CAR L1)) (CDR $MACROS))))
  1727. ;        (RPLACA L1 NIL))))
  1728. ; (REMOVE1 L 'MEXPR T $FUNCTIONS T)
  1729. ; (REMOVE1 L 'MMACRO T $MACROS T)
  1730. ; (CONS '(MLIST) L))
  1731.  
  1732. (DEFMSPEC $REMARRAY (L) (SETQ L (CDR L))
  1733.  (CONS '(MLIST)
  1734.        (DO ((L L (CDR L)) (X) (PRED)) ((NULL L) (NREVERSE X))
  1735.        (COND ((EQ (CAR L) '$ALL) (SETQ L (APPEND L (CDR $ARRAYS))))
  1736.          (T (REMCOMPARY (CAR L)) (SETQ PRED (MREMPROP (CAR L) 'array))
  1737.             (SETQ PRED (OR (MREMPROP (CAR L) 'HASHAR) PRED))
  1738.             (SETQ PRED (OR (MREMPROP (CAR L) 'AEXPR) PRED))
  1739.             (SETQ X (CONS (AND PRED (PROG2 (DELQ (CAR L) $ARRAYS 1) (CAR L)))
  1740.                   X)))))))
  1741.  
  1742. (DEFUN REMCOMPARY (X)
  1743.  (COND ((EQ X (MGET X 'array)) (ZL-REMPROP X 'ARRAY-MODE) (ZL-REMPROP X 'array))))
  1744.  
  1745. (DEFMSPEC $REMVALUE (FORM) (I-$REMVALUE (CDR FORM)))
  1746.  
  1747. (DEFMFUN I-$REMVALUE (L)
  1748.  (CONS '(MLIST)
  1749.        (DO ((L L (CDR L)) (X) (Y)) ((NULL L) (NREVERSE X))
  1750.        (COND ((EQ (CAR L) '$ALL) (SETQ L (APPEND L (CDR $VALUES))))
  1751.          (T (SETQ X (CONS (COND ((ATOM (CAR L))
  1752.                      (IF (REMVALUE (CAR L) '$REMVALUE) (CAR L)))
  1753.                     ((SETQ Y (MGETL (CAAAR L) '(HASHAR ARRAY)))
  1754.                      (REMARRELEM Y (CAR L)) (CAR L)))
  1755.                 X)))))))
  1756.  
  1757. (DEFMFUN REMARRELEM (ARY FORM)
  1758.   (IF (MFILEP (CADR ARY)) (I-$UNSTORE (NCONS (CAAR FORM))))
  1759.   #-nil
  1760.   (LET ((Y (CAR (ARRAYDIMS (CADR ARY)))))
  1761.     (ARRSTORE FORM (COND ((EQ Y 'fixnum) 0) ((EQ Y 'flonum) 0.0) (T MUNBOUND))))
  1762.   #+nil
  1763.  (LET ((Y (ARRAY-TYPE (CADR ARY))))
  1764.    (ARRSTORE FORM (OR (CDR (ASSQ Y '((FIXNUM . 0)
  1765.                      (FLONUM . 0.0)
  1766.                 #+NIL(SINGLE-FLOAT . 0.0F0)
  1767.                 #+NIL(SHORT-FLOAT . 0.0S0)
  1768.                 #+NIL(DOUBLE-FLOAT . 0.0D0)
  1769.                 #+NIL(LONG-FLOAT . 0.0L0)
  1770.                 )))
  1771.               MUNBOUND)))
  1772.  
  1773.   )
  1774.  
  1775. (DEFMFUN REMRULE (L)
  1776.   (DO ((L L (CDR L)) (U)) ((NULL L))
  1777.     (COND ((EQ (CAR L) '$ALL) (SETQ L (APPEND L (CDR $RULES))))
  1778.       ((GET (CAR L) 'OPERATORS) ($REMRULE (CAR L) '$ALL))
  1779.       ((SETQ U (RULEOF (CAR L))) ($REMRULE U (CAR L)))
  1780.       ((MGET (CAR L) '$RULE)
  1781.        (ZL-REMPROP (CAR L) 'EXPR) (MREMPROP (CAR L) '$RULE)
  1782.        (DELQ (CAR L) $RULES 1)))))
  1783.  
  1784. (DEFMFUN REMALIAS1 (L ALIASP)
  1785.   (DO ((L L (CDR L)) (U)) ((NULL L))
  1786.     (COND ((EQ (CAR L) '$ALL) (SETQ L (APPEND L (CDR $ALIASES))))
  1787.       ((OR ALIASP (GET (CAR L) 'NOUN)) (REMALIAS (CAR L) T))
  1788.       ((SETQ U (GET (CAR L) 'VERB))
  1789.        (ZL-REMPROP (CAR L) 'VERB) (ZL-REMPROP U 'NOUN)))))
  1790.  
  1791. ;in maxmac
  1792. ;(DEFMFUN MGET (ATOM IND)
  1793. ;  (LET ((PROPS (AND (SYMBOLP ATOM) (GET ATOM 'MPROPS))))
  1794. ;;    (AND PROPS (GET PROPS IND)))
  1795. ;    (AND PROPS (GETf (cdr PROPS) IND))))
  1796.  
  1797.  
  1798.  
  1799. #-cl
  1800. (DEFUN MDEFPROP FEXPR (L) (MPUTPROP (CAR L) (CADR L) (CADDR L)) (CAR L))
  1801.  
  1802.  
  1803.  
  1804.  
  1805.  
  1806. (DEFMFUN MREMPROP (ATOM IND)
  1807.   (LET ((PROPS (GET ATOM 'MPROPS))) (AND PROPS (ZL-REMPROP PROPS IND))))
  1808.  
  1809. (DEFMFUN MGETL (ATOM INDS)
  1810.   (LET ((PROPS (GET ATOM 'MPROPS))) (AND PROPS (GETL PROPS INDS))))
  1811.  
  1812. (DEFMFUN $MATRIX N
  1813.   (IF (= N 0)
  1814.       (NCONS '($MATRIX))
  1815.       (LET ((L (LISTIFY N)))
  1816.     (DOLIST (ROW L)
  1817.       (IF (NOT ($LISTP ROW)) (MERROR "Invalid matrix row:~%~M" ROW)))
  1818.     (MATCHECK L)
  1819.     (CONS '($MATRIX) L))))
  1820.  
  1821. (DEFMFUN MATCHECK (L)
  1822.   (DO ((L1 (CDR L) (CDR L1)) (N (LENGTH (CAR L)))) ((NULL L1))
  1823.     (IF (NOT (= N (LENGTH (CAR L1))))
  1824.     (MERROR "All matrix rows are not of the same length."))))
  1825.  
  1826. (DEFUN HARRFIND (FORM)
  1827.        (PROG (ARY Y LISPSUB ITEML SUB NCELLS NITEMS)
  1828.          (SETQ ARY (symbol-array (MGET (CAAR FORM) 'HASHAR)))
  1829.          (COND ((NOT (= (aref ARY 2) (LENGTH (CDR FORM))))
  1830.             (MERROR "Array ~:M already has dimension ~:M~%~M"
  1831.                 (CAAR FORM) (AREF ARY 2) FORM)))
  1832.          (SETQ SUB (CDR FORM))
  1833.          (SETQ ITEML (AREF ARY
  1834.                   (SETQ LISPSUB
  1835.                     (f+ 3 (fixnum-remainder
  1836.                            (HASHER SUB) (AREF ARY 0))))))
  1837.     A    (COND ((NULL ITEML) (GO B))
  1838.            ((ALIKE (CAAR ITEML) SUB) (RETURN (CDAR ITEML))))
  1839.          (SETQ ITEML (CDR ITEML))
  1840.          (GO A)
  1841.     B    (COND (EVARRP (THROW 'EVARRP 'NOTEXIST))
  1842.            ((NULL (SETQ Y (ARRFUNP (CAAR FORM)))) (RETURN (MEVAL2 SUB FORM))))
  1843.          (SETQ Y (ARRFUNCALL Y SUB form))
  1844.          (SETQ ARY (symbol-array (MGET (CAAR FORM) 'HASHAR)))
  1845.          (SETQ ITEML (aref ARY (SETQ LISPSUB (f+ 3 (fixnum-remainder (HASHER SUB) (aref ARY 0))))))
  1846.          (SETQ SUB (NCONS (CONS SUB Y)))
  1847.          (COND (ITEML (NCONC ITEML SUB)) (T (STORE (aref ARY LISPSUB) SUB)))
  1848.          (STORE (AREF ARY 1) (SETQ NITEMS (f1+ (AREF ARY 1))))
  1849.          (COND ((> NITEMS (SETQ NCELLS (AREF ARY 0)))
  1850.             (ARRAYSIZE (CAAR FORM) (f+ NCELLS NCELLS))))
  1851.          (RETURN Y)))
  1852.  
  1853. ; Types of FIXNUM and FLONUM herein not currently compatible 
  1854. ; on LISP machine.  Don't worry about it for now.
  1855. (DEFUN ARRFIND (FORM)
  1856.   (let ((sub (cdr form)) u v type)
  1857.     (SETQ V (DIMCHECK (CAAR FORM) SUB NIL))
  1858.     (COND (V (SETQ TYPE (CAR (ARRAYDIMS (MGET (CAAR FORM) 'array))))))
  1859.     (COND ((AND V (PROG2 #-cl
  1860.              (SETQ U (APPLY (MGET (CAAR FORM) 'array) SUB))
  1861.              #+cl
  1862.              (setq u (apply 'aref (symbol-array
  1863.                            (MGET (CAAR FORM) 'array))
  1864.                     sub))
  1865.              (COND ((EQ TYPE 'flonum) (NOT (= U FLOUNBOUND)))
  1866.                    ((EQ TYPE 'fixnum) (NOT (= U FIXUNBOUND)))
  1867.                    (T (NOT (EQ U MUNBOUND))))))
  1868.        U)
  1869.       (EVARRP (THROW 'EVARRP 'NOTEXIST))
  1870.       ((OR (NOT V) (NULL (SETQ U (ARRFUNP (CAAR FORM)))))
  1871.        (COND ((EQ TYPE 'flonum) 0.0)
  1872.          ((EQ TYPE 'fixnum) 0)
  1873.          (T (MEVAL2 SUB FORM))))
  1874.       (T (SETQ U (ARRFUNCALL U SUB form))
  1875.          #-cl(STORE (APPLY (MGET (CAAR FORM) 'array) SUB) U)
  1876.          #+cl
  1877.          (setf (apply #'aref (SYMBOL-ARRAY (MGET (CAAR FORM) 'array))
  1878.                 sub) u)
  1879.          
  1880.          U))))
  1881.  
  1882.  
  1883.  
  1884. ;#+cl
  1885. ;(defmacro $array (ar typ &rest dims)
  1886. ;   (setq ar (make-array dims :initial-element init))
  1887. ;   (cond ((
  1888.  
  1889.  
  1890. (DEFMSPEC $ARRAY (X) (SETQ X (CDR X))
  1891.  (COND #+cl
  1892.        ($use_fast_arrays
  1893.       
  1894.       (mset (car x) (apply '$make_array '$any
  1895.                    (mapcar #'1+ (cdr x)))))
  1896.        ((SYMBOLP (CAR X))
  1897.     (funcall #'(LAMBDA (COMPP)
  1898.       (funcall #'(LAMBDA (FUN DIML FUNP OLD NEW NCELLS)
  1899.         (COND ((MEMQ '$FUNCTION DIML)
  1900.            (SETQ DIML (DELQ '$FUNCTION (copy-top-level DIML) 1) FUNP T)))
  1901.         (SETQ DIML (MAPCAR #'MEVAL DIML))
  1902.         (COND ((NULL DIML) (WNA-ERR '$ARRAY))
  1903.           ((> (LENGTH DIML) 5) (MERROR "ARRAY takes at most 5 indices"))
  1904.           ((MEMQ NIL (MAPCAR #'(LAMBDA (U) (EQ (ml-typep U) 'fixnum)) DIML))
  1905.            (MERROR "Non-integer dimension - ARRAY")))
  1906.         (SETQ DIML (MAPCAR #'1+ DIML))
  1907.         (SETQ NEW (APPLY #'*ARRAY (CONS (IF COMPP FUN (GENSYM))
  1908.                         (CONS #-CL (OR COMPP T)
  1909.                           #+CL T
  1910.                           DIML))))
  1911.         #+cl
  1912.         (COND ((EQ COMPP 'fixnum) (FILLARRAY NEW '(0)))
  1913.           ((EQ COMPP 'flonum) (FILLARRAY NEW '(0.0))))
  1914.         (COND ((NOT (MEMQ COMPP '(FIXNUM FLONUM))) (FILLARRAY NEW (LIST MUNBOUND)))
  1915.           ((OR FUNP (ARRFUNP FUN))
  1916.            (FILLARRAY NEW (LIST (COND ((EQ COMPP 'fixnum) FIXUNBOUND)
  1917.                           (T FLOUNBOUND))))))
  1918.         (COND ((NULL (SETQ OLD (MGET FUN 'HASHAR)))
  1919.            (MPUTPROP FUN NEW 'array))
  1920.           (T (COND ((NOT (= (AFUNCALL OLD 2) (LENGTH DIML)))
  1921.                 (MERROR "Array ~:M already has ~:M dimension(s)"
  1922.                     FUN (AFUNCALL OLD 2))))
  1923.              (SETQ NCELLS (f+ 2 (AFUNCALL OLD 0)))
  1924.              (DO ((N 3 (f1+ N))) ((> N NCELLS))
  1925.              (DO ((ITEMS (AFUNCALL OLD N) (CDR ITEMS))) ((NULL ITEMS))
  1926.                  (DO ((X (CAAR ITEMS) (CDR X)) (Y DIML (CDR Y)))
  1927.                  ((NULL X)
  1928.                   (IF (AND (MEMQ COMPP '(FIXNUM FLONUM))
  1929.                        (NOT (EQ (ml-typep (CDAR ITEMS)) COMPP)))
  1930.                       (MERROR "Element and array type do not match:~%~M"
  1931.                           (CDAR ITEMS)))
  1932.                   #-cl(EVAL (LIST 'STORE
  1933.                             (CONS NEW (CAAR ITEMS))
  1934.                             (LIST 'QUOTE (CDAR ITEMS))))
  1935.                   #+cl
  1936.                   (setf (APPLY #'Aref
  1937.                            (SYMBOL-ARRAY NEW)
  1938.                            (CAAR ITEMS))
  1939.                     (CDAR ITEMS)))
  1940.                  (IF (OR (NOT (EQ (ml-typep (CAR X)) 'fixnum))
  1941.                      (< (CAR X) 0)
  1942.                      (NOT (< (CAR X) (CAR Y))))
  1943.                      (MERROR "Improper index for declared array:~%~M"
  1944.                          (CAR X))))))
  1945.              (MREMPROP FUN 'HASHAR)
  1946.              (MPUTPROP FUN NEW 'array)))
  1947.              (ADD2LNC FUN $ARRAYS)
  1948.          (IF (EQ COMPP 'fixnum) (PUTPROP FUN '$FIXNUM 'ARRAY-MODE))
  1949.          (IF (EQ COMPP 'flonum) (PUTPROP FUN '$FLOAT 'ARRAY-MODE))
  1950.          FUN)
  1951.        ($VERBIFY (CAR X)) (COND (COMPP (SETQ COMPP (CDR COMPP)) (CDDR X)) (T (CDR X)))
  1952.        NIL NIL NIL 0))
  1953.      (ASSQ (CADR X) '(($COMPLETE . T) ($INTEGER . FIXNUM) ($FIXNUM . FIXNUM)
  1954.               ($FLOAT . FLONUM) ($FLONUM . FLONUM)))))
  1955.        (($LISTP (CAR X))
  1956.     (DO ((U (CDAR X) (CDR U))) ((NULL U)) (MEVAL `(($ARRAY) ,(CAR U) ,@(CDR X))))
  1957.     (CAR X))
  1958.        (T (MERROR "Improper first argument to ARRAY:~%~M" (CAR X)))))
  1959.  
  1960.  
  1961.  
  1962.  
  1963. #+cl
  1964. (defmfun $Show_hash_array (x)
  1965.   (send x :map-hash
  1966.    `(lambda (u v) 
  1967.     (format t "~%~A-->~A" u v))))
  1968.   
  1969. #+cl
  1970. ;; If this is T then arrays are stored in the value cell,
  1971. ;; whereas if it is false they are stored in the function cell
  1972. (defmvar $use_fast_arrays nil)
  1973. #+cl
  1974. (DEFMFUN ARRSTORE (L R &aux tem index)
  1975.   (cond ($use_fast_arrays
  1976.      (cond ((and (boundp (caar l)) (setq tem (symbol-value (caar l))))
  1977.         (setq index (mevalargs (cdr l)))
  1978.         (LET ((THE-TYPE (ml-typep TEM)))
  1979.            (COND ((EQ THE-TYPE 'array)
  1980.              (setf (APPLY #'Aref TEM INDEX)  R))
  1981.             ((EQ THE-TYPE #+cl 'hash-table
  1982.                           #-cl'SI:EQUAL-HASH-TABLE)
  1983.              (cond ((gethash 'dim1 tem)
  1984.                 (if (cdr index)
  1985.                     (error "Array has dimension 1")))
  1986.                    (t (or (cdr index)
  1987.                       (error "Array has dimension > 1"))))
  1988.              (setf (gethash
  1989.                  (if (cdr index) index
  1990.                    (car index))
  1991.                  tem) r))
  1992.             ((EQ THE-TYPE  'list)
  1993.              (COND ((EQ (CAAR TEM) 'MLIST)
  1994.                 (SETQ INDEX (CAR INDEX))
  1995.                 (SETF (NTH INDEX TEM) R)
  1996.                 r)
  1997.                    ((eq (caar tem) '$matrix)
  1998.                 (setf (nth (second index) (nth (first index) tem)) r)
  1999.                 r)
  2000.                       (T
  2001.                 (ERROR "The value of ~A is not a hash-table ,an ~
  2002.                                            array, macsyma list, or a matrix"
  2003.                     (CAAR L)))))
  2004.             (T(cond ((eq tem (caar l))
  2005.                  (meval* `((mset) ,(caar l)
  2006.                        ,(make-equal-hash-table
  2007.                           (cdr (mevalargs (cdr l))))))
  2008.                    (arrstore l r))
  2009.                 (t
  2010.                  (error "The value of ~A is not a hash-table , an array,a macsyma list, or a matrix" (caar l))))
  2011.               ))))
  2012.            (t
  2013.         (cond ((mget (caar l) 'hashar)
  2014.                (let ($use_fast_arrays)
  2015.              (arrstore l r)))
  2016.               (t
  2017.                (meval* `((mset) ,(caar l)
  2018.                  ,(make-equal-hash-table
  2019.                     (cdr (mevalargs (cdr l))))))
  2020.                (arrstore l r))))))
  2021.     (t
  2022.      (LET ((FUN ($VERBIFY (CAAR L))) ARY SUB (LISPSUB 0) HASHL MQAPPLYP)
  2023.        (COND ((SETQ ARY (MGET FUN 'array))
  2024.           (WHEN (MFILEP ARY)
  2025.             (I-$UNSTORE (NCONS FUN)) (SETQ ARY (MGET FUN 'array)))
  2026.           (DIMCHECK FUN (SETQ SUB (MAPCAR #'MEVAL (CDR L))) T)
  2027.           (IF (AND (MEMQ (SETQ FUN (CAR (ARRAYDIMS ARY))) '(FIXNUM FLONUM))
  2028.                (NOT (EQ (ml-typep R) FUN)))
  2029.               (MERROR "Improper assignment to complete array:~%~M" R))
  2030. ;          #-cl(EVAL (LIST 'STORE (CONS ARY SUB) (LIST 'QUOTE R)))
  2031.           #+cl(setf (APPLY #'Aref (SYMBOL-ARRAY ARY) SUB)  R)
  2032.           )
  2033.          ((SETQ ARY (MGET FUN 'HASHAR))
  2034.           (WHEN (MFILEP ARY)
  2035.             (I-$UNSTORE (NCONS FUN)) (SETQ ARY (MGET FUN 'HASHAR)))
  2036.           (IF (NOT (= (AFUNCALL ARY 2) (LENGTH (CDR L))))
  2037.               (MERROR "Array ~:M has dimension ~:M; it was called by ~:M"
  2038.                   FUN (AFUNCALL ARY 2) L))
  2039.           (SETQ SUB (MAPCAR #'MEVAL (CDR L)))
  2040.           (SETQ HASHL (AFUNCALL ARY (SETQ LISPSUB
  2041.                          (f+ 3 (fixnum-remainder (HASHER SUB) (AFUNCALL ARY 0))))))      (DO ((HASHL1 HASHL (CDR HASHL1)))
  2042.           ((NULL HASHL1)
  2043.            (COND ((NOT (EQ R MUNBOUND))
  2044.               (SETQ SUB (NCONS (CONS SUB R)))
  2045.               (COND ((NULL HASHL) (STORE (AFUNCALL ARY LISPSUB) SUB))
  2046.                 (T (NCONC HASHL SUB)))
  2047.               (STORE (AFUNCALL ARY 1) (f1+ (AFUNCALL ARY 1))))))
  2048.         (COND ((ALIKE (CAAR HASHL1) SUB)
  2049.            (COND ((EQ R MUNBOUND) (STORE (AFUNCALL ARY 1)
  2050.                          (f1- (AFUNCALL ARY 1))))
  2051.              (T (NCONC HASHL (NCONS (CONS SUB R)))))
  2052.            (STORE (AFUNCALL ARY LISPSUB) (zl-DELETE (CAR HASHL1) HASHL 1))
  2053.            (RETURN NIL))))
  2054.           (IF (> (AFUNCALL ARY 1) (AFUNCALL ARY 0))
  2055.               (ARRAYSIZE FUN (f* 2 (AFUNCALL ARY 0))))
  2056.           R)
  2057.          ((AND (EQ FUN 'MQAPPLY) (MXORLISTP (SETQ ARY (MEVAL (CADR L))))
  2058.                (PROG2 (SETQ MQAPPLYP T L (CDR L)) NIL)))
  2059.          
  2060.          ((AND (NOT MQAPPLYP)
  2061.                (OR (NOT (BOUNDP FUN)) (NOT (OR (MXORLISTP (SETQ ARY (SYMBOL-VALUE FUN)))
  2062.                                (EQ (ml-typep ARY) 'array)))))
  2063.           (IF (MEMQ FUN '(MQAPPLY $%)) (MERROR "Illegal use of :"))
  2064.           (ADD2LNC FUN $ARRAYS)
  2065.           (MPUTPROP FUN (SETQ ARY (GENSYM)) 'HASHAR)
  2066.           (*ARRAY ARY T 7) (STORE (AFUNCALL ARY 0) 4) (STORE (AFUNCALL ARY 1) 0)
  2067.           (STORE (AFUNCALL ARY 2) (LENGTH (CDR L)))
  2068.           (ARRSTORE L R))
  2069.          
  2070.          ((EQ (ml-typep ARY) 'array)
  2071.           (ARRSTORE-EXTEND ARY (MEVALARGS (CDR L)) R))
  2072.          ((OR (EQ (CAAR ARY) 'MLIST) (= (LENGTH L) 2))
  2073.           (COND ((EQ (CAAR ARY) '$MATRIX)
  2074.              (COND ((OR (NOT ($LISTP R)) (NOT (= (LENGTH (CADR ARY)) (LENGTH R))))
  2075.                 (MERROR "Attempt to assign bad matrix row:~%~M" R))))
  2076.             ((NOT (= (LENGTH L) 2))
  2077.              (MERROR "Wrong number of indices:~%~M" (CONS '(MLIST) (CDR L)))))
  2078.           (LET ((INDEX (MEVAL (CADR L))))
  2079.             (COND ((NOT (EQ (ml-typep INDEX) 'fixnum))
  2080.                (MERROR "Index not an integer:~%~M" INDEX))
  2081.               ((AND (> INDEX 0) (< INDEX (LENGTH ARY)))
  2082.                (RPLACA (NCDR (CDR ARY) INDEX) R))
  2083.               (T (MERROR "~A - index out of range" INDEX))))
  2084.           R)
  2085.          (T (IF (NOT (= (LENGTH L) 3))
  2086.             (MERROR "Wrong number of indices:~%~M" (CONS '(MLIST) (CDR L))))
  2087.             ($SETELMX R (MEVAL (CADR L)) (MEVAL (CADDR L)) ARY)
  2088.             R))))))
  2089.            
  2090.  
  2091. #-cl
  2092. (DEFMFUN ARRSTORE (L R)
  2093.  (LET ((FUN ($VERBIFY (CAAR L))) ARY SUB (LISPSUB 0) HASHL MQAPPLYP)
  2094.    (COND ((SETQ ARY (MGET FUN 'array))
  2095.       (WHEN (MFILEP ARY)
  2096.         (I-$UNSTORE (NCONS FUN)) (SETQ ARY (MGET FUN 'array)))
  2097.       (DIMCHECK FUN (SETQ SUB (MAPCAR #'MEVAL (CDR L))) T)
  2098.       (IF (AND (MEMQ (SETQ FUN (CAR (ARRAYDIMS ARY))) '(FIXNUM FLONUM))
  2099.            (NOT (EQ (ml-typep R) FUN)))
  2100.           (MERROR "Improper assignment to complete array:~%~M" R))
  2101.       #-lispm(EVAL (LIST 'STORE (CONS ARY SUB) (LIST 'QUOTE R)))
  2102.       )
  2103.      ((SETQ ARY (MGET FUN 'HASHAR))
  2104.       (WHEN (MFILEP ARY)
  2105.         (I-$UNSTORE (NCONS FUN)) (SETQ ARY (MGET FUN 'HASHAR)))
  2106.       (IF (NOT (= (AFUNCALL ARY 2) (LENGTH (CDR L))))
  2107.           (MERROR "Array ~:M has dimension ~:M; it was called by ~:M"
  2108.               FUN (AFUNCALL ARY 2) L))
  2109.       (SETQ SUB (MAPCAR #'MEVAL (CDR L)))
  2110.       (SETQ HASHL (AFUNCALL ARY (SETQ LISPSUB (f+ 3 (fixnum-remainder (HASHER SUB) (AFUNCALL ARY 0))))))      (DO ((HASHL1 HASHL (CDR HASHL1)))
  2111.           ((NULL HASHL1)
  2112.            (COND ((NOT (EQ R MUNBOUND))
  2113.               (SETQ SUB (NCONS (CONS SUB R)))
  2114.               (COND ((NULL HASHL) (STORE (AFUNCALL ARY LISPSUB) SUB))
  2115.                 (T (NCONC HASHL SUB)))
  2116.               (STORE (AFUNCALL ARY 1) (f1+ (AFUNCALL ARY 1))))))
  2117.           (COND ((ALIKE (CAAR HASHL1) SUB)
  2118.              (COND ((EQ R MUNBOUND) (STORE (AFUNCALL ARY 1)
  2119.                            (f1- (AFUNCALL ARY 1))))
  2120.                (T (NCONC HASHL (NCONS (CONS SUB R)))))
  2121.              (STORE (AFUNCALL ARY LISPSUB) (zl-DELETE (CAR HASHL1) HASHL 1))
  2122.              (RETURN NIL))))
  2123.       (IF (> (AFUNCALL ARY 1) (AFUNCALL ARY 0))
  2124.           (ARRAYSIZE FUN (f* 2 (AFUNCALL ARY 0))))
  2125.       R)
  2126.      ((AND (EQ FUN 'MQAPPLY) (MXORLISTP (SETQ ARY (MEVAL (CADR L))))
  2127.            (PROG2 (SETQ MQAPPLYP T L (CDR L)) NIL)))
  2128.      
  2129.      ((AND (NOT MQAPPLYP)
  2130.            (OR (NOT (BOUNDP FUN)) (NOT (OR (MXORLISTP (SETQ ARY (SYMBOL-VALUE FUN)))
  2131.                            (EQ (ml-typep ARY) 'array)))))
  2132.       (IF (MEMQ FUN '(MQAPPLY $%)) (MERROR "Illegal use of :"))
  2133.       (ADD2LNC FUN $ARRAYS)
  2134.       (MPUTPROP FUN (SETQ ARY (GENSYM)) 'HASHAR)
  2135.       (*ARRAY ARY T 7) (STORE (AFUNCALL ARY 0) 4) (STORE (AFUNCALL ARY 1) 0)
  2136.       (STORE (AFUNCALL ARY 2) (LENGTH (CDR L)))
  2137.       (ARRSTORE L R))
  2138.      
  2139.      ((EQ (ml-typep ARY) 'array)
  2140.       (ARRSTORE-EXTEND ARY (MEVALARGS (CDR L)) R))
  2141.      ((OR (EQ (CAAR ARY) 'MLIST) (= (LENGTH L) 2))
  2142.       (COND ((EQ (CAAR ARY) '$MATRIX)
  2143.          (COND ((OR (NOT ($LISTP R)) (NOT (= (LENGTH (CADR ARY)) (LENGTH R))))
  2144.             (MERROR "Attempt to assign bad matrix row:~%~M" R))))
  2145.         ((NOT (= (LENGTH L) 2))
  2146.          (MERROR "Wrong number of indices:~%~M" (CONS '(MLIST) (CDR L)))))
  2147.       (LET ((INDEX (MEVAL (CADR L))))
  2148.         (COND ((NOT (EQ (ml-typep INDEX) 'fixnum))
  2149.            (MERROR "Index not an integer:~%~M" INDEX))
  2150.           ((AND (> INDEX 0) (< INDEX (LENGTH ARY)))
  2151.            (RPLACA (NCDR (CDR ARY) INDEX) R))
  2152.           (T (MERROR "~A - index out of range" INDEX))))
  2153.       R)
  2154.      (T (IF (NOT (= (LENGTH L) 3))
  2155.         (MERROR "Wrong number of indices:~%~M" (CONS '(MLIST) (CDR L))))
  2156.         ($SETELMX R (MEVAL (CADR L)) (MEVAL (CADDR L)) ARY)
  2157.         R)))) 
  2158.  
  2159. (DEFUN ARRFUNP (X)
  2160.  (OR (AND $TRANSRUN (GETL X '(A-EXPR #+Maclisp A-SUBR))) (MGETL X '(AEXPR))))
  2161.  
  2162. #-cl
  2163. (defmacro system-subrcall* (p argl) p argl
  2164.   (cond ((status feature maclisp)
  2165.      `(subrcall* ,p ,argl))
  2166.     (t
  2167.      `(MAXIMA-ERROR '|Don't think I can A-SUBR frobulate here!|))))
  2168. #+lispm
  2169. (defmacro system-subrcall* (p argl) p argl
  2170.   (cond
  2171.     #-cl
  2172.     ((status feature maclisp)
  2173.      `(subrcall* ,p ,argl))
  2174.        (t
  2175.      `(error "Don't think I can A-SUBR frobulate here!"))))
  2176. #-(or cl NIL)
  2177. (defmacro assemble-subrcall* ()
  2178.   (cond ((status feature maclisp)
  2179.      (cond ((status feature pdp10)
  2180.         '(PROGN 'COMPILE
  2181.             (SETPLIST '|the subr| '(SUBR NIL))
  2182.             (lap-a-list
  2183.              '((LAP SUBRCALL* SUBR) 
  2184.                (ARGS SUBRCALL* (()  . 2)) 
  2185.                (HRRZ 3 '|the subr|)
  2186.                (HRRZ 4 0 3) 
  2187.                (HRLM 1 0 4) 
  2188.                (MOVEI 1 '|the subr|) 
  2189.                (JCALL 2 '*APPLY) 
  2190.                ()  ))))
  2191.            (t
  2192.         ;; the above optimizes out the JSP PDLNMK
  2193.         ;; which is not needed since we know the first argument
  2194.         ;; is NOT a number. We are more interested in
  2195.         ;; illustrating the issue than in bumming out
  2196.         ;; a couple instructions, however there it is.
  2197.         '(progn 'compile
  2198.             (setplist '|the subr| '(SUBR NIL))
  2199.             (defun subrcall* (p argl)
  2200.               (rplaca (cdr (symbol-plist '|the subr|)) p)
  2201.               (apply #'|the subr| argl))))))
  2202.     (t nil)))
  2203. #-(or cl NIL)
  2204. (assemble-subrcall*)
  2205.                             
  2206. (DEFUN ARRFUNCALL (ARRFUN SUBS form)
  2207.   (LET ((AEXPRP T))
  2208.     (CASE (CAR ARRFUN)
  2209.       (AEXPR (MAPPLY1 (CADR ARRFUN) SUBS (CADR ARRFUN) form))
  2210.       (A-EXPR (APPLY (CADR ARRFUN) SUBS))
  2211.       (A-SUBR 
  2212.        (COMMENT "This is what the code used to look like:"
  2213.         (EVAL (NCONC (LIST 'SUBRCALL NIL
  2214.                    (LIST 'QUOTE (CADR ARRFUN))) SUBS)))
  2215.        (SYSTEM-SUBRCALL* (CADR ARRFUN) SUBS)))))
  2216.  
  2217. (DEFUN HASHER (L)  ; This is not the best way to write a hasher.  But, 
  2218.  (IF (NULL L)       ; please don't change this code or you're liable to 
  2219.      0           ; break SAVE files.
  2220.      (LOGAND #o77777
  2221.          (LET ((X (CAR L)))
  2222.           (COND (($RATP X) (MERROR "Subscripts may not be in CRE form."))
  2223.             (#+NIL (ml-typep X '(OR FIXNUM DOUBLE-FLOAT))
  2224.              #-NIL (OR (FIXNUMP X) (FLOATP X))
  2225.              (f+ (IF (FIXNUMP X) X (FIX (+$ X 0.0005)))
  2226.                 (f* 7 (HASHER (CDR L)))))
  2227.             ((ATOM X) (f+ (SXHASH X) (HASHER (CDR L))))
  2228.             (T (f+ 1 (SXHASH (CAAR X)) (HASHER (CDR X))
  2229.                   (HASHER (CDR L)))))))))
  2230.  
  2231. (DEFUN ARRAYSIZE (FUN N)
  2232.        (PROG (OLD NEW INDX NCELLS CELL ITEM I Y)
  2233.          (SETQ OLD (symbol-array (MGET FUN 'HASHAR)))
  2234.          (MPUTPROP FUN (SETQ NEW (GENSYM)) 'HASHAR)
  2235.          (*ARRAY NEW T (f+ N 3))
  2236.          (setq new (symbol-array new))
  2237.          (STORE (AREF NEW 0) N)
  2238.          (STORE (AREF NEW 1) (AREF OLD 1))
  2239.          (STORE (AREF NEW 2) (AREF OLD 2))
  2240.          (SETQ INDX 2 NCELLS (f+ 2 (AREF OLD 0)))
  2241.     A    (IF (> (SETQ INDX (f1+ INDX)) NCELLS) (RETURN T))
  2242.          (SETQ CELL (AREF OLD INDX))
  2243.     B    (IF (NULL CELL) (GO A))
  2244.          (SETQ I (f+ 3 (fixnum-remainder (HASHER (CAR (SETQ ITEM (CAR CELL)))) N)))
  2245.          (IF (SETQ Y (AREF NEW I))
  2246.          (NCONC Y (NCONS ITEM))
  2247.          (STORE (AREF NEW I) (NCONS ITEM)))
  2248.          (SETQ CELL (CDR CELL))
  2249.          (GO B)))
  2250.  
  2251. (DEFUN DIMCHECK (ARY SUB FIXPP)
  2252.  (DO ((X SUB (CDR X)) (RET T) (Y (CDR (ARRAYDIMS (MGET ARY 'array))) (CDR Y)))
  2253.      ((NULL Y)
  2254.       (IF X (MERROR "Array ~:M has dimensions ~:M, but was called with ~:M"
  2255.             ARY `((MLIST)
  2256.               ,.(MAPCAR #'1-
  2257.                     (CDR (ARRAYDIMS (MGET ARY 'array)))))
  2258.               `((MLIST) ,.SUB))
  2259.         RET))
  2260.      (COND ((OR (NULL X) (AND (EQ (ml-typep (CAR X)) 'fixnum)
  2261.                   (OR (< (CAR X) 0) (NOT (< (CAR X) (CAR Y))))))
  2262.         (SETQ Y NIL X (CONS NIL T)))
  2263.        ((NOT (fixnump (car x)) )
  2264.         (IF FIXPP (SETQ Y NIL X (CONS NIL T)) (SETQ RET NIL))))))
  2265.  
  2266. (DEFUN CONSTLAM (x &aux (lam x))
  2267.  (IF AEXPRP
  2268.      `(,(CAR LAM) ,(CADR LAM) ,@(MBINDING ((MPARAMS (CADR LAM)))
  2269.                       (MAPCAR #'MEVAL (CDDR LAM))))
  2270.  
  2271.      LAM))
  2272.  
  2273. (DEFMSPEC $DEFINE (L)
  2274.   (TWOARGCHECK L)
  2275.   (SETQ L (CDR L))
  2276.   (MEVAL `((MDEFINE)
  2277.        ,(COND ((MQUOTEP (CAR L)) (CADAR L))
  2278.           ((AND (NOT (ATOM (CAR L)))
  2279.             (MEMQ (CAAAR L) '($EV $FUNMAKE $ARRAYMAKE)))
  2280.            (MEVAL (CAR L)))
  2281.           (T (DISP2 (CAR L))))
  2282.        ,(MEVAL (CADR L)))))
  2283.  
  2284. (defun set-lineinfo (fnname lineinfo body type)
  2285.   (cond ((and (consp lineinfo) (eq 'src (third lineinfo)))
  2286.      (setf (cdddr lineinfo) (list fnname (first lineinfo)))
  2287.      (setf (get fnname 'lineinfo) body))
  2288.     (t (remprop fnname 'lineinfo))))
  2289.  
  2290. (DEFMSPEC MDEFINE (L )
  2291.  (let ($use_fast_arrays) ;;for mdefine's we allow use the oldstyle hasharrays
  2292.  (TWOARGCHECK L)
  2293.  (SETQ L (CDR L))
  2294.  (LET ((FUN (CAR L)) (BODY (CADR L)) ARGS SUBS ARY FNNAME MQDEF REDEF)
  2295.    (COND ((OR (ATOM FUN)
  2296.           (AND (SETQ MQDEF (EQ (CAAR FUN) 'MQAPPLY))
  2297.            (MEMQ 'array (CDAR FUN))))
  2298.       (MERROR "Improper function definition:~%~M" FUN))
  2299.      (MQDEF (IF (OR (ATOM (CADR FUN))
  2300.             (NOT (SETQ ARY (MEMQ 'array (CDAADR FUN)))))
  2301.             (MERROR "Improper function definition:~%~M" (CADR FUN)))
  2302.         (SETQ SUBS (CDADR FUN) ARGS (CDDR FUN) FUN (CADR FUN)
  2303.               FNNAME ($VERBIFY (CAAR FUN)))
  2304.         (IF (AND (NOT (MGETL FNNAME '(HASHAR ARRAY)))
  2305.              (GET FNNAME 'SPECSIMP))
  2306.             (MTELL "Warning - you are redefining the MACSYMA ~
  2307.                 subscripted function ~:M.~%"
  2308.                FNNAME)))
  2309.      ((PROG2 (SETQ FNNAME ($VERBIFY (CAAR FUN)))
  2310.          (OR (MOPP FNNAME) (MEMQ FNNAME '($ALL $ALLBUT $%))))
  2311.       (MERROR "Improper function name: ~:@M" FNNAME))
  2312.      ((SETQ ARY (MEMQ 'array (CDAR FUN))) (SETQ SUBS (CDR FUN)))
  2313.      (T (SETQ ARGS (CDR FUN) REDEF (MREDEF-CHECK FNNAME))))
  2314.    (IF (NOT ARY) (REMOVE1 (NCONS FNNAME) 'MMACRO T $MACROS T))
  2315.    (MDEFCHK FNNAME (OR ARGS (AND (NOT MQDEF) SUBS)) ARY MQDEF)
  2316.    (IF (NOT (EQ FNNAME (CAAR FUN))) (RPLACA (CAR FUN) FNNAME))
  2317.    (COND ((NOT ARY) (IF (AND EVP (MEMQ FNNAME (CAR LOCLIST)))
  2318.             (MPUTPROP FNNAME T 'LOCAL-FUN)
  2319.             (REMOVE-TRANSL-FUN-PROPS FNNAME))
  2320.             (ADD2LNC (CONS (NCONS FNNAME) ARGS) $FUNCTIONS)
  2321.             (set-lineinfo fnname (cadar fun) body 'mexpr)
  2322.             (MPUTPROP FNNAME (MDEFINE1 ARGS BODY) 'MEXPR)
  2323.             #+MacLisp
  2324.             (IF (NOT REDEF)
  2325.             (ARGS FNNAME (IF (NOT (MGET FNNAME 'MLEXPRP))
  2326.                      (CONS NIL (LENGTH ARGS)))))
  2327.             (IF $TRANSLATE (TRANSLATE-FUNCTION FNNAME)))
  2328.      ((PROG2 (ADD2LNC FNNAME $ARRAYS)
  2329.          (SETQ ARY (MGETL FNNAME '(HASHAR ARRAY)))
  2330.          (REMOVE-TRANSL-ARRAY-FUN-PROPS FNNAME))
  2331.       (WHEN (MFILEP (CADR ARY))
  2332.         (I-$UNSTORE (NCONS FNNAME))
  2333.         (SETQ ARY (MGETL FNNAME '(HASHAR ARRAY))))
  2334.       (IF (NOT (= (IF (EQ (CAR ARY) 'HASHAR)
  2335.               (aref (symbol-array (CADR ARY)) 2)
  2336.               #+NIL (ARRAY-/#-DIMS (CADR ARY))
  2337.               #-NIL (LENGTH (CDR (ARRAYDIMS (CADR ARY)))))
  2338.               (LENGTH SUBS)))
  2339.           (MERROR "Array ~:M already defined with different dimensions"
  2340.               FNNAME))
  2341.       (MDEFARRAY FNNAME SUBS ARGS BODY MQDEF))
  2342.      (T (MPUTPROP FNNAME (SETQ ARY (GENSYM)) 'HASHAR)
  2343.         (*ARRAY ARY T 7)
  2344.         (STORE (AFUNCALL ARY 0) 4)
  2345.         (STORE (AFUNCALL ARY 1) 0)
  2346.         (STORE (AFUNCALL ARY 2) (LENGTH SUBS))
  2347.         (MDEFARRAY FNNAME SUBS ARGS BODY MQDEF)))
  2348.    (CONS '(MDEFINE SIMP) #-CL L #+CL (COPY-LIST L)))))
  2349.  
  2350. ; Checks to see if a user is clobbering the name of a system function.  
  2351. ; Prints a warning and returns T if he is, and NIL if he isn't.
  2352. (DEFUN MREDEF-CHECK (FNNAME)
  2353.  (COND ((AND (NOT (MGET FNNAME 'MEXPR))
  2354.          (OR (AND #+MacLisp
  2355.               (GETL FNNAME '(SUBR FSUBR MFEXPR*S LSUBR AUTOLOAD))
  2356.               #+Franz (getd fnname)
  2357.               #+NIL
  2358.               (OR (GET FNNAME 'MFEXPR*)
  2359.               (GETL-NIL-FCN-PROP FNNAME '(SUBR)))
  2360.               #+CL
  2361.               (OR (GET FNNAME 'AUTOLOAD)
  2362.               (GETL-LM-FCN-PROP FNNAME '(SUBR FSUBR LSUBR))
  2363.               (GET FNNAME 'MFEXPR*S))
  2364.               (NOT (GET FNNAME 'TRANSLATED)))
  2365.          (MOPP FNNAME)))
  2366.     (PRINC "Warning - you are redefining the MACSYMA ")
  2367.     (IF (GETL FNNAME '(VERB OPERATORS))
  2368.         (PRINC "command ") (PRINC "function "))
  2369.     (PRINC (STRIPDOLLAR FNNAME))
  2370.     (TERPRI)
  2371.     #+(OR MACLISP FRANZ) (ARGS FNNAME NIL)
  2372.     T)))
  2373.  
  2374. (DEFUN MDEFARRAY (FUN SUBS ARGS BODY MQDEF)
  2375.   (cond ((and  (boundp fun) (hash-table-p fun))
  2376.      (error "~a is already a hash table.  Make it a function first" fun)))
  2377.   
  2378.   (COND ((AND (NULL ARGS) (NOT MQDEF)) (MPUTPROP FUN (MDEFINE1 SUBS BODY) 'AEXPR))
  2379.     ((NULL (DOLIST (U SUBS)
  2380.          (IF (NOT (OR ($CONSTANTP U) (char= (GETCHARN U 1) #\&)))
  2381.              (RETURN T))))
  2382.       (ARRSTORE (CONS (NCONS FUN) SUBS) (MDEFINE1 ARGS BODY)))
  2383.     (T (MDEFCHK FUN SUBS T NIL)
  2384.        (MPUTPROP FUN (MDEFINE1 SUBS (MDEFINE1 ARGS BODY)) 'AEXPR))))
  2385.  
  2386. (DEFMFUN MSPECFUNP (FUN) (AND (OR (GETL-FUN FUN '(FSUBR FEXPR MACRO))
  2387. (GETL FUN '(MFEXPR* MFEXPR*S))      (AND $TRANSRUN (GET FUN
  2388. 'TRANSLATED-MMACRO))      (MGET FUN 'MMACRO)) (NOT (GET FUN 'EVOK))))
  2389.  
  2390. (DEFUN MDEFINE1 (ARGS BODY)
  2391.   (IF FUNDEFSIMP
  2392.       (LET ((SBODY (SIMPLIFY BODY)))
  2393.     (WHEN (AND (NOT (ATOM BODY)) (NOT (ATOM SBODY)))
  2394.           (RPLACA BODY (CAR SBODY)) (RPLACD BODY (CDR SBODY)))))
  2395.   (LIST '(LAMBDA) (CONS '(MLIST) ARGS) BODY))
  2396.  
  2397. (DEFUN MDEFCHK (FUN ARGS ARY MQDEF)
  2398.   (DO ((L ARGS (CDR L)) (MFEX) (MLEX))
  2399.       ((NULL L) (AND MFEX (NOT MQDEF) (MPUTPROP FUN MFEX 'MFEXPRP))
  2400.         (AND MLEX (NOT MQDEF) (MPUTPROP FUN MLEX 'MLEXPRP)))
  2401.     (IF (NOT (OR (MDEFPARAM (CAR L))
  2402.          (AND (OR (NOT ARY) MQDEF)
  2403.               (OR (AND MFEXPRP (MQUOTEP (CAR L))
  2404.                    (MDEFPARAM (CADAR L)) (SETQ MFEX T))
  2405.               (AND (MDEFLISTP L)
  2406.                    (OR (MDEFPARAM (CADAR L))
  2407.                    (AND MFEXPRP (MQUOTEP (CADAR L))
  2408.                     (MDEFPARAM (CADR (CADAR L)))
  2409.                     (SETQ MFEX T)))
  2410.                    (SETQ MLEX T))))))
  2411.     (MERROR "Improper parameter in function definition for ~:M:~%~M"
  2412.         FUN (CAR L)))))
  2413.  
  2414. (DEFUN MDEFPARAM (X)
  2415.   (AND (ATOM X) (NOT (MAXIMA-CONSTANTP X)) (NOT (char= (GETCHARN X 1) #\&))))
  2416.  
  2417. (DEFUN MDEFLISTP (L)
  2418.   (AND (NULL (CDR L)) ($LISTP (CAR L)) (CDAR L) (NULL (CDDAR L))))
  2419.  
  2420. (DEFMFUN MOPP (FUN)
  2421.   (AND (NOT (EQ FUN 'MQAPPLY))
  2422.        (OR (MOPP1 FUN)
  2423.        (AND (GET FUN 'OPERATORS) (NOT (RULECHK FUN))
  2424.         (NOT (MEMQ FUN RULEFCNL)) (NOT (GET FUN 'OPERS))))))
  2425.  
  2426. (DEFMFUN MOPP1 (FUN)
  2427.   (declare (object fun))
  2428.   (AND (SETQ FUN (GET FUN 'OP)) (NOT (MEMQ FUN (CDR $PROPS)))))
  2429.  
  2430. ;; maybe should have a separate version, or a macro..
  2431. (defun mapply (a b c ) (mapply1 a b c nil))
  2432.  
  2433. ;(DEFMFUN $CALL FEXPR (L)
  2434. ;  (IF (NULL L) (MERROR "Wrong number of args to CALL"))
  2435. ;  (MEVAL (CONS (NCONS (CAR L)) (CDR L))))
  2436.  
  2437. ;(DEFMFUN $ACALL FEXPR (L)
  2438. ;  (IF (NULL L) (MERROR "Wrong number of args to ACALL"))
  2439. ;  (MEVAL (CONS (CONS (CAR L) '(ARRAY)) (CDR L))))
  2440.  
  2441. (DEFMSPEC $APPLY (L)
  2442.   (TWOARGCHECK L)
  2443.   (LET ((FUN (MEVAL (CADR L))) (ARG (MEVAL (CADDR L))))
  2444.     (IF (NOT ($LISTP ARG))
  2445.     (MERROR "Attempt to apply ~:M to ~M~
  2446.          ~%Second argument to APPLY must be a list."
  2447.         FUN ARG))
  2448.     (AUTOLDCHK (SETQ FUN (GETOPR FUN)))
  2449.     (MAPPLY1 FUN (CDR ARG) (CADR L) l)))
  2450.  
  2451. (DEFUN AUTOLDCHK (FUN)
  2452.   (IF (AND (SYMBOLP FUN)
  2453.        (GET FUN 'AUTOLOAD)
  2454.        (NOT (OR (FBOUNDP FUN) (MFBOUNDP FUN))))
  2455.       (LOAD-FUNCTION FUN T)))
  2456.  
  2457. (DEFMSPEC $DISPFUN (L) (SETQ L (CDR L))
  2458.  (COND ((OR (CDR L) (NOT (EQ (CAR L) '$ALL))) (DISPFUN1 L NIL NIL))
  2459.        (T (DISPFUN1 (CDR $FUNCTIONS) T NIL)
  2460.       (DISPFUN1 (MAPCAN #'(LAMBDA (X) (IF (MGET X 'AEXPR) (NCONS X)))
  2461.                 (CDR $ARRAYS))
  2462.             NIL T)
  2463.       (DISPFUN1 (CDR $MACROS) T NIL))))
  2464.  
  2465. (DEFUN DISPFUN1 (L FLAG MAEXPRP)
  2466.  (DOLIST (FUN L) ($LDISP (CONSFUNDEF (IF FLAG (CAAR FUN) FUN) MAEXPRP NIL)))
  2467.  '$DONE)
  2468.  
  2469. (DEFMSPEC $FUNDEF (X) (CONSFUNDEF (FEXPRCHECK X) NIL NIL))
  2470.  
  2471. (DEFUN CONSFUNDEF (X MAEXPRP STRINGP)
  2472.  (PROG (ARRYP NAME FUN)
  2473.   (SETQ ARRYP (AND (NOT (ATOM X)) (NOT (EQ (CAAR X) 'MQAPPLY)) (MEMQ 'array (CDAR X))))
  2474.   (COND ((ATOM X) (SETQ NAME ($VERBIFY X)
  2475.             FUN (OR (AND (NOT MAEXPRP) (MGETL NAME '(MEXPR MMACRO)))
  2476.                 (MGETL NAME '(AEXPR)))))
  2477.     (ARRYP (SETQ FUN (MEVAL1 (SETQ NAME (CONS (LIST ($VERBIFY (CAAR X)) 'array) (CDR X)))))
  2478.            (IF (OR (ATOM FUN) (NOT (EQ (CAAR FUN) 'LAMBDA))) (SETQ FUN NIL))))
  2479.   (COND ((NOT FUN) (COND (STRINGP (RETURN X)) ((MEMQ 'EDIT STATE-PDL) (TERPRI)))
  2480.            (MERROR "~:M is not the name of a user function." X))
  2481.     ((AND (NOT ARRYP) (MFILEP (CADR FUN)))
  2482.      (SETQ FUN (LIST (CAR FUN) (DSKGET (CADADR FUN) (CAR (CDDADR FUN)) (CAR FUN) NIL)))))
  2483.   (RETURN
  2484.    (CONS (IF (EQ (CAR FUN) 'MMACRO) '(MDEFMACRO SIMP) '(MDEFINE SIMP))
  2485.      (COND (ARRYP (CONS (CONS '(MQAPPLY) (CONS NAME (CDADR FUN))) (CDDR FUN)))
  2486.            (T (FUNCALL #'(LAMBDA (BODY)
  2487.             (COND ((AND (EQ (CAR FUN) 'AEXPR) (NOT (ATOM BODY))
  2488.                 (EQ (CAAR BODY) 'LAMBDA))
  2489.                (LIST (CONS '(MQAPPLY) (CONS (CONS (CONS NAME '(ARRAY))
  2490.                                   (CDR (CADADR FUN)))
  2491.                             (CDADR BODY)))
  2492.                  (CADDR BODY)))
  2493.               (T (LIST (CONS (CONS NAME (IF (EQ (CAR FUN) 'AEXPR) '(ARRAY)))
  2494.                      (CDR (CADADR FUN)))
  2495.                    BODY))))
  2496.            (CADDR (CADR FUN)))))))))
  2497.  
  2498.  
  2499. (DEFMFUN $FUNMAKE (FUN ARGS)
  2500.   (IF (NOT (OR (SYMBOLP FUN) ($SUBVARP FUN)
  2501.            (AND (NOT (ATOM FUN)) (EQ (CAAR FUN) 'LAMBDA))))
  2502.       (MERROR "Bad first argument to FUNMAKE: ~M" FUN))
  2503.   (IF (NOT ($LISTP ARGS)) (MERROR "Bad second argument to FUNMAKE: ~M" ARGS))
  2504.   (MCONS-OP-ARGS (GETOPR FUN) (CDR ARGS)))
  2505.  
  2506. (DEFMFUN MCONS-OP-ARGS (OP ARGS)
  2507.  (IF (SYMBOLP OP) (CONS (NCONS OP) ARGS) (LIST* '(MQAPPLY) OP ARGS)))
  2508.  
  2509. (DEFMFUN OPTIONP (X)
  2510.  (AND (BOUNDP X) (NOT (MEMQ X (CDR $VALUES))) (NOT (MEMQ X (CDR $LABELS)))))
  2511.  
  2512. (DEFMSPEC MCOND (FORM) (SETQ FORM (CDR FORM))
  2513.  (DO ((U FORM (CDDR U)) (V))
  2514.      ((NULL U) NIL)
  2515.      (COND ((EQ (SETQ V (MEVALP (CAR U))) T) (RETURN (MEVAL (CADR U))))
  2516.        (V (RETURN (LIST* '(MCOND) V (MAPCAR #'MEVAL-ATOMS (CDR U))))))))
  2517.  
  2518. (DEFUN MEVAL-ATOMS (FORM) 
  2519.  (COND ((ATOM FORM) (MEVAL1 FORM))
  2520.        ((EQ (CAAR FORM) 'MQUOTE) (CADR FORM))
  2521.        ((AND (OR (GETL-FUN (CAAR FORM) '(FSUBR FEXPR))
  2522.          (GETL (CAAR FORM) '(MFEXPR* MFEXPR*S)))
  2523.          (NOT (MEMQ (CAAR FORM) '(MCOND MAND MOR MNOT MPROGN MDO MDOIN))))
  2524.     FORM)
  2525.        (T (RECUR-APPLY #'MEVAL-ATOMS FORM))))
  2526.  
  2527. (DEFMSPEC MDO (FORM) (SETQ FORM (CDR FORM))
  2528.  (FUNCALL #'(LAMBDA (MDOP VAR NEXT TEST DO)
  2529.    (SETQ NEXT (OR (CADDDR FORM) (LIST '(MPLUS) (OR (CADDR FORM) 1) VAR))
  2530.      TEST (LIST '(MOR)
  2531.             (COND ((NULL (CAR (CDDDDR FORM))) NIL)
  2532.               (T (LIST (IF (MNEGP ($NUMFACTOR (SIMPLIFY (CADDR FORM))))
  2533.                        '(MLESSP)
  2534.                        '(MGREATERP))
  2535.                    VAR (CAR (CDDDDR FORM)))))
  2536.             (CADR (CDDDDR FORM)))
  2537.      DO (CADDR (CDDDDR FORM)))
  2538.    (MBINDING ((NCONS VAR)
  2539.           (NCONS (IF (NULL (CADR FORM)) 1 (MEVAL (CADR FORM)))))
  2540.          (DO ((VAL) (BINDL BINDLIST))
  2541.          ((IS TEST) '$DONE)
  2542.            (COND ((NULL (SETQ VAL (CATCH 'MPROG (PROG2 (MEVAL DO) NIL))))
  2543.               (MSET VAR (MEVAL NEXT)))
  2544.              ((ATOM VAL) (MERROR "GO not in BLOCK:~%~M" VAL))
  2545.              ((NOT (EQ BINDL BINDLIST))
  2546.               (MERROR "Illegal RETURN:~%~M" (CAR VAL)))
  2547.              (T (RETURN (CAR VAL)))))))
  2548.   T (OR (CAR FORM) 'MDO) NIL NIL NIL))
  2549.  
  2550. (DEFMSPEC MDOIN (FORM) (SETQ FORM (CDR FORM))
  2551.  (FUNCALL #'(LAMBDA  (MDOP VAR SET TEST ACTION)
  2552.    (SETQ SET (IF (ATOM (SETQ SET (FORMAT1 (MEVAL (CADR FORM)))))
  2553.          (MERROR "Atomic 'IN' argument to DO statement:~%~M" SET)
  2554.          (MARGS SET))
  2555.      TEST (LIST '(MOR)
  2556.             (IF (CAR (CDDDDR FORM))
  2557.             (LIST '(MGREATERP) VAR (CAR (CDDDDR FORM))))
  2558.             (CADR (CDDDDR FORM)))
  2559.      ACTION (CADDR (CDDDDR FORM)))
  2560.    (COND ((ATOM SET) '$DONE)
  2561.      (T (MBINDING ((NCONS VAR) (NCONS (CAR SET)))
  2562.               (DO ((VAL) (BINDL BINDLIST))
  2563.               ((OR (ATOM SET) (IS TEST))
  2564.                '$DONE)
  2565.             (COND ((NULL (SETQ VAL (CATCH 'MPROG (PROG2 (MEVAL ACTION) NIL))))
  2566.                    (IF (SETQ SET (CDR SET)) (MSET VAR (CAR SET))))
  2567.                   ((ATOM VAL) (MERROR "GO not in BLOCK:~%~M" VAL))
  2568.                   ((NOT (EQ BINDL BINDLIST))
  2569.                    (MERROR "Illegal RETURN:~%~M" (CAR VAL)))
  2570.                   (T (RETURN (CAR VAL)))))))))
  2571.   T (OR (CAR FORM) 'MDO) NIL NIL NIL))
  2572.  
  2573. (DEFMSPEC MPROG (PROG) (SETQ PROG (CDR PROG))
  2574.  (LET (VARS VALS (MLOCP T))
  2575.       (IF ($LISTP (CAR PROG)) (SETQ VARS (CDAR PROG) PROG (CDR PROG)))
  2576.       (SETQ LOCLIST (CONS NIL LOCLIST))
  2577.       (DO ((L VARS (CDR L))) ((NULL L) (SETQ VALS VARS))
  2578.       (IF (NOT (ATOM (CAR L))) (RETURN (SETQ VALS T))))
  2579.       (IF (EQ VALS T)
  2580.       (SETQ VALS (MAPCAR #'(LAMBDA (V)
  2581.                 (COND ((ATOM V) V)
  2582.                       ((EQ (CAAR V) 'MSETQ) (MEVAL (CADDR V)))
  2583.                       (T (MERROR
  2584.                       "Improper form in BLOCK variable list: ~M"
  2585.                       V))))
  2586.                  VARS)
  2587.         VARS (MAPCAR #'(LAMBDA (V) (IF (ATOM V) V (CADR V))) VARS)))
  2588.       (MBINDING (VARS VALS)
  2589.         (DO ((PROG PROG (CDR PROG)) (MPROGP PROG)
  2590.              (BINDL BINDLIST) (VAL '$DONE) (RETP) (X) ($%% '$%%))
  2591.             ((NULL PROG) (MUNLOCAL) VAL)
  2592.           (COND ((ATOM (CAR PROG))
  2593.              (IF (NULL (CDR PROG))
  2594.                  (SETQ RETP T VAL (MEVAL (CAR PROG)))))
  2595.             ((NULL (SETQ X (CATCH 'MPROG
  2596.                      (PROG2 (SETQ VAL (SETQ $%% (MEVAL (CAR PROG))))
  2597.                         NIL)))))
  2598.             ((NOT (EQ BINDL BINDLIST))
  2599.              (IF (NOT (ATOM X))
  2600.                  (MERROR "Illegal RETURN:~%~M" (CAR X))
  2601.                  (MERROR "Illegal GO:~%~M" X)))
  2602.             ((NOT (ATOM X)) (SETQ RETP T VAL (CAR X)))
  2603.             ((NOT (SETQ PROG (zl-MEMBER X MPROGP)))
  2604.              (MERROR "No such tag as ~:M" X)))
  2605.           (IF RETP (SETQ PROG '(NIL)))))))
  2606.  
  2607. (DEFMFUN MRETURN (X)
  2608.  (IF (AND (NOT MPROGP) (NOT MDOP))
  2609.      (MERROR "RETURN not in BLOCK:~%~M" X))
  2610.  (THROW 'MPROG (NCONS X)))
  2611.  
  2612. (DEFMSPEC MGO (TAG)
  2613.  (SETQ TAG (FEXPRCHECK TAG))
  2614.  (COND ((NOT MPROGP) (MERROR "GO not in BLOCK:~%~M" TAG))
  2615.        ((ATOM TAG) (THROW 'MPROG TAG))
  2616.        (T (MERROR "Argument to GO not atomic:~%~M" TAG))))
  2617.  
  2618. (DEFMSPEC $SUBVAR (L) (SETQ L (CDR L))
  2619.  (IF (NULL L) (WNA-ERR '$SUBVAR)) (MEVAL (CONS '(MQAPPLY ARRAY) L)))
  2620.  
  2621. (DEFMFUN RAT (X Y) `((RAT SIMP) ,X ,Y))
  2622.  
  2623. (DEFMFUN $EXP (X) `((MEXPT) $%E ,X))
  2624.  
  2625. (DEFMFUN $SQRT (X) `((%SQRT) ,X))
  2626.  
  2627.  
  2628. (DEFMFUN ADD2LNC (ITEM LLIST &aux #+lispm  (default-cons-area working-storage-area))
  2629.  (WHEN (NOT (MEMALIKE ITEM (IF ($LISTP LLIST) (CDR LLIST) LLIST)))
  2630.        (IF (NOT (ATOM ITEM)) (zl-DELETE (zl-ASSOC (CAR ITEM) LLIST) LLIST 1))
  2631.        (NCONC LLIST (NCONS ITEM))))
  2632.  
  2633. (DEFMFUN BIGFLOATM* (BF)
  2634.  (IF (NOT (MEMQ 'SIMP (CDAR BF)))
  2635.      (SETQ BF (CONS (LIST* (CAAR BF) 'SIMP (CDAR BF)) (CDR BF))))
  2636.  (IF $FLOAT ($FLOAT BF) BF))
  2637.  
  2638. (DEFMFUN $ALLBUT N (CONS '($ALLBUT) (LISTIFY N)))
  2639.  
  2640. (DEFMFUN MFILEP (X)
  2641.   (AND (NOT (ATOM X)) (NOT (ATOM (CAR X))) (EQ (CAAR X) 'MFILE)))
  2642.  
  2643. #-(or NIL cl)
  2644. (DEFMFUN DSKSETQ FEXPR (L) (LET ((DSKSETP T)) (MSET (CAR L) (EVAL (CADR L)))))
  2645. #+cl
  2646. (defquote DSKSETQ (&rest L) (LET ((DSKSETP T)) (MSET (CAR L) (EVAL (CADR L)))))
  2647.  
  2648. (DEFMFUN DSKRAT (X)
  2649.  (ORDERPOINTER (CADDAR X))
  2650.  (MAPC #'(LAMBDA (A B) (DSKRAT-SUBST A B (CDDDDR (CAR X)))  ; for TAYLOR forms
  2651.                (DSKRAT-SUBST A B (CDR X)))
  2652.        GENVAR (CADDDR (CAR X)))
  2653.  (RPLACA (CDDDAR X) GENVAR)
  2654.  #-(OR CL NIL) (GCTWA) 
  2655.  (IF (MEMQ 'TRUNC (CAR X)) (SRCONVERT X) X))  ; temporary
  2656.  
  2657. (DEFUN DSKRAT-SUBST (X Y Z) 
  2658.  (COND ((ATOM Z) Z)
  2659.        (T (IF (EQ Y (CAR Z)) (RPLACA Z X) (DSKRAT-SUBST X Y (CAR Z)))
  2660.       (DSKRAT-SUBST X Y (CDR Z))
  2661.       Z)))
  2662.  
  2663. (DEFMFUN |''MAKE-FUN| (NOUN-NAME X)
  2664.  (LET (($NUMER T) ($FLOAT T))
  2665.       (SIMPLIFYA (LIST (NCONS NOUN-NAME) (RESIMPLIFY X)) T)))
  2666.  
  2667. (DEFMACRO |''MAKE| (FUN NOUN)
  2668.  `(DEFMFUN ,FUN (X) (|''MAKE-FUN| ',NOUN X)))
  2669.  
  2670. (|''MAKE| $LOG %LOG)
  2671. (|''MAKE| $SIN %SIN) (|''MAKE| $COS %COS) (|''MAKE| $TAN %TAN)
  2672. (|''MAKE| $COT %COT) (|''MAKE| $SEC %SEC) (|''MAKE| $CSC %CSC)
  2673. (|''MAKE| $SINH %SINH) (|''MAKE| $COSH %COSH) (|''MAKE| $TANH %TANH)
  2674. (|''MAKE| $COTH %COTH) (|''MAKE| $SECH %SECH) (|''MAKE| $CSCH %CSCH)
  2675. (|''MAKE| $ASIN %ASIN) (|''MAKE| $ACOS %ACOS) (|''MAKE| $ATAN %ATAN)
  2676. (|''MAKE| $ACOT %ACOT) (|''MAKE| $ASEC %ASEC) (|''MAKE| $ACSC %ACSC)
  2677. (|''MAKE| $ASINH %ASINH) (|''MAKE| $ACOSH %ACOSH) (|''MAKE| $ATANH %ATANH)
  2678. (|''MAKE| $ACOTH %ACOTH) (|''MAKE| $ASECH %ASECH) (|''MAKE| $ACSCH %ACSCH)
  2679. (|''MAKE| $GAMMA %GAMMA) 
  2680.  
  2681. (DEFMFUN $BINOMIAL (X Y)
  2682.  (LET (($NUMER T) ($FLOAT T)) (SIMPLIFY (LIST '(%BINOMIAL) X Y))))
  2683.  
  2684. (PROG1 '(EVFUN properties)
  2685.        (MAPC #'(LAMBDA (X) (PUTPROP X T 'EVFUN))
  2686.          '($RADCAN $FACTOR $RATSIMP $TRIGEXPAND $TRIGREDUCE $LOGCONTRACT
  2687.            $ROOTSCONTRACT $BFLOAT $RATEXPAND $FULLRATSIMP $RECTFORM
  2688.            $POLARFORM)))
  2689.  
  2690. (PROG1 '(EVFLAG properties)
  2691.        (MAPC #'(LAMBDA (X) (PUTPROP X T 'EVFLAG))
  2692.          '($EXPONENTIALIZE $%EMODE $DEMOIVRE $LOGEXPAND $LOGARC $LOGNUMER
  2693.            $RADEXPAND $KEEPFLOAT $LISTARITH $FLOAT $RATSIMPEXPONS $RATMX
  2694.            $SIMP $SIMPSUM $ALGEBRAIC $RATALGDENOM $FACTORFLAG $RATFAC
  2695.            $INFEVAL $%ENUMER $PROGRAMMODE $LOGNEGINT $LOGABS $LETRAT
  2696.            $HALFANGLES $EXPTISOLATE $ISOLATE_WRT_TIMES $SUMEXPAND
  2697.            $CAUCHYSUM $NUMER_PBRANCH $M1PBRANCH $DOTSCRULES
  2698.            $TRIGEXPAND)))
  2699.  
  2700. (MDEFPROP $%E     2.71828182845904523536 $NUMER)  ; (EXP 1) [wrong in ITS-MACLISP]
  2701. (MDEFPROP $%PI    3.14159265358979323846 $NUMER)  ; (ATAN 0 -1)
  2702. (MDEFPROP $%PHI   1.61803398874989484820 $NUMER)  ; (1+sqrt(5))/2
  2703. (MDEFPROP $%GAMMA 0.5772156649015328606  $NUMER)  ; Euler's constant
  2704.  
  2705. (MDEFPROP $HERALD_PACKAGE (NIL $TRANSLOAD T) $PROPS)
  2706. (MDEFPROP $LOAD_PACKAGE (NIL $TRANSLOAD T) $PROPS)
  2707.  
  2708. (DEFPROP BIGFLOAT BIGFLOATM* MFEXPR*)
  2709. (DEFPROP LAMBDA CONSTLAM MFEXPR*)
  2710. (DEFPROP QUOTE CADR MFEXPR*)  ; Needed by MATCOM/MATRUN.
  2711.  
  2712. #-(or cl NIL)
  2713. (EVAL-WHEN (EVAL COMPILE) (SETQ *read-base* OLD-IBASE))
  2714. #+cl
  2715. (EVAL-WHEN (EVAL COMPILE) (SETQ  *read-BASE* OLD-read-base))
  2716.  
  2717. ; Undeclarations for the file:
  2718. (declare-top (NOTYPE N I J NNEED NGIVEN NCELLS NITEMS LISPSUB INDX EVFLG))
  2719.  
  2720.  
  2721.  
  2722.  
  2723.  
  2724.