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
11;;	** (c) Copyright 1982 Massachusetts Institute of Technology **
12
13(macsyma-module mlisp)
14
15(eval-when
16    #+gcl (compile eval)
17    #-gcl (:compile-toplevel :execute)
18
19    (defvar *old-read-base* *read-base*)
20    (setq *read-base* 10.))
21
22(defmvar $mapprint t
23  "If TRUE, messages about map/fullmap truncating on the shortest list
24or if apply is being used are printed.")
25
26(declare-top (special derivflag derivlist $labels $values $functions $arrays
27                      $rules $gradefs $dependencies $aliases
28		      $myoptions $props genvar $maxposex $maxnegex $expop $expon
29		      $numer *mdebug* *refchkl* *baktrcl*
30		      $norepeat $detout $doallmxops $doscmxops opers
31		      *mopl* *alphabet* $%% %e-val
32		      $macros linel $ratfac $ratwtlvl
33		      $partswitch *gcdl*
34		      *builtin-$props* $infolists))
35
36(declare-top (unspecial args))
37
38(defvar mspeclist nil)
39(defvar bindlist nil)
40(defvar loclist nil)
41(defvar mproplist nil)
42(defvar *nounl* nil)
43(defvar scanmapp nil)
44(defvar maplp nil)
45(defvar mprogp nil)
46(defvar evp nil)
47(defvar mdop nil)
48(defvar mlocp nil)
49(defvar aexprp nil)
50(defvar fmaplvl 0)
51(defvar dsksetp nil)
52(defvar aryp nil)
53(defvar msump nil)
54(defvar evarrp nil)
55(defvar factlist nil)
56(defvar mfexprp t)
57(defvar *nounsflag* nil)
58(defvar transp nil)
59(defvar noevalargs nil)
60(defvar rulefcnl nil)
61(defvar featurel
62  '($integer $noninteger $even $odd $rational $irrational $real $imaginary $complex
63    $analytic $increasing $decreasing $oddfun $evenfun $posfun $constant
64    $commutative $lassociative $rassociative $symmetric $antisymmetric
65    $integervalued))
66
67(defmvar $features (cons '(mlist simp) (append featurel nil)))
68(defmvar $%enumer nil)
69(defmvar $float nil)
70(defmvar $refcheck nil)
71(defmvar $translate nil)
72(defmvar $transrun t)
73(defmvar $savedef t)
74(defmvar $maperror t)
75(defmvar $optionset nil)
76(defmvar $setcheckbreak nil)
77(defmvar $infeval nil)
78(defmvar $piece '$piece)
79(defmvar $setval '$setval)
80
81;; These three variables are what get stuck in array slots as magic
82;; unbound objects.  They are for T, FIXNUM, and FLONUM type arrays
83;; respectively.
84
85(defvar munbound '|#####|)
86
87(defvar fixunbound most-negative-fixnum)
88
89(defvar flounbound most-negative-flonum)
90
91(defmvar munbindp nil
92  "Used for safely `munbind'ing incorrectly-bound variables."
93  no-reset)
94
95(defmvar $setcheck nil)
96
97(mapc #'(lambda (x) (setf (symbol-value x) (ncons '(mlist simp))))
98      '($values $functions $macros $arrays $myoptions $rules $props))
99
100(defun mapply1 (fn args fnname form)
101  (declare (special aryp))
102  (cond ((atom fn)
103	 (cond ((functionp fn)
104		(apply fn args))
105	       ((and (symbolp fn) (fboundp fn) (not (macro-function fn)))
106		(mapply1 (symbol-function fn) args fn form))
107	       ((and (symbolp fn) (symbol-array fn))
108		(mapply1 (symbol-array fn) args fn form))
109	       (t
110		(setq fn (getopr fn))
111		(badfunchk fnname fn nil)
112		(let ((noevalargs t))
113		  (meval (cons (ncons fn) args))))))
114
115	;; GCL considers interpreted functions and lambdas to be non-atoms
116	#+gcl((functionp fn)
117	 (apply fn args))
118
119	;; extension for pdiff; additional extension are welcomed.
120        ;; (AND (CONSP FN) (CONSP (CAR FN)) ...) is an attempt to identify
121        ;; conventional Maxima expressions ((FOO) X Y Z); probably should
122        ;; encapsulate somewhere, maybe it is already ??
123	((and (consp fn) (consp (car fn)) (symbolp (mop fn)) (get (mop fn) 'mapply1-extension)
124	      (apply (get (mop fn) 'mapply1-extension) (list fn args fnname form))))
125	((eq (car fn) 'lambda)
126	 (apply (coerce fn 'function) args))
127	((eq (caar fn) 'lambda) (mlambda fn args fnname t form))
128	((eq (caar fn) 'mquote) (cons (append (cdr fn) aryp) args))
129	((and aryp (member (caar fn) '(mlist $matrix) :test #'eq))
130	 (if (not (or (= (length args) 1)
131		      (and (eq (caar fn) '$matrix) (= (length args) 2))))
132	     (merror (intl:gettext "apply: wrong number of indices; found: ~M") (cons '(mlist) args)))
133	 (if (member 0 args)
134	     (merror (intl:gettext "apply: no such ~M element: ~M") (if (eq (caar fn) 'mlist) (intl:gettext "list") (intl:gettext "matrix"))
135		     `((mlist) ,@args)))
136	 (do ((args1 args (cdr args1)))
137	     ((null args1) (let (($piece $piece) ($partswitch 'mapply))
138			     (apply #'$inpart (cons fn args))))
139	   (unless (fixnump (car args1))
140	     (if evarrp (throw 'evarrp 'notexist))
141	     (merror (intl:gettext "apply: subscript must be an integer; found: ~M") (car args1)))))
142	(aryp
143	 (cons '(mqapply array) (cons fn args)))
144	(t
145	 (cons '(mqapply) (cons fn args)))))
146
147;; the last argument to mapply1 for the lineinfo is not correct here..
148(defun mcall (fn &rest args)
149  (mapply1 fn args fn nil))
150
151(defun mevalargs (args)
152  (cond (noevalargs (setq noevalargs nil) args)
153	(t (mapcar #'meval args))))
154
155;;Function Call stack each element is
156;; (fname . bindlist) where bindlist was the value at time of entry.
157;; So you can use this to compute what the bindings were at any
158;; function call.
159(defvar *mlambda-call-stack* (make-array 30 :fill-pointer 0 :adjustable t ))
160
161;;; The frame info for a function call consists of 5 consecutive
162;;; entries in *MLAMBDA-CALL-STACK*.  I call the topmost object of
163;;; such a quintuple the `function designator' belonging to this
164;;; frame.
165
166(defun pop-mlambda-call-stack (&optional fnname)
167  "Deactivate the topmost function call frame info.
168Return the function designator for this frame and check that it
169is EQ to FNNAME if the latter is non-NIL."
170  (let ((ar *mlambda-call-stack*) mlambda)
171    (symbol-macrolet ((mlambda-pointer (fill-pointer ar)))
172      (prog1
173	  (setq mlambda (aref ar (1- mlambda-pointer)))
174	(when fnname
175	  ;; Different frames can have the same function designator,
176	  ;; so this doesn't prove anything, it's just a check.
177	  (assert (eq mlambda fnname)
178		  (*mlambda-call-stack*)
179		  "Expected ~a but got ~a on mlambda call stack."
180		  fnname mlambda))
181	(decf mlambda-pointer 5)))))
182
183(defun mlambda (fn args fnname noeval form)
184  ; We assume that the lambda expression handed to us has been simplified,
185  ; or at least that it's well-formed.  This is because various checks are
186  ; performed during simplification instead of every time lambda expressions
187  ; are applied to arguments.
188  (setq noevalargs nil)
189  (let ((params  (cdadr fn))( mlocp  t))
190    (setq loclist (cons nil loclist))
191    (do ((a) (p))
192	((or (null params) (and (null args) (not (mdeflistp params))))
193	 (setq args (nreconc a args) params (nreconc p params)))
194      (cond ((mdeflistp params)
195	     (setq params (cdar params) args (ncons (cons '(mlist) args)))))
196      (cond ((and mfexprp (mquotep (car params)))
197	     (setq a (cons (car args) a) p (cons (cadar params) p)))
198	    ((atom (car params))
199	     (setq p (cons (car params) p)
200		   a (cons (cond (noeval (car args))
201				 (t (meval (car args)))) a)))
202	    (t (merror (intl:gettext "lambda: formal argument must be a symbol or quoted symbol; found: ~M") (car params))))
203      (setq args (cdr args) params (cdr params)))
204    (let (finish2033 (finish2032 params) (ar *mlambda-call-stack*))
205      (declare (type (vector t) ar))
206      (unwind-protect
207	   (progn
208	     (unless (> (array-total-size ar) (+ (fill-pointer ar) 10))
209	       (setq ar (adjust-array ar (+ (array-total-size ar) 50)	:fill-pointer (fill-pointer ar))))
210	     (vector-push bindlist ar)
211	     ;; rather than pushing all on *baktrcl* it might be good
212	     ;; to make a *last-form* global that is set in meval1
213	     ;; and is pushed here.
214	     (vector-push form ar)
215	     (vector-push params ar)
216	     (vector-push args ar)
217	     (vector-push fnname ar)
218	     (mbind finish2032 args fnname)
219	     (setq finish2033 t)
220	     (let ((aexprp (and aexprp (not (atom (caddr fn)))
221				(eq (caar (caddr fn)) 'lambda))))
222	       (cond ((null (cddr fn)) (merror (intl:gettext "lambda: no body present.")))
223		     ((cdddr fn) (mevaln (cddr fn)))
224		     (t (meval (caddr fn))))))
225	(if finish2033
226	    (progn
227	      (incf (fill-pointer *mlambda-call-stack*) -5)
228	      (munlocal)
229	      (munbind finish2032)))))))
230
231
232(defmspec mprogn (form)
233  (mevaln (cdr form)))
234
235(defun mevaln (l) ;; called in a few places externally.
236  (do ((body l (cdr body))
237       ($%% '$%%))
238      ((null (cdr body)) (meval (car body)))
239    (setq $%% (meval (car body)))))
240
241(defun mqapply1 (form)
242  (declare (special aryp))
243  (destructuring-let (((fn . argl) (cdr form)) (aexprp))
244    (unless (mquotep fn) (setq fn (meval fn)))
245    (cond ((atom fn)
246	   (meval (cons (cons (amperchk fn) aryp) argl)))
247	  ((eq (caar fn) 'lambda)
248	   (if aryp
249	       (merror (intl:gettext "lambda: cannot apply lambda as an array function."))
250	       (mlambda fn argl (cadr form) noevalargs form)))
251	  (t
252	   (mapply1 fn (mevalargs argl) (cadr form) form)))))
253
254(defun meval (form)
255  (simplifya (meval1 form) nil))
256
257;;temporary hack to see what's going on:
258(defun safe-mgetl (atom inds)
259  (and (symbolp atom)
260       (let ((props (get atom 'mprops)))
261	 (and props (getl props inds)))))
262
263(defun safe-mget (atom inds)
264  (and (symbolp atom)
265       (let ((props (get atom 'mprops)))
266	 (and props (getf (cdr props) inds)))))
267
268(defvar *last-meval1-form* nil)
269
270(defun meval1 (form)
271  (declare (special *nounl* *break-points* *break-step*))
272  (cond
273    ((atom form)
274     (prog (val)
275       (cond ((not (symbolp form)) (return form))
276             ((and $numer
277                   (setq val (safe-mget form '$numer))
278                   (or (not (eq form '$%e)) $%enumer))
279              (return (meval1 val)))
280             ((not (boundp form))
281              (if (safe-get form 'bindtest)
282                  (merror (intl:gettext "evaluation: unbound variable ~:M")
283                          form)
284                  (return form))))
285       (setq val (symbol-value form))
286       (when (and $refcheck
287                  (member form (cdr $values) :test #'eq)
288                  (not (member form *refchkl* :test #'eq)))
289         (setq *refchkl* (cons form *refchkl*))
290         (mtell (intl:gettext "evaluation: ~:M has the value ~:M.~%") form val))
291       (return val)))
292    ((or (and (atom (car form))
293              (setq form (cons (ncons (car form)) (cdr form))))
294         (atom (caar form)))
295     (let ((*baktrcl* *baktrcl*) transp)
296       (prog (u aryp)
297         (declare (special aryp))
298         (setq *last-meval1-form* form)
299         (setq aryp (member 'array (cdar form) :test #'eq))
300         (cond ((and (not aryp)
301                     (member (caar form)
302                             '(mplus mtimes mexpt mnctimes) :test #'eq))
303                (go c))
304               ;; don't bother pushing mplus and friends on *baktrcl*
305               ;; should maybe even go below aryp.
306               ((and *mdebug*
307                     (progn
308                       ;; if wanting to step, the *break-points*
309                       ;; variable will be set to a vector (possibly empty).
310                       (when (and *break-points*
311                                  (or (null  *break-step*)
312                                      (null (funcall *break-step* form))))
313                         (let ((ar *break-points*))
314                           (declare (type (vector t) ar))
315                           (loop for i below (fill-pointer ar)
316                                 when (eq (car (aref ar i)) form)
317                                 do (*break-points* form)
318                                 (loop-finish))))
319                       nil)))
320               ((eq (caar form) 'mqapply) (return (mqapply1 form))))
321         (badfunchk (caar form) (caar form) nil)
322       a
323         (setq u
324               (or (safe-getl (caar form) '(noun))
325                   (and *nounsflag*
326                        (and (symbolp (caar form)) (char= (get-first-char (caar form)) #\%))
327                        (not (or (getl-lm-fcn-prop (caar form) '(subr))
328                              (safe-getl (caar form) '(mfexpr*))))
329                        (prog2 ($verbify (caar form))
330                               (safe-getl (caar form) '(noun))))
331                   (and (not aryp)
332                        $transrun
333                        (setq transp
334                              (safe-getl (caar form) '(translated-mmacro))))
335                   (and (not aryp)
336                        (setq u
337                              (or (safe-mget (caar form) 'trace)
338                                  (and $transrun
339                                       (safe-get (caar form) 'translated)
340                                       (not (safe-mget (caar form) 'local-fun))
341                                       (setq transp t)
342                                       (caar form))))
343                        (getl-lm-fcn-prop u '(subr mfexpr)))
344                   (cond (aryp (safe-mgetl (caar form) '(hashar array)))
345                         ((safe-mgetl (caar form) '(mexpr mmacro)))
346                         (t
347                          (or (safe-getl (caar form) '(mfexpr*))
348                              (getl-lm-fcn-prop (caar form) '(subr macro)))))))
349         (when (null u) (go b))
350         (return
351           (cond ((eq (car u) 'hashar)
352                  (harrfind (cons (car form) (mevalargs (cdr form)))))
353                 ((eq (car u) 'subr)
354                  (apply (caar form) (mevalargs (cdr form))))
355                 ((eq (car u) 'noun)
356                  (cond ((or (member (caar form) *nounl* :test #'eq) *nounsflag*)
357                         (setq form (cons (cons (cadr u) (cdar form))
358                                          (cdr form)))
359                         (go a))
360                        (aryp (go b))
361                        ((member (caar form) '(%sum %product) :test #'eq)
362                         (setq u (do%sum (cdr form) (caar form))
363                               noevalargs nil)
364                         (cons (ncons (caar form)) u))
365                        (t (meval2 (mevalargs (cdr form)) form))))
366                 ((eq (car u) 'array)
367                  (arrfind (cons (car form) (mevalargs (cdr form)))))
368                 ((eq (car u) 'mexpr)
369                  (mlambda (cadr u) (cdr form) (caar form) noevalargs form))
370                 ((member (car u) '(mmacro translated-mmacro) :test #'eq)
371                  (setq noevalargs nil)
372                  (meval (mmacro-apply (cadr u) form)))
373                 ((eq (car u) 'mfexpr*)
374                  (setq noevalargs nil)
375                  (apply (cadr u) (ncons form)))
376                 ((eq (car u) 'mfexpr)
377                  (mlambda (cadr u) (cdr form) (caar form) noevalargs form))
378                 ((eq (car u) 'macro)
379                  (setq noevalargs nil)
380                  (setq form (cons(caar form) (cdr form)))
381                  (eval form))
382                 (t
383                  (apply (cadr u) (mevalargs (cdr form))))))
384       b
385         (if (and (not aryp) (load-function (caar form) t)) (go a))
386         (badfunchk (caar form) (caar form) nil)
387         (if (symbolp (caar form))
388             (setq u (boundp (caar form)))
389             (return (meval1-extend form)))
390       c
391         (cond ((or (null u)
392                    (and (safe-get (caar form) 'operators) (not aryp))
393                    (eq (caar form) (setq u (symbol-value (caar form)))))
394                (setq form (meval2 (mevalargs (cdr form)) form))
395                (return (or (and (safe-mget (caar form) 'atvalues)
396                                 (at1 form))
397                            form)))
398               ((and aryp
399                     (safe-get (caar form) 'nonarray))
400                (return (cons (cons (caar form) aryp)
401                              (mevalargs (cdr form)))))
402               ((atom u)
403                (badfunchk (caar form) u nil)
404                (setq form (cons (cons (getopr u) aryp) (cdr form)))
405                (go a))
406               ((eq (caar u) 'lambda)
407                (if aryp
408                    (merror (intl:gettext "lambda: cannot apply lambda as an array function."))
409                    (return (mlambda u (cdr form)
410                                       (caar form) noevalargs form))))
411               (t
412                (return
413                  (mapply1 u (mevalargs (cdr form)) (caar form) form)))))))
414    (t
415     (mapply1 (caar form) (mevalargs (cdr form)) (caar form) form))))
416
417(defun getl-lm-fcn-prop (sym props &aux fn typ)
418  (setq fn sym)
419  (cond ((functionp fn)
420	 (setq typ 'subr))
421	((not (symbolp sym))) ;; eventually return nil if not a symbol
422	((macro-function sym)
423	 (setq typ 'macro))
424	((setq fn (symbol-array sym))
425	 (setq typ 'array))
426	((setq fn (get sym 'mfexpr*))
427	 (setq typ 'mfexpr*))
428	((setq fn (get sym 'mfexpr))
429	 (setq typ 'mfexpr)))
430  (and typ (member typ props :test #'eq) (list typ fn)))
431
432
433(defun meval2 (newargs old)
434  (declare (special aryp))
435  (let ((new (cons (car old) newargs)) nosimp)
436    (cond ((not (member 'simp (cdar old) :test #'eq))
437	   (if (and (not (eq (caar new) 'mlist)) (equal new old)) old new))
438	  ((prog2 (setq nosimp (not (get (caar new) 'operators))) (alike1 new old))
439	   (if nosimp old (cons (delsimp (car old)) (cdr old))))
440	  (nosimp (if aryp new (cons (cons (caar new) '(simp)) newargs)))
441	  (t (cons (cons (caar new) aryp) newargs)))))
442
443(defun mparam (var)
444  (cond ((atom var)
445         var)
446        ((atom (cadr var))
447         (cadr var))
448        (t
449         (cadadr var))))
450
451(defun mparams (vars)
452  (mapcar #'mparam (cdr vars)))
453
454(defun mop (form)
455  (if (eq (caar form) 'mqapply)
456      (cadr form)
457      (caar form)))
458
459(defun margs (form)
460  (if (eq (caar form) 'mqapply)
461      (cddr form)
462      (cdr form)))
463
464(defun badfunchk (name val flag)
465  (declare (special aryp))
466  (if (or flag (numberp val) (member val '(t nil $%e $%pi $%i) :test #'eq))
467      (let ((type (if aryp (intl:gettext "an array") (intl:gettext "a function"))))
468        (if (and (atom name) (not (equal val name)))
469            (merror (intl:gettext "apply: found ~M evaluates to ~M where ~A was expected.") name val type)
470            (merror (intl:gettext "apply: found ~M where ~A was expected.") val type)))))
471
472;; To store the value of $errormsg in mbind. This value is looked up in the
473;; routine mbind-doit. This is a hack to get the expected behavior, when the
474;; option variable $errormsg is used as a local variable in a block.
475(defvar *$errormsg-value* nil)
476
477(defun mbind-doit (lamvars fnargs fnname)
478  "Makes a new frame where the variables in the list LAMVARS are bound
479to the corresponding elements in FNARGS.  Note that these elements are
480used tels quels, without calling MEVAL.
481If FNNAME is non-NIL, it designates a function call frame.
482This function does not handle errors properly, use the MBIND
483wrapper for this."
484  (declare (special bindlist mspeclist))
485  (do ((vars lamvars (cdr vars))
486       (args fnargs (cdr args)))
487      ((cond ((and vars args) nil)
488	     ((and (null vars) (null args)))
489	     (t (assert fnname (fnname)
490			"Expected a maxima function designator but got NIL.")
491		(merror (intl:gettext "~A arguments supplied to ~M; found: ~M")
492			(if vars (intl:gettext "Too few") (intl:gettext "Too many"))
493			(if (and (consp fnname)
494				 (consp (car fnname))
495				 (eq (caar fnname) 'lambda))
496			    fnname
497			    (cons (ncons fnname) lamvars))
498			(cons '(mlist) fnargs)))))
499    (let ((var (car vars)))
500      (if (not (symbolp var))
501	  (merror (intl:gettext "Only symbols can be bound; found: ~M") var))
502      (let ((value (if (boundp var)
503                       (if (eq var '$errormsg)
504                           ;; Do not take the actual value of $errormsg. It is
505                           ;; always NIL at this point, but the value which
506                           ;; is stored in *$errormsg-value*.
507                           *$errormsg-value*
508                           (symbol-value var))
509                       munbound)))
510	(mset var (car args))
511	(psetq bindlist (cons var bindlist)
512	       mspeclist (cons value mspeclist))))))
513
514(defun mbind (lamvars fnargs fnname)
515  "Error-handling wrapper around MBIND-DOIT."
516  (handler-case
517      (let ((old-bindlist bindlist) win)
518	(declare (special bindlist))
519        ;; At this point store the value of $errormsg in a global. The macro
520        ;; with-$error sets the value of $errormsg to NIL, but we need the
521        ;; actual value in the routine mbind-doit.
522        (setq *$errormsg-value* $errormsg)
523	(unwind-protect
524	     (prog1
525		 (with-$error (mbind-doit lamvars fnargs fnname))
526	       (setq win t))
527	  (unless win
528	    (unless (eq bindlist old-bindlist)
529	      (munbind (nreverse (ldiff bindlist old-bindlist))))
530	    (when fnname
531	      (pop-mlambda-call-stack fnname)))))
532    (maxima-$error (c)
533      ;; HMM, HERE'S A CALL TO MERROR. I CAN'T TELL WHERE ARE THE ERROR MESSAGES.
534      ;; IF I DID, I'D WRAP THEM IN A CALL TO GETTEXT
535      (apply #'merror (cdr (the-$error c)))
536      ;; Make absolutely sure that this handler (and mbind) doesn't
537      ;; return in this situation since other code depends on this
538      ;; behaviour.
539      (throw 'macsyma-quit t))))
540
541;;; For testing purposes
542
543#+ignore
544(defmfun $show_mbind_data ()
545  (format t "~&~{~a = ~a~%~}"
546	  (mapcan #'(lambda (x) (list x (symbol-value x)))
547		  '(bindlist mspeclist $values *mlambda-call-stack*)))
548  (finish-output)
549  (values))
550
551(defun munbind (vars)
552  (dolist (var (reverse vars))
553    (cond ((eq (car mspeclist) munbound)
554	   (makunbound var)
555	   (setf $values (delete var $values :count 1 :test #'eq)))
556	  (t (let ((munbindp t)) (mset var (car mspeclist)))))
557    (setq mspeclist (cdr mspeclist) bindlist (cdr bindlist))))
558
559;;This takes the place of something like
560;; (DELETE (ASSOC (NCONS VAR) $DEPENDENCIES) $DEPENDENCIES 1)
561
562(defun mfunction-delete (var fn-a-list)
563  (delete (assoc (ncons var) fn-a-list :test #'equal) fn-a-list :count 1 :test #'equal))
564
565(defmspec mlocal (l)
566  (push nil loclist)
567  (let ((mlocp t))
568    (meval `(($local) ,@(cdr l)))))
569
570(defmspec $local (l)
571  (setq l (cdr l))
572  (unless mlocp
573    (merror (intl:gettext "local: must be called within a block or lambda.")))
574  (dolist (var l)
575    (cond ((not (symbolp var))
576	   (improper-arg-err var '$local))
577	  ((and (mget var 'array)
578		(arrayp (symbol-array var)))
579       ;; HMM. I DON'T UNDERSTAND WHY DECLARED ARRAYS ARE OFF-LIMITS:
580       ;; THE ARRAY IS JUST A PROPERTY LIKE ANY OTHER, IS IT NOT ??
581       (merror (intl:gettext "local: argument cannot be a declared array; found: ~M") var)))
582    (setq mproplist (cons (get var 'mprops) mproplist)
583	  factlist (cons (get var 'data) factlist))
584    (dolist (fact (car factlist))
585      (putprop fact -1 'ulabs))
586    (progn
587      (mfunction-delete var $functions)
588      (mfunction-delete var $macros)
589      (mfunction-delete var $dependencies))
590    (setf $arrays (delete var $arrays :count 1 :test #'eq))
591    (zl-remprop var 'mprops)
592    (zl-remprop var 'data))
593  (rplaca loclist (reverse l))
594  (setq mlocp nil)
595  '$done)
596
597(defun munlocal ()
598  (dolist (var (car loclist))
599    (let ((mprop (car mproplist))
600	  (y nil)
601	  (fact (car factlist)))
602      (remcompary var)
603      (cput var mprop 'mprops)
604      (cond ((setq y (old-get mprop 'mexpr))
605	     (add2lnc (cons (ncons var) (cdadr y)) $functions))
606	    (t (mfunction-delete var $functions)))
607      (cond ((setq y (old-get mprop 'mmacro))
608	     (add2lnc (cons (ncons var) (cdadr y)) $macros))
609	    (t (mfunction-delete var $macros)))
610      (cond ((or (old-get mprop 'array) (old-get mprop 'hashar))
611	     (add2lnc var $arrays))
612	    (t (setf $arrays (delete var $arrays :count 1 :test #'eq))))
613      (cond ((setq y (old-get mprop 'depends))
614	     (add2lnc (cons (ncons var) y) $dependencies))
615	    (t (mfunction-delete var $dependencies)))
616      (rempropchk var)
617      (mapc #'remov (get var 'data))
618      (cput var fact 'data)
619      (dolist (u fact)
620	(zl-remprop u 'ulabs))
621      (setq mproplist (cdr mproplist)
622	    factlist (cdr factlist))))
623  (setq loclist (cdr loclist)))
624
625(defmacro msetq (a b)
626  `(mset ',a ,b))
627
628;; A "run-time macro" needed by MATCOM/MATRUN.
629;;works with the defms
630(defmspec msetq (l)
631  (twoargcheck l)
632  (mset (simplifya (cadr l) nil) (meval (caddr l))))
633
634(defun mset (x y)
635  (prog ()
636     (cond ((or (null $setcheck)
637		(eq $setcheck '$setcheck)))
638	   ((and (or (atom $setcheck)
639		     (memalike x (cdr $setcheck))
640		     (and (not (atom x))
641			  (memalike (caar x) (cdr $setcheck))))
642		 (not (eq x y)))
643	    (mtell (intl:gettext "~:M is being set to ~:M.~%") x y)
644	    (if (and $setcheckbreak (not (eq x '$setval)))
645		(let (($setval y))
646		  (merrbreak t)
647		  (setq y $setval)))))
648     (cond ((atom x)
649	    (when (or (not (symbolp x))
650		      (member x '(t nil) :test #'eq)
651                      (mget x '$numer)
652                      (get x 'sysconst))
653	      (if munbindp (return nil))
654	      (if (mget x '$numer)
655		  (merror (intl:gettext "assignment: cannot assign to ~M; it is a declared numeric quantity.") x)
656		  (merror (intl:gettext "assignment: cannot assign to ~M") x)))
657	    (let ((f (get x 'assign)))
658	      (if (and f (or (not (eq x y))
659			     (member f '(neverset read-only-assign) :test #'eq)))
660		  (if (eq (funcall f x y) 'munbindp) (return nil))))
661	    (cond ((and (not (boundp x))
662			(not dsksetp))
663		   (add2lnc x $values))
664		  ((and (not (eq x y))
665			(optionp x))
666		   (if $optionset (mtell (intl:gettext "assignment: assigning to option ~M") x))
667		   (if (not (eq x '$linenum)) (add2lnc x $myoptions))))
668	    (return (setf (symbol-value x) y)))
669
670           ;; ---------- begin code copied & modified from defstruct.lisp
671
672           ;; Check to see if the operator has an mset_extension_operator.
673           ;; If so, this says how to do assignments. Examples, a@b:x. Put mset_extension_operator
674           ;; of mrecord-assign on the atom $@.  To allow [a,b]:[3,4] put op on mlist.
675           ;; arguably we could use mget, mfuncall, and $mset_extension_operator  and
676           ;; allow this to be done at the maxima level instead of lisp.
677
678           ;; X is could be something like (($FOO ARRAY) 42), in which case it is meaningful
679           ;; to look for an assignment operator associated either with $FOO itself or with
680           ;; $FOO's object type, with "object type" = (CAAR (SYMBOL-VALUE '$FOO)).
681
682           ((let*
683              ((x-value (if (boundp (caar x)) (symbol-value (caar x))))
684               (mset-extension-op
685                 (cond
686                   ((get (caar x) 'mset_extension_operator))
687                   ((and
688                      (not (atom x-value))
689                      (get (caar x-value) 'defstruct-template)
690                      (get (caar x-value) 'mset_extension_operator))))))
691              (if mset-extension-op
692                (return-from mset (funcall mset-extension-op x y)))))
693
694           ;; ---------- end code copied & modified from defstruct.lisp
695
696	   ((member 'array (cdar x) :test #'eq)
697	    (return (arrstore x y)))
698	   (t (merror (intl:gettext "assignment: cannot assign to ~M") x)))))
699
700;; ---------- begin code copied & modified from defstruct.lisp
701
702;; CHANGES WRT FATEMAN'S STUFF.
703;; (1) $NEW BARFS IF #ARGUMENTS != 1, OR ARGUMENT HAS NO DEFSTRUCT, OR WRONG NUMBER OF INITIALIZERS.
704;; (2) $DEFSTRUCT ALLOWS 1 OR MORE ARGUMENTS, RETURNS A LIST OF DEFSTRUCTS.
705;; (3) USE $PUT AND $GET TO MAINTAIN DEFSTRUCT PROPERTIES
706;;     (RENAMED TO $DEFSTRUCT_DEFAULT AND $DEFSTRUCT_TEMPLATE).
707;;     THIS MAKES DEFSTRUCT PROPERTIES VISIBLE TO USER VIA GET AND PROPVARS.
708;;     ALSO, THIS MAKES `KILL' KILL DEFSTRUCTS.
709;; (4) @ EVALUATES LHS AND QUOTES RHS
710;; (5) $STRUCTURES INFOLIST
711;; (6) LBP = 200, RBP = 201 (HIGHER PRECEDENCE, LEFT-ASSOCIATIVE)
712;; (7) A@B => A@B WHEN B IS NOT BOUND TO SOMETHING OTHER THAN ITSELF
713;; (8) DISALLOW @ APPLIED TO EXPRESSIONS W/ OPERATOR NOT DECLARED BY DEFSTRUCT
714;; (9) MAKE RECORD AND LIST ASSIGNMENT FUNCTIONS LISP FUNCTIONS (STRIP OFF $ FROM NAME)
715;;     ALSO MAKE PROPERTY SYMBOLS LISP SYMBOLS (STRIP OFF $ FROM NAME)
716;; (10) EXTEND KILL TO TAKE ITEMS OFF $STRUCTURES AND REMOVE DEFSTRUCT PROPERTIES
717;; (11) EXTEND KILL TO RECOGNIZE KILL(X@Y)
718;; (12) EVALUATE INITIALIZERS IN $DEFSTRUCT AND IN $NEW
719;; (13) DISPLAY FIELDS WHICH HAVE BEEN ASSIGNED VALUES AS FOO(X = BAR, Y = BAZ)
720;; (14) ASSIGN TRANSLATION PROPERTY TO 'DEFSTRUCT AND DEF-SAME%TR ALL STRUCTURES
721
722(setf (get '$@ 'mset_extension_operator) 'mrecord-assign)
723
724;;  defstruct(f(x,y,z));
725;;  myrecord: new(f);
726;;  myrecord@y:45;
727;;  myrecord;  ==>   f(x,45,z)
728
729;; initializers are possible
730;; defstruct(f(x,y=3.14159, z));
731;; ff:new(f)  ==>   f(x,3.14159,z)
732;; ff@y:2.71828 ==>  ff is  f(x,2.71828,z).
733
734;; the @ syntax can also be used instead of substinpart.
735
736;; k:  h(g(aa,bb),cc);
737;; k@1@2:dd; change aa to dd.
738;; k;
739
740(defun mrecord-assign (@-expr value)
741  ;; assume @-expr is  (($@..)  instance-name  field-name)
742  (let*
743    ((instance (cadr @-expr))
744	 (field (caddr @-expr))
745	 (object (meval instance))
746     template)
747    (if (not (and (consp object) (consp (car object)) (setq template (get (caar object) 'defstruct-template))))
748      (merror "MRECORD-ASSIGN: left-hand side doesn't appear to be a defstruct object:~%~M" instance)
749      (let
750        ((index
751           (if (integerp field)
752             field ;;; allow foo@3, also
753             (position field template)))) ;field->integer
754        (if (null index) (merror (intl:gettext "assignment: no such field: ~M @ ~M") instance field))
755        (if (< 0 index (length object)) (setf (elt object index) value)
756          (merror (intl:gettext "assignment: no such field: ~M @ ~M") instance field))
757        value))))
758
759;; MRECORD-KILL is very similar to MRECORD-ASSIGN. Might consider merging the two somehow.
760
761(defun mrecord-kill (@-expr)
762  (let*
763    ((instance (cadr @-expr))
764     (field (caddr @-expr))
765     (object (meval instance))
766     template)
767    (if (not (and (consp object) (consp (car object)) (setq template (get (caar object) 'defstruct-template))))
768      (merror "MRECORD-KILL: left-hand side doesn't appear to be a defstruct object:~%~M" instance)
769      (let
770        ((index
771           (if (integerp field)
772             field
773             (position field template))))
774        (if (null index) (merror (intl:gettext "kill: no such field: ~M @ ~M") instance field))
775        (if (< 0 index (length object)) (setf (elt object index) (elt template index))
776          (merror (intl:gettext "kill: no such field: ~M @ ~M") instance field))))))
777
778(defmspec $@ (L)
779  (let*
780    ((a (cadr L))
781     (b (caddr L))
782     (e ($@-function (meval a) b)))
783    (if (eq e b) L e)))
784
785(defmfun $@-function (in fn)
786  (cond
787    ((not (listp in))
788     (list '(%@) in fn)) ;; noun form
789    ((get (caar in) 'defstruct-template)
790     (let*
791       ((index
792         (if (integerp fn) fn ;; allow foo@3
793             (position fn (get (caar in) 'defstruct-template))))) ;; field->integer
794       (if (null index) (merror (intl:gettext "@: no such field: ~M @ ~M") in fn))
795       (if  (< 0 index (length in))
796         (elt in index)
797         (merror (intl:gettext "@: no such field: ~M @ ~M") in fn))))
798    (t
799      (list '($@) in fn))))
800
801(defun dimension-defstruct (form result)
802  (let
803    ((L1 (cdr (get (caar form) 'defstruct-template)))
804     (L2 (cdr form)))
805    (dimension-function (cons (car form) (mapcar #'(lambda (e1 e2) (if (eq e1 e2) e1 `((mequal) ,e1 ,e2))) L1 L2)) result)))
806
807;; L looks like defstruct (foo(...), bar(...), baz(...)).
808;; Process each argument and return a list of declared structures.
809
810(defmspec $defstruct (L)
811  `((mlist) ,@(mapcar 'defstruct1 (cdr L))))
812
813;; trivial translation to quiet complaint about lack of translation for this defmspec
814(def%tr $defstruct (x) `($any . (meval ',x)))
815
816(defvar $structures '((mlist)))
817
818(defun defstruct-translate (form)
819  (let ((translated-args (mapcar #'translate (cdr form))))
820    `($any simplify (list '(,(caar form)) ,@(mapcar #'cdr translated-args)))))
821
822(defun defstruct1 (z) ;; z should look like (($whatever) $a $b $c)
823  (unless (and (consp z) (consp (car z)))
824    (merror (intl:gettext "defstruct: expected a structure template; found ~M") z))
825   ;; store the template
826  (putprop (caar z) (namesonly z) 'defstruct-template)
827  ;; set the initialization
828  (putprop (caar z) (initializersmostly z) 'defstruct-default)
829  (setf (get (caar z) 'dimension) 'dimension-defstruct)
830  (nconc $structures (list (get (caar z) 'defstruct-default)))
831  (setf (get (caar z) 'translate) #'defstruct-translate)
832  (get (caar z) 'defstruct-default))
833
834(defun namesonly(r)			; f(a,b,c) unchanged, f(a=3,b=4,c=5) -> f(a,b,c)
835  (cons (car r)(mapcar #'(lambda(z)
836			   (cond((symbolp z) z)
837				((mequalp z) (second z))
838				(t (merror (intl:gettext "defstruct: expected a record initializer; found: ~M") z))))
839		       (cdr r))))
840
841(defun initializersmostly(r);; f(a=3,b,c=5) -> f(3,b,5)
842  (cons (car r)(mapcar #'(lambda(z)
843			   (cond((symbolp z) z)
844				((mequalp z) (meval (third z)))
845				(t (merror (intl:gettext "defstruct: expected a record initializer; found: ~M") z))))
846		       (cdr r))))
847
848(defmspec $new (h)
849  (unless (= (length (cdr h)) 1)
850    (merror (intl:gettext "new: expected exactly one argument; found: ~M") (length (cdr h))))
851
852  (let ((recordname (cadr h)))
853    (cond
854      ((symbolp recordname)  ;; the case of, e.g.  new(f);
855       (if (null (get recordname 'defstruct-default))
856         (merror (intl:gettext "new: no such structure ~M") recordname))
857
858       (copy-tree (get recordname 'defstruct-default)))
859
860      ;; assume there is some initialization here e.g. new (f(5,6,7))
861      (t
862        (let ((recordop (caar recordname)) (recordargs (cdr recordname)))
863          (if (null (get recordop 'defstruct-default))
864            (merror (intl:gettext "new: no such structure ~M") recordop))
865
866          (if (not (= (length recordargs) (length (cdr (get recordop 'defstruct-default)))))
867            (merror (intl:gettext "new: wrong number of arguments in initializer; expected ~M, not ~M.")
868                    (length (cdr (get recordop 'defstruct-default))) (length recordargs)))
869
870          `(,(car recordname) ,@(mapcar #'meval (cdr recordname))))))))
871
872;; trivial translation to quiet complaint about lack of translation for this defmspec
873(def%tr $new (x) `($any . (meval ',x)))
874
875;; Following property assignments comprise the Lisp code equivalent to infix("@", 200, 201)
876
877(defprop $@ %@ verb)
878(defprop $@ "@" op)
879(putopr "@" '$@)
880;; !! FOLLOWING LINE MOVED TO NPARSE.LISP TO AVOID COMPILER ERROR
881;; !! (MOVING SUPRV1.LISP HIGHER IN MAXIMA.SYSTEM CAUSES MYSTERIOUS ERROR)
882;; !! (define-symbol "@")
883(defprop $@ dimension-infix dimension)
884(defprop $@ (#\@) dissym)
885(defprop $@ tex-infix tex)
886(defprop $@ ("@") texsym)
887(defprop $@ msize-infix grind)
888(defprop $@ 200 lbp)
889(defprop $@ 201 rbp)
890(defprop $@ parse-infix led)
891(defprop %@ dimension-infix dimension)
892(defprop %@ (#\@) dissym)
893(defprop %@ $@ noun)
894
895;; The follow code implements PARALLEL LIST assignment.
896;; it is consistent with commercial macsyma.  [a,b,c]:[x,y,z] means
897;;  about the same as a:x, b:y, c:z.  Actually it
898;; evaluates x,y,z  BEFORE any assignments to a,b,c, hence parallel.
899;; Also implemented is [a,b,c]:x  which evaluates x once and assigns
900;; to a,b,c.
901;; value returned is (evaluated x to ex)  [ex,ex,ex].
902
903;; quiz .  [a,b]:[b,2*a].  produces values a=b, b= 2*a.
904;; re-execute the statement 4 times. what do you get?  [4b, 8a]
905;;
906;; a neat application of parallel assignment is this version of
907;; a gcd algorithm (for integers)...
908;; kgcd(a,b):=(while b#0 do [a,b]:[b,remainder(a,b)], abs(a));
909;; The extended euclidean algorithm looks even better with parallel
910;; assignment.
911
912;; add MLIST to possible operators on the left hand side of
913;; an assignment statement.
914
915(setf (get 'mlist 'mset_extension_operator) 'mlist-assign)
916
917(defun mlist-assign (tlist vlist)
918  ;;  tlist is  ((mlist..)  var[0]... var[n])  of targets
919  ;; vlist is either((mlist..)  val[0]... val[n]) of values
920  ;; or possibly just one value.
921  ;; should insert some checking code here
922  (if (and (listp vlist)
923	   (eq (caar vlist) 'mlist)
924	   (not (= (length tlist)(length vlist))))
925      (merror (intl:gettext "assignment: lists must be the same length; found: ~M, ~M") tlist vlist))
926  (setq tlist
927        `((mlist)
928          ,@(mapcar
929              #'(lambda (x)
930                        (if (or (symbolp x) (get (caar x) 'mset_extension_operator))
931                            x
932                            `(,(car x) ,@(mapcar #'meval (cdr x)))))
933              (cdr tlist))))
934  (unless (and (listp vlist)
935	   (eq (caar vlist) 'mlist))
936    (setf vlist (cons (car tlist) ;; if [a,b,c]:v  then make a list [v,v,v]
937		      (make-sequence 'list (1-(length tlist)) :initial-element vlist))))
938  (map nil #'mset (cdr tlist)(cdr vlist))
939   vlist)
940
941;; ---------- end code copied & modified from defstruct.lisp
942
943(defmspec $ev (l)
944  (setq l (cdr l))
945  (let ((evp t) (*nounl* *nounl*) ($float $float) ($numer $numer)
946	($expop $expop) ($expon $expon) ($doallmxops $doallmxops)
947	($doscmxops $doscmxops) (derivflag derivflag) ($detout $detout)
948	(*nounsflag* *nounsflag*) (rulefcnl rulefcnl))
949    (if (and (cdr l) (null (cddr l)) (eq (car l) '$%e) (eq (cadr l) '$numer))
950	(setq l (append l '($%enumer))))
951    (do ((l (cdr l) (cdr l)) (bndvars) (bndvals) (locvars) (exp (car l))
952	 (subsl) (evflg 0) (ratf) (derivlist) (evfunl) (funcl) (predflg)
953	 (noeval (member '$noeval (cdr l) :test #'eq)))
954	((null l)
955	 (mbinding (bndvars bndvars)
956		   (meval `((mlocal) ,@locvars))
957		   (let ($translate) (mapc #'meval1 funcl))
958		   (let ($numer) (setq exp (mevalatoms exp)))
959		   (if ($ratp exp) (setq ratf t exp ($ratdisrep exp)))
960		   (if (specrepp exp) (setq exp (specdisrep exp)))
961		   (when subsl
962		     (setq exp (simplify exp))
963		     (dolist (item subsl)
964		       (setq exp (maxima-substitute (meval (car item))
965						    (meval (cdr item))
966						    exp)))))
967	 ; Ensure that MUNLOCAL gets called so that we don't leak any local
968	 ; function definitions if we run into an error
969	 (unwind-protect
970	   (mbinding (bndvars bndvals)
971		     (if (and $numer noeval $%enumer)
972			 (setq exp (maxima-substitute %e-val '$%e exp)))
973		     (setq exp (if noeval
974				   (resimplify exp)
975				   (simplify (if predflg (mevalp exp) (meval1 exp)))))
976		     (if (or (> evflg 0) $infeval)
977			 (prog (exp1)
978			    (setq exp (specrepcheck exp))
979			    loop (do ((l evfunl (cdr l)) (exp2 exp))
980				     ((null l) (setq exp1 (meval exp2)))
981				   (setq exp2 (list (ncons (car l)) exp2)))
982			    (dolist (item subsl)
983			      (setq exp1 (maxima-substitute (meval (car item))
984							    (meval (cdr item))
985							    exp1)))
986			    (cond ((or (and (not $infeval)
987					    (= (setq evflg (1- evflg)) 0))
988				       (prog2 (setq exp1 (specrepcheck exp1))
989					   (alike1 exp exp1)))
990				   (setq exp exp1))
991				  (t (setq exp exp1) (go loop)))))
992		     (if (and ratf (not $numer) (not $float))
993			 (setq exp (let ($norepeat) (ratf exp)))))
994	   (munlocal))
995	 exp)
996      (if (not (or (atom (car l))
997		   (member 'array (cdaar l) :test #'eq)
998		   (member (caaar l) '(mquote msetq mlist mequal mdefine mset
999				     mdefmacro $expand $local $derivlist) :test #'eq)))
1000	  (setq l (cons (meval (car l)) (cdr l))))
1001      (cond ((or (atom (car l)) (member 'array (cdaar l) :test #'eq) (eq (caaar l) 'mquote))
1002	     (or (and (symbolp (car l))
1003		      (cond ((eq (car l) '$eval) (setq evflg (1+ evflg)))
1004			    ((member (car l) '($noeval $rescan) :test #'eq))
1005			    ((eq (car l) '$detout)
1006			     (setq $doallmxops nil $doscmxops nil $detout t))
1007			    ((eq (car l) '$numer) (setq $numer t $float t))
1008			    ((eq (car l) '$nouns) (setq *nounsflag* t))
1009			    ((eq (car l) '$pred) (setq predflg t))
1010			    ((eq (car l) '$expand)
1011			     (setq $expop $maxposex $expon $maxnegex))
1012			    ((eq (car l) '%derivative)
1013			     (setq derivflag t derivlist nil))
1014			    ((get (car l) 'evflag)
1015			     (setq bndvars (cons (car l) bndvars)
1016				   bndvals (cons (get (car l) 'evflag) bndvals)))
1017			    ((get (car l) 'evfun)
1018			     (setq exp (evfunmake (car l) exp)
1019				   evfunl (nconc evfunl (ncons (car l)))))))
1020		 (let ((fl (meval (car l))))
1021		   (cond ((symbolp fl)
1022			  (cond ((eq fl '$diff)
1023				 (setq l (list* nil '$del (cdr l))))
1024				((eq fl '$risch)
1025				 (setq l (list* nil '$integrate (cdr l)))))
1026			  (setq *nounl* (cons ($nounify fl) *nounl*)))
1027			 ((numberp fl) (improper-arg-err (car l) '$ev))
1028			 ((stringp fl) (improper-arg-err (car l) '$ev))
1029			 ((eq (caar fl) 'mlist)
1030			  (setq l (append fl (cdr l))))
1031			 ((member (caar fl)
1032				'(msetq mequal mdefine mdefmacro mset) :test #'eq)
1033			  (setq l (list* nil fl (cdr l))))
1034			 (t (improper-arg-err (car l) '$ev))))))
1035	    ((not (member (caaar l) '(msetq mlist mequal mdefine mdefmacro
1036				    $expand $local $derivlist mset) :test #'eq))
1037	     (improper-arg-err (car l) '$ev))
1038	    ((eq (caaar l) '$expand)
1039	     (cond ((null (cdar l)) (setq $expop $maxposex $expon $maxnegex))
1040		   ((null (cddar l)) (setq $expop (cadar l) $expon $maxnegex))
1041		   (t (setq $expop (cadar l) $expon (caddar l)))))
1042	    ((member (caaar l) '(mdefine mdefmacro) :test #'eq)
1043	     (let ((fun (cadar l)) $use_fast_arrays)
1044	       (if (eq (caar fun) 'mqapply) (setq fun (cadr fun)))
1045	       (setq fun ($verbify (caar fun)))
1046	       (setq funcl (nconc funcl (ncons (car l)))
1047		     locvars (append locvars (ncons fun)))
1048	       (if (rulechk fun) (setq rulefcnl (cons fun rulefcnl)))))
1049	    ((eq (caaar l) '$local) (setq locvars (append locvars (cdar l))))
1050	    ((eq (caaar l) '$derivlist) (setq derivflag t derivlist (cdar l)))
1051	    ((and (eq (caaar l) 'mset)
1052		  (setq l (cons (list '(msetq) (meval (cadar l)) (caddar l))
1053				(cdr l)))
1054		  nil))
1055	    ((member (caaar l) '(msetq mequal) :test #'eq)
1056	     (if (and (msetqp (car l)) (msetqp (caddar l)))
1057		 (setq l (nconc (|:SPREAD| (car l)) (cdr l))))
1058	     (if (or noeval (not (atom (cadar l))))
1059		 (setq subsl (nconc subsl (list (cons (caddar l) (cadar l))))))
1060	     (if (atom (cadar l))
1061		 (setq bndvars (cons (cadar l) bndvars)
1062		       bndvals (cons (meval (specrepcheck (caddar l))) bndvals))))
1063        (t (setq l (append (car l) (cdr l))))))))
1064
1065(defun mevalatoms (exp)
1066  (cond ((atom exp) (meval1 exp))
1067	((member 'array (cdar exp) :test #'eq)
1068	 (let (exp1)
1069	   (let ((evarrp t)) (setq exp1 (catch 'evarrp (meval1 exp))))
1070	   (if (eq exp1 'notexist)
1071	       (cons (car exp) (mapcar #'mevalatoms (cdr exp)))
1072	       exp1)))
1073	((eq (caar exp) 'mquote) (cadr exp))
1074	((member (caar exp) '(msetq $define) :test #'eq)
1075	 (list (car exp) (cadr exp) (mevalatoms (caddr exp))))
1076	((or (and (eq (caar exp) '$ev)
1077		  (cdr exp)
1078		  (or (null (cddr exp)) (equal (cddr exp) '($eval))))
1079	     (eq (caar exp) 'mprogn))
1080	 (cons (car exp) (cons (mevalatoms (cadr exp)) (cddr exp))))
1081	((member (caar exp) '($sum $product %sum %product) :test #'eq)
1082	 (if msump
1083	     (meval exp)
1084	     (list (car exp) (cadr exp) (caddr exp)
1085		   (mevalatoms (cadddr exp)) (mevalatoms (car (cddddr exp))))))
1086	((and (eq (caar exp) '$%th) (fixnump (simplify (cadr exp))))
1087	 (meval1 exp))
1088	((prog2 (autoldchk (caar exp))
1089	     (and (getl (caar exp) '(mfexpr*))
1090		  (not (get (caar exp) 'evok))))
1091	 exp)
1092	((mgetl (caar exp) '(mfexprp))
1093	 (cons (car exp)
1094	       (do ((a (cdadr (mget (caar exp) 'mexpr)) (cdr a))
1095		    (b (cdr exp) (cdr b)) (l))
1096		   ((not (and a b)) (nreverse l))
1097		 (cond ((mdeflistp a)
1098			(return (nreconc l (if (mquotep (cadar a))
1099					       b
1100					       (mapcar #'mevalatoms b)))))
1101		       ((mquotep (car a)) (setq l (cons (car b) l)))
1102		       (t (setq l (cons (mevalatoms (car b)) l)))))))
1103	((or (eq (caar exp) 'mmacroexpanded)
1104	     (and $transrun (get (caar exp) 'translated-mmacro))
1105	     (mget (caar exp) 'mmacro))
1106	 (mevalatoms (mmacroexpand exp)))
1107	(t (cons (car exp) (mapcar #'mevalatoms (cdr exp))))))
1108
1109;; evok properties
1110(mapc #'(lambda (x) (putprop x t 'evok))
1111      '($map $maplist $fullmap $matrixmap $fullmapl $outermap $scanmap $apply))
1112
1113(defun evfunmake (fun exp)
1114  (if (msetqp exp)
1115      (list (car exp) (cadr exp) (evfunmake fun (caddr exp)))
1116      (list (ncons fun) exp)))
1117
1118(defun |:SPREAD| (x)
1119  (do ((val (do ((x x (caddr x))) (nil)
1120	      (if (not (msetqp (caddr x))) (return (caddr x)))))
1121       (x x (caddr x)) (l))
1122      ((not (msetqp x)) l)
1123    (setq l (cons (list (car x) (cadr x) val) l))))
1124
1125(defun msetqp (x)
1126  (and (not (atom x)) (eq (caar x) 'msetq)))
1127
1128(defun mquotep (x)
1129  (and (not (atom x)) (eq (caar x) 'mquote)))
1130
1131(defmspec mquote (form)
1132  (cadr form))
1133
1134(defmfun $subvarp (x)
1135  (and (not (atom x)) (member 'array (cdar x) :test #'eq) t))
1136
1137(defun mseterr (x y)
1138  (if munbindp
1139      'munbindp
1140      (merror (intl:gettext "assignment: cannot assign ~M to ~:M") y x)))
1141
1142;; assign properties
1143(mapc #'(lambda (x) (putprop (car x) (cadr x) 'assign))
1144      '(($linel msetchk) (*read-base* msetchk) (*print-base* msetchk) (modulus msetchk)
1145	($infolists neverset) ($trace neverset) ($ratweights msetchk)
1146	($ratvars msetchk) ($setcheck msetchk) ($gcd msetchk)
1147	($dotassoc msetchk) ($ratwtlvl msetchk) ($ratfac msetchk)
1148	($all neverset) ($numer numerset) ($fortindent msetchk)
1149	($gensumnum msetchk) ($genindex msetchk) ($fpprintprec msetchk)
1150	($floatwidth msetchk) ($parsewindow msetchk) ($optimprefix msetchk)))
1151
1152(defun msetchk (x y)
1153  (cond ((member x '(*read-base* *print-base*) :test #'eq)
1154	 (cond ((eq y 'roman))
1155	       ((or (not (fixnump y)) (< y 2) (> y 36)) (mseterr x y))
1156	       ((eq x '*read-base*))))
1157	((member x '($linel $fortindent $gensumnum $fpprintprec $floatwidth
1158		   $parsewindow) :test #'eq)
1159	 (if (not (fixnump y)) (mseterr x y))
1160         (if (eq x '$linel)
1161             (cond ((not (and (> y 0)         ; at least one char per line
1162                              (< y 1000001))) ; arbitrary chosen big value
1163                    (mseterr x y))
1164                   (t
1165                    (setq linel y))))
1166	 (cond ((and (member x '($fortindent $gensumnum $floatwidth) :test #'eq) (< y 0))
1167		(mseterr x y))
1168	       ((and (eq x '$parsewindow) (< y -1)) (mseterr x y))
1169	       ((and (eq x '$fpprintprec) (or (< y 0) (= y 1))) (mseterr x y))))
1170	((member x '($genindex $optimprefix) :test #'eq) (if (not (symbolp y)) (mseterr x y)))
1171	((eq x '$dotassoc) (cput 'mnctimes y 'associative))
1172	((eq x 'modulus)
1173	 (cond ((null y))
1174	       ((and (integerp y) (plusp y))
1175	        ;; modulus must be an integer > 0. Give a warning if not
1176	        ;; a prime number.
1177	        (if (not (primep y))
1178	            (mtell (intl:gettext "warning: assigning ~:M, a non-prime, to 'modulus'~&") y)))
1179	       (t (mseterr x y))))
1180	((eq x '$setcheck)
1181	 (if (not (or (member y '($all t nil) :test #'eq) ($listp y))) (mseterr x y)))
1182	((eq x '$gcd) (if (not (or (null y) (member y *gcdl* :test #'eq))) (mseterr x y)))
1183	((eq x '$ratvars)
1184	 (if ($listp y) (apply #'$ratvars (cdr y)) (mseterr x y)))
1185	((eq x '$ratfac)
1186	 (if (and y $ratwtlvl)
1187	     (merror (intl:gettext "assignment: 'ratfac' and 'ratwtlvl' may not both be used at the same time."))))
1188	((eq x '$ratweights)
1189	 (cond ((not ($listp y)) (mseterr x y))
1190	       ((null (cdr y)) (kill1 '$ratweights))
1191	       (t (apply #'$ratweight (cdr y)))))
1192	((eq x '$ratwtlvl)
1193	 (if (and y (not (fixnump y))) (mseterr x y))
1194	 (if (and y $ratfac)
1195	     (merror (intl:gettext "assignment: 'ratfac' and 'ratwtlvl' may not both be used at the same time."))))))
1196
1197(defun numerset (assign-var y)
1198  (declare (ignore assign-var))
1199  (mset '$float y))
1200
1201(defun neverset (x assign-val)
1202  (declare (ignore assign-val))
1203  (if munbindp
1204      'munbindp
1205      (merror (intl:gettext "assignment: cannot assign to ~:M") x)))
1206
1207;; Check assignment to be a positive integer including zero
1208(defun posintegerset (x y)
1209  (if (or (not (integerp y))
1210          (not (>= y 0)))
1211      (merror
1212        (intl:gettext "assignment: '~:M must be a positive integer. Found: ~:M")
1213        x y)))
1214
1215(defun mmapev (l)
1216  (if (null (cddr l))
1217      (merror (intl:gettext "~:M: expected two or more arguments; found: ~M") (caar l) (cons '(mlist) (cdr l))))
1218  (let ((op (getopr (meval (cadr l)))))
1219    (autoldchk op)
1220    (badfunchk (cadr l) op nil)
1221    (cons op (mapcar #'meval (cddr l)))))
1222
1223(defmspec $map (l)
1224  (apply #'map1 (mmapev l)))
1225
1226(defun-maclisp map1 n
1227  (do ((i n (1- i))
1228       (argi (setarg n (format1 (arg n))) (format1 (arg (1- i))))
1229       (op (or (mapatom (arg n)) (mop (arg n))))
1230       (flag (mapatom (arg n))
1231	     (or flag
1232		 (setq flag (mapatom argi))
1233		 (and (not maplp) (not (alike1 (mop argi) op)))))
1234       (argl nil (cons argi argl))
1235       (cdrl nil (or flag (cons (margs argi) cdrl))))
1236      ((= i 1) (if flag
1237		   (cond ((not $maperror)
1238			  (when $mapprint (mtell (intl:gettext "map: calling 'apply'")))
1239			  (funcer (arg 1) argl))
1240			 ((and (= n 2) (mapatom (arg 2)))
1241			  (improper-arg-err (arg 2) '$map))
1242			 (t (merror (intl:gettext "map: arguments must have same main operator; found: ~M, ~M") op (mop (first argl)))))
1243		   (mcons-op-args op (apply #'mmapcar (cons (arg 1) cdrl)))))))
1244
1245(defmspec $maplist (l)
1246  (let ((maplp t) res)
1247    (setq res (apply #'map1 (mmapev l)))
1248    (cond ((atom res) (list '(mlist) res))
1249	  ((eq (caar res) 'mlist) res)
1250	  (t (cons '(mlist) (margs res))))))
1251
1252(defun-maclisp mmapcar n
1253  (do ((ans nil (cons (funcer (arg 1) argl) ans))
1254       (argl nil nil))
1255      ((do ((i n (1- i)))
1256	   ((= i 1) nil)
1257	 (when (null (arg i))
1258	   (when (or (< i n)
1259		     (do ((j 2 (1+ j)))
1260			 ((= j n) nil)
1261		       (when (arg j) (return t))))
1262	     (when $maperror
1263	       (merror (intl:gettext "map: arguments must be the same length.")))
1264	     (when $mapprint (mtell (intl:gettext "map: truncating one or more arguments."))))
1265	   (return t))
1266	 (push (car (arg i)) argl)
1267	 (setarg i (cdr (arg i))))
1268       (nreverse ans))))
1269
1270(defun mapatom (x)
1271  (or (symbolp x) (mnump x) ($subvarp x) (stringp x)
1272      (and (consp x) (eq (caar x) 'mminus) (mnump (cadr x)))))
1273
1274(defmfun $mapatom (x)
1275  (if (mapatom (specrepcheck x)) t))
1276
1277(defmspec $fullmap (l)
1278  (setq l (mmapev l))
1279  (fmap1 (car l) (cdr l) nil))
1280
1281(defun fmap1 (fn argl fmapcaarl)
1282  (setq argl (mapcar #'format1 argl))
1283  (do ((op (or (mapatom (car argl)) (mop (car argl))))
1284       (fmaplvl (1- fmaplvl)) (cdr1 argl (cdr cdr1)) (argi nil nil)
1285       (cdrl nil (cons (margs (car cdr1)) cdrl)))
1286      ((null cdr1)
1287       (do ((ans nil (cons (if bottom (funcer fn carargl)
1288			       (fmap1 fn carargl fmapcaarl))
1289			   ans))
1290	    (carargl nil nil) (cdrargl nil nil)
1291	    (cdrl cdrl cdrargl) (bottom nil nil)
1292	    (done (when (member nil cdrl :test #'eq)
1293		    (when (dolist (e cdrl) (if e (return t)))
1294		      (when $maperror
1295			(merror (intl:gettext "fullmap: arguments must have same formal structure.")))
1296		      (when $mapprint
1297			(mtell (intl:gettext "fullmap: truncating one or more arguments.~%"))))
1298		    t)))
1299	   (done (mcons-op-args op (nreverse ans)))
1300	 (do ((op (or (setq bottom (or (zerop fmaplvl) (mapatom (caar cdrl))))
1301		      (mop (caar cdrl))))
1302	      (eleml cdrl (cdr eleml)) (caareleml nil nil))
1303	     ((null eleml)
1304	      (when (and done (dolist (e cdrargl) (if e (return t))))
1305		(if $maperror
1306		    (merror (intl:gettext "fullmap: arguments must have same formal structure.")))
1307		(if $mapprint (mtell (intl:gettext "fullmap: truncating one or more arguments.~%")))))
1308	   (setq caareleml (caar eleml))
1309	   (or bottom
1310	       (setq bottom
1311		     (or (mapatom caareleml)
1312			 (not (alike1 op (mop caareleml)))
1313			 (and fmapcaarl (not (eq (caar caareleml) fmapcaarl))))))
1314	   (or done (setq done (null (cdar eleml))))
1315	   (setq carargl (nconc (ncons caareleml) carargl)
1316		 cdrargl (nconc cdrargl (ncons (cdar eleml)))))))
1317    (setq argi (car cdr1))
1318    (if (or (mapatom argi)
1319	    (not (alike1 op (mop argi)))
1320	    (and fmapcaarl (not (eq (caar argi) fmapcaarl))))
1321	(cond ($maperror (merror (intl:gettext "fullmap: arguments must have same operators.")))
1322	      (t (if $mapprint (mtell (intl:gettext "fullmap: calling 'apply'.~%")))
1323		 (return (funcer fn argl)))))))
1324
1325(defmspec $matrixmap (l)
1326  (let ((fmaplvl 2))
1327    (apply #'fmapl1 (mmapev l))))
1328
1329(defmspec $fullmapl (l)
1330  (apply #'fmapl1 (mmapev l)))
1331
1332(defun fmapl1 (fun &rest args)
1333  (let* ((header '(mlist))
1334	 (argl (fmap1 fun
1335		      (mapcar #'(lambda (z)
1336				  (cond ((not (mxorlistp z))
1337					 (merror (intl:gettext "fullmapl: argument must be a list or matrix; found: ~M") (or (and (consp z) (mop z)) z)))
1338					((eq (caar z) '$matrix)
1339					 (setq header '($matrix))
1340					 (cons '(mlist simp) (cdr z)))
1341					(t z)))
1342			      args)
1343		      'mlist)))
1344    (if (dolist (e (cdr argl))
1345	  (unless ($listp e) (return t)))
1346	argl
1347	(cons header (cdr argl)))))
1348
1349(defmfun $outermap (x y &rest z)
1350  (if z
1351    (apply #'outermap1 x y z)
1352    (fmapl1 x y)))
1353
1354(defun-maclisp outermap1 n
1355  (let (outargs1 outargs2)
1356    (declare (special outargs1 outargs2))
1357    (cond ((mxorlistp (arg 2))
1358	   (setq outargs1 (ncons (arg 1))
1359		 outargs2 (listify (- 2 n)))
1360	   (fmapl1 #'outermap2 (arg 2)))
1361	  (t (do ((i 3 (1+ i)))
1362		 ((> i n) (funcer (arg 1) (listify (- 1 n))))
1363	       (when (mxorlistp (arg i))
1364		 (setq outargs1 (listify (1- i))
1365		       outargs2 (if (< i n) (listify (- i n))))
1366		 (return (fmapl1 #'outermap2 (arg i)))))))))
1367
1368(defun outermap2 (&rest args)
1369  (declare (special outargs1 outargs2))
1370  (unless (null args)
1371    (apply #'outermap1 (append outargs1 (list (first args)) outargs2))))
1372
1373(defun funcer (fn args)
1374  (cond ((member fn '(mplus mtimes mexpt mnctimes) :test #'eq)
1375	 (simplify (cons (ncons fn) args)))
1376	((or (member fn '(outermap2 constfun) :test #'eq)
1377	     (and $transrun (symbolp fn) (get fn 'translated)
1378		  (not (mget fn 'local-fun)) (fboundp fn)))
1379	 (apply fn (mapcar #'simplify args)))
1380	(t (mapply1 fn (mapcar #'simplify args) fn
1381		    nil	;; try to get more info to pass
1382		    ))))
1383
1384(defmspec $qput (l)
1385  (setq l (cdr l))
1386  (unless (= (length l) 3)
1387    (wna-err '$qput))
1388  ($put (car l) (cadr l) (caddr l)))
1389
1390(defmfun $rem (atom ind)
1391  (prop1 '$rem atom nil ind))
1392
1393(defmfun $put (atom val ind)
1394  (prog1
1395      (prop1 '$put atom val ind)
1396    (add2lnc atom $props)))
1397
1398(defun prop1 (fun atom val ind)
1399  (unless (or (symbolp atom) (stringp atom))
1400    (merror (intl:gettext "~:M: argument must be a symbol or a string; found: ~M") fun atom))
1401  (unless (or (symbolp ind) (stringp ind))
1402    (merror (intl:gettext "~:M: indicator must be a symbol or a string; found: ~M") fun ind))
1403  (unless (symbolp atom)
1404    (if (symbolp (getopr atom))
1405      (setq atom (getopr atom))
1406      (setq atom (intern atom))))
1407  (unless (symbolp ind)
1408    (setq ind (intern ind)))
1409  (let ((u (mget atom '$props)))
1410    (cond ((eq fun '$get) (and u (old-get u ind)))
1411	  ((eq fun '$rem) (and u (zl-remprop u ind) '$done))
1412	  ((not u) (mputprop atom (list nil ind val) '$props) val)
1413	  (t (putprop u val ind)))))
1414
1415(defmspec $declare (l)
1416  (setq l (cdr l))
1417  (when (oddp (length l))
1418    (merror (intl:gettext "declare: number of arguments must be a multiple of 2.")))
1419  (do ((l l (cddr l)) (vars) (flag nil nil))
1420      ((null l)
1421       '$done)
1422    (cond (($listp (cadr l))
1423	   (do ((l1 (cdadr l) (cdr l1))) ((if (null l1) (setq flag t)))
1424	     (meval `(($declare) ,(car l) ,(car l1)))))
1425	  ((nonsymchk (cadr l) '$declare))
1426	  (t (setq vars (declsetup (car l) '$declare))))
1427    (cond (flag)
1428	  ((member (cadr l) '($evfun $evflag $nonarray $bindtest) :test #'eq)
1429	   (declare1 vars t (stripdollar (cadr l)) nil))
1430	  ((eq (cadr l) '$noun)
1431	   (dolist (var vars) (alias (getopr var) ($nounify var))))
1432	  ((member (cadr l) '($nonscalar $scalar $mainvar) :test #'eq)
1433	   (declare1 vars t (cadr l) t))
1434	  ((eq (cadr l) '$alphabetic) (declare1 vars t t '$alphabetic))
1435	  ((member (cadr l) opers :test #'eq)
1436	   (if (member (cadr l) (cdr $features) :test #'eq) (declare1 vars t (cadr l) 'kind))
1437	   (declare1 (mapcar #'getopr vars) t (cadr l) 'opers))
1438	  ((member (cadr l) (cdr $features) :test #'eq) (declare1 vars t (cadr l) 'kind))
1439	  ((eq (cadr l) '$feature)
1440	   (dolist (var vars) (nonsymchk var '$declare) (add2lnc var $features)))
1441	  (t (merror (intl:gettext "declare: unknown property ~:M") (cadr l))))))
1442
1443(defun declare1 (vars val prop mpropp)
1444  (dolist (var vars)
1445    (unless (or (symbolp var) (stringp var))
1446      (merror (intl:gettext "declare: argument must be a symbol or a string; found: ~M") var))
1447
1448      (if (eq mpropp '$alphabetic)
1449        ; Explode var into characters and put each one on the *alphabet* list,
1450        ; which is used by src/nparse.lisp .
1451        (dolist (1-char (coerce var 'list))
1452          (add2lnc 1-char *alphabet*))
1453        (progn
1454          (setq var (getopr var))
1455          (cond
1456            ((eq mpropp 'kind) (declarekind var prop))
1457            ((eq mpropp 'opers)
1458             (putprop (setq var (linchk var)) t prop) (putprop var t 'opers))
1459            (mpropp
1460              (if (and (member prop '($scalar $nonscalar) :test #'eq)
1461                       (mget var (if (eq prop '$scalar) '$nonscalar '$scalar)))
1462                (merror (intl:gettext "declare: inconsistent declaration ~:M") `(($declare) ,var ,prop)))
1463              (mputprop var val prop))
1464            (t (putprop var val prop)))
1465          (if (and (safe-get var 'op) (operatorp1 var)
1466                   (not (member (setq var (get var 'op)) (cdr $props) :test #'eq)))
1467            (setq *mopl* (cons var *mopl*)))
1468          (add2lnc (getop var) $props)))))
1469
1470(defun linchk (var)
1471  (if (member var '($sum $integrate $limit $diff $transpose) :test #'eq)
1472      ($nounify var)
1473      var))
1474
1475(defmspec $remove (form)
1476  (i-$remove (cdr form)))
1477
1478(defun i-$remove (l)
1479  (when (oddp (length l))
1480    (merror (intl:gettext "remove: number of arguments must be a multiple of 2.")))
1481  (do ((l l (cddr l)) (vars) (flag nil nil)) ((null l) '$done)
1482    (cond (($listp (cadr l))
1483	   (do ((l1 (cdadr l) (cdr l1))) ((if (null l1) (setq flag t)))
1484	     (i-$remove (list (car l) (car l1)))))
1485      ((unless (or (symbolp (cadr l)) (stringp (cadr l)))
1486        (merror (intl:gettext "remove: argument must be a symbol or a string; found: ~M") (cadr l))))
1487	  (t (setq vars (declsetup (car l) '$remove))))
1488    (cond (flag)
1489	  ((eq (cadr l) '$value) (i-$remvalue vars))
1490	  ((eq (cadr l) '$function)
1491	   (remove1 (mapcar #'$verbify vars) 'mexpr t $functions t))
1492	  ((eq (cadr l) '$macro)
1493	   (remove1 (mapcar #'$verbify vars) 'mmacro t $macros t))
1494	  ((eq (cadr l) '$array) (meval `(($remarray) ,@vars)))
1495	  ((member (cadr l) '($alias $noun) :test #'eq) (remalias1 vars (eq (cadr l) '$alias)))
1496	  ((eq (cadr l) '$matchdeclare) (remove1 vars 'matchdeclare t t nil))
1497	  ((eq (cadr l) '$rule) (remrule (mapcar #'(lambda (v) (if (stringp v) ($verbify v) v)) vars)))
1498	  ((member (cadr l) '($evfun $evflag $nonarray $bindtest
1499			    $autoload $assign) :test #'eq)
1500	   (remove1 vars (stripdollar (cadr l)) nil t nil))
1501	  ((member (cadr l) '($mode $modedeclare) :test #'eq) (remove1 vars 'mode nil 'foo nil))
1502	  ((eq (cadr l) '$atvalue) (remove1 vars 'atvalues t t nil))
1503	  ((member (cadr l) '($nonscalar $scalar $mainvar $numer $atomgrad) :test #'eq)
1504	   (remove1 vars (cadr l) t t nil))
1505	  ((member (cadr l) opers :test #'eq) (remove1 (mapcar #'linchk vars) (cadr l) nil t nil))
1506	  ((member (cadr l) (cdr $features) :test #'eq) (remove1 vars (cadr l) nil t nil))
1507	  ((eq (cadr l) '$feature)
1508	   (dolist (var vars)
1509	     (setf $features (delete var $features :count 1 :test #'eq))))
1510	  ((member (cadr l) '($alphabetic $transfun) :test #'eq)
1511	   (remove1 vars (cadr l) nil t nil))
1512	  ((member (cadr l) '($gradef $grad) :test #'eq) (remove1 vars 'grad nil $gradefs t))
1513	  ((member (cadr l) '($dependency $depend $depends) :test #'eq)
1514	   (remove1 vars 'depends t $dependencies t))
1515	  ((member (cadr l) '($op $operator) :test #'eq) (remove1 vars '$op nil 'foo nil))
1516	  ((member (cadr l) '($deftaylor $taylordef) :test #'eq) (remove1 vars 'sp2 nil t nil))
1517	  (t (merror (intl:gettext "remove: unknown property ~:M") (cadr l))))))
1518
1519(defun declsetup (x fn)
1520  (cond ((atom x) (ncons x))
1521	((eq (caar x) '$nounify) (ncons (meval x)))
1522	((eq (caar x) 'mlist)
1523	 (mapcar #'(lambda (var)
1524		     (cond ((atom var) var)
1525			   ((eq (caar var) '$nounify) (meval var))
1526			   (t (improper-arg-err var fn))))
1527		 (cdr x)))
1528	(t (improper-arg-err x fn))))
1529
1530(defun remove1 (vars prop mpropp info funp)
1531  (do ((vars vars (cdr vars)) (allflg))
1532    ((null vars))
1533    (unless (or (symbolp (car vars)) (stringp (car vars)))
1534      (merror (intl:gettext "remove: argument must be a symbol or a string; found: ~M") (car vars)))
1535    (cond
1536      ((and (eq (car vars) '$all) (null allflg))
1537       (setq vars (append vars (cond ((atom info) (cdr $props))
1538                                     (funp (mapcar #'caar (cdr info)))
1539                                     (t (cdr info))))
1540             allflg t))
1541      (t
1542        (if (and (stringp (car vars)) (eq prop '$op) (getopr0 (car vars)))
1543          (kill-operator (getopr0 (car vars))))
1544
1545        (if (and (eq prop '$alphabetic) (stringp (car vars)))
1546          (dolist (1-char (coerce (car vars) 'list))
1547            (setf *alphabet* (delete 1-char *alphabet* :count 1 :test #'equal)))
1548          (let ((var  (getopr (car vars)))( flag  nil))
1549            (cond
1550              (mpropp (mremprop var prop)
1551                      (when (member prop '(mexpr mmacro) :test #'eq)
1552                        (mremprop var 'mlexprp)
1553                        (mremprop var 'mfexprp)
1554                        (remprop var 'lineinfo)
1555                        (if (mget var 'trace)
1556                          (macsyma-untrace var))))
1557              ((eq prop '$transfun)
1558               (remove-transl-fun-props var)
1559               (remove-transl-array-fun-props var))
1560              ((or (setq flag (member prop (cdr $features) :test #'eq)) (member prop opers :test #'eq))
1561               (if flag (unkind var prop))
1562               (zl-remprop var prop)
1563               (if (not (getl var (delete prop (copy-list opers) :count 1 :test #'eq)))
1564                 (zl-remprop var 'opers)))
1565              (t (zl-remprop var prop)))
1566            (cond ((eq info t) (rempropchk (car vars)))
1567                  ((eq info 'foo))
1568                  (funp
1569                    (mfunction-delete var info))
1570                  (t
1571                    (setf info (delete var info :count 1 :test #'eq))))))))))
1572
1573(defun remove-transl-fun-props (fun)
1574  (if (mget fun 'trace)
1575      (macsyma-untrace fun))
1576  (when (and (get fun 'translated) (not (eq $savedef '$all)))
1577    (fmakunbound fun)
1578    (zl-remprop fun 'translated-mmacro)
1579    (zl-remprop fun 'function-mode)
1580    (when (not (getl fun '(a-expr a-subr)))
1581	(zl-remprop fun 'once-translated)
1582	(zl-remprop fun 'translated))))
1583
1584(defun remove-transl-array-fun-props (fun)
1585  (when (and (get fun 'translated) (not (eq $savedef '$all)))
1586    (zl-remprop fun 'a-expr)
1587    (zl-remprop fun 'a-subr)
1588    (if (not (fboundp fun)) (zl-remprop fun 'translated))))
1589
1590(defun rempropchk (var)
1591  (if (and
1592        (or
1593          (not (symbolp var))
1594          (and
1595            (not (mgetl var '($nonscalar $scalar $mainvar $numer
1596                                        matchdeclare $atomgrad atvalues)))
1597            (not (getl var '(evfun evflag translated nonarray bindtest
1598                                   sp2 operators opers data autoload mode)))))
1599	   (not (member var *builtin-$props* :test #'equal)))
1600      (delete var $props :count 1 :test #'equal)))
1601
1602(defmspec $remfunction (l)
1603  (setq l (cdr l))
1604  (cond ((member '$all l :test #'eq)
1605	 (setq l (nconc (mapcar #'caar (cdr $functions))
1606			(mapcar #'caar (cdr $macros)))))
1607	(t (setq l (mapcar #'$verbify l))
1608	   (do ((l1 l (cdr l1))) ((null l1) t)
1609	     (if (not (or (assoc (ncons (car l1)) (cdr $functions) :test #'equal)
1610			  (assoc (ncons (car l1)) (cdr $macros) :test #'equal)))
1611		 (rplaca l1 nil)))))
1612  (remove1 l 'mexpr t $functions t)
1613  (remove1 l 'mmacro t $macros t)
1614  (cons '(mlist) l))
1615
1616(defmspec $remarray (l)
1617  (setq l (cdr l))
1618  (cons '(mlist)
1619	(do ((l l (cdr l)) (x) (pred)) ((null l) (nreverse x))
1620	  (cond ((eq (car l) '$all) (setq l (append l (cdr $arrays))))
1621		(t (remcompary (car l)) (setq pred (mremprop (car l) 'array))
1622		   (setq pred (or (mremprop (car l) 'hashar) pred))
1623		   (setq pred (or (mremprop (car l) 'aexpr) pred))
1624		   (setq x (cons (and pred (prog2
1625					       (setf $arrays (delete (car l) $arrays :count 1 :test #'eq))
1626					       (car l)))
1627				 x)))))))
1628
1629(defun remcompary (x)
1630  (cond ((eq x (mget x 'array))
1631	 (zl-remprop x 'array-mode)
1632	 (zl-remprop x 'array))))
1633
1634(defmspec $remvalue (form)
1635  (i-$remvalue (cdr form)))
1636
1637(defun i-$remvalue (l)
1638  (cons '(mlist)
1639	(do ((l l (cdr l)) (x) (y)) ((null l) (nreverse x))
1640	  (cond ((eq (car l) '$all) (setq l (append l (cdr $values))))
1641		(t (setq x (cons (cond ((atom (car l))
1642					(if (remvalue (car l) '$remvalue) (car l)))
1643				       ((setq y (mgetl (caaar l) '(hashar array)))
1644					(remarrelem y (car l)) (car l)))
1645				 x)))))))
1646
1647(defun remarrelem (ary form)
1648  (let ((y (car (arraydims (cadr ary)))))
1649    (arrstore form (cond ((eq y 'fixnum) 0) ((eq y 'flonum) 0.0) (t munbound)))))
1650
1651(defun remrule (l)
1652  (do ((l l (cdr l)) (u))
1653      ((null l))
1654    (cond ((eq (car l) '$all) (setq l (append l (cdr $rules))))
1655	  ((get (car l) 'operators) ($remrule (car l) '$all))
1656	  ((setq u (ruleof (car l))) ($remrule u (car l)))
1657	  ((mget (car l) '$rule)
1658	   (zl-remprop (car l) 'expr) (mremprop (car l) '$rule)
1659	   (setf $rules (delete (car l) $rules :count 1 :test #'eq))))))
1660
1661(defun remalias1 (l aliasp)
1662  (do ((l l (cdr l)) (u)) ((null l))
1663    (cond ((eq (car l) '$all) (setq l (append l (cdr $aliases))))
1664	  ((or aliasp (get (car l) 'noun)) (remalias (car l) t))
1665	  ((setq u (get (car l) 'verb))
1666	   (zl-remprop (car l) 'verb) (zl-remprop u 'noun)))))
1667
1668(defun mremprop (atom ind)
1669  (let ((props (get atom 'mprops))) (and props (zl-remprop props ind))))
1670
1671(defun mgetl (atom inds)
1672  (let ((props (get atom 'mprops))) (and props (getl props inds))))
1673
1674;;; Define $matrix so that apply(matrix,...) does not need to use Lisp
1675;;; apply -- in GCL, apply is limited to 63 arguments.
1676
1677;;; Equivalent to matrix([?rows]) := ?matrixhelper(?rows)$
1678#+gcl (mputprop '$matrix '((lambda) ((mlist) ((mlist) rows)) ((matrixhelper) rows)) 'mexpr)
1679#+gcl (mputprop '$matrix t 'mlexprp)
1680#+gcl (mputprop '$matrix '$matrix 'pname)
1681
1682#-gcl (defmfun $matrix (&rest rows) (matrixhelper rows))
1683
1684;; Call ONLY from $matrix
1685(defun matrixhelper (rows)
1686  #+gcl
1687    (progn
1688      (if (not ($listp rows)) (merror "internal error: MATRIXHELPER expects a Maxima list."))
1689      (setq rows (cdr rows)))
1690  (dolist (row rows)
1691    (if (not ($listp row))
1692      (merror (intl:gettext "matrix: row must be a list; found: ~M") row)))
1693  (matcheck rows)
1694  (cons '($matrix) rows))
1695
1696(defun matcheck (l)
1697  (do ((l1 (cdr l) (cdr l1)) (n (length (car l)))) ((null l1))
1698    (if (not (= n (length (car l1))))
1699	(merror (intl:gettext "matrix: all rows must be the same length.")))))
1700
1701(defun harrfind (form)
1702  (prog (ary y lispsub iteml sub ncells nitems)
1703     (setq ary (symbol-array (mget (caar form) 'hashar)))
1704     (cond ((not (= (aref ary 2) (length (cdr form))))
1705	    (merror (intl:gettext "evaluation: array ~:M must have ~:M indices; found: ~M")
1706		    (caar form) (aref ary 2) form)))
1707     (setq sub (cdr form))
1708     (setq iteml (aref ary (setq lispsub (+ 3 (rem (hasher sub) (aref ary 0))))))
1709     a    (cond ((null iteml) (go b))
1710		((alike (caar iteml) sub) (return (cdar iteml))))
1711     (setq iteml (cdr iteml))
1712     (go a)
1713     b    (cond (evarrp (throw 'evarrp 'notexist))
1714		((null (setq y (arrfunp (caar form)))) (return (meval2 sub form))))
1715     (setq y (arrfuncall y sub form))
1716     (setq ary (symbol-array (mget (caar form) 'hashar)))
1717     (setq iteml (aref ary (setq lispsub (+ 3 (rem (hasher sub) (aref ary 0))))))
1718     (setq sub (ncons (cons sub y)))
1719     (cond (iteml (nconc iteml sub)) (t (setf (aref ary lispsub) sub)))
1720     (setf (aref ary 1) (setq nitems (1+ (aref ary 1))))
1721     (cond ((> nitems (setq ncells (aref ary 0)))
1722	    (arraysize (caar form) (+ ncells ncells))))
1723     (return y)))
1724
1725(defun arrfind (form)
1726  (let ((sub (cdr form)) u v type)
1727    (setq v (dimcheck (caar form) sub nil))
1728    (cond (v (setq type (car (arraydims (mget (caar form) 'array))))))
1729    (cond ((and v (prog2
1730		      (setq u (apply 'aref (symbol-array (mget (caar form) 'array)) sub))
1731		      (cond ((eq type 'flonum) (not (= u flounbound)))
1732			    ((eq type 'fixnum) (not (= u fixunbound)))
1733			    (t (not (eq u munbound))))))
1734	   u)
1735	  (evarrp (throw 'evarrp 'notexist))
1736	  ((or (not v) (null (setq u (arrfunp (caar form)))))
1737	   (cond ((eq type 'flonum) 0.0)
1738		 ((eq type 'fixnum) 0)
1739		 (t (meval2 sub form))))
1740	  (t (setq u (arrfuncall u sub form))
1741	     (setf (apply #'aref (symbol-array (mget (caar form) 'array))
1742			  sub) u)
1743
1744	     u))))
1745
1746(defmspec $array (x)
1747  (setq x (cdr x))
1748  (cond
1749	((symbolp (car x))
1750     (if $use_fast_arrays
1751         (let ((type (if (symbolp (cadr x)) (cadr x) '$any))
1752               (name (car x))
1753               (diml (if (symbolp (cadr x)) (cddr x) (cdr x))))
1754           (mset name
1755                 (apply '$make_array
1756                        type
1757                        (mapcar #'(lambda (dim)
1758                                  ;; let make_array catch bad vals
1759                                    (add 1 (meval dim)))
1760                                diml))))
1761	 (let ((compp (assoc (cadr x) '(($complete . t) ($integer . fixnum) ($fixnum . fixnum)
1762					($float . flonum) ($flonum . flonum)))))
1763	   (let ((fun (car x))
1764		 (diml (cond (compp (setq compp (cdr compp))
1765				    (cddr x))
1766			     (t (cdr x))))
1767		 funp
1768		 old
1769		 new
1770		 (ncells 0))
1771	     (when (member '$function diml :test #'eq)
1772	       (setq diml (delete '$function diml :count 1 :test #'eq)
1773		     funp t))
1774	     (setq diml (mapcar #'meval diml))
1775	     (cond ((null diml)
1776		    (wna-err '$array))
1777		   ((> (length diml) 5)
1778		    (merror (intl:gettext "array: number of dimensions must be 5 or less; found: ~M") (length diml)))
1779		   ((member nil (mapcar #'fixnump diml) :test #'eq)
1780		    (merror (intl:gettext "array: all dimensions must be integers."))))
1781	     (setq diml (mapcar #'1+ diml))
1782	     (setq new (if compp fun (gensym)))
1783	     (setf (symbol-array new)
1784	           (make-array diml :initial-element (case compp
1785	                                               (fixnum 0)
1786	                                               (flonum 0.0)
1787	                                               (otherwise munbound))))
1788	     (when (or funp (arrfunp fun))
1789	       (fillarray new (list (if (eq compp 'fixnum) fixunbound flounbound))))
1790	     (cond ((null (setq old (mget fun 'hashar)))
1791		    (mputprop fun new 'array))
1792		   (t (unless (= (aref (symbol-array old) 2) (length diml))
1793			(merror (intl:gettext "array: array ~:M must have ~:M dimensions; found: ~M") fun (aref (symbol-array old) 2) (length diml)))
1794		      (setq ncells (+ 2 (aref (symbol-array old) 0)))
1795		      (do ((n 3 (1+ n)))
1796			  ((> n ncells))
1797			(do ((items (aref (symbol-array old) n) (cdr items)))
1798			    ((null items))
1799			  (do ((x (caar items) (cdr x)) (y diml (cdr y)))
1800			      ((null x)
1801			       (if (and (member compp '(fixnum flonum) :test #'eq)
1802					(not (eq (ml-typep (cdar items)) compp)))
1803				   (merror (intl:gettext "array: existing elements must be ~M; found: ~M") compp (cdar items)))
1804			       (setf (apply #'aref (symbol-array new) (caar items))
1805				     (cdar items)))
1806			    (if (or (not (fixnump (car x)))
1807                                   (< (car x) 0)
1808                                   (not (< (car x) (car y))))
1809				(merror (intl:gettext "array: index must be nonnegative integer less than ~M; found: ~M") (car y) (car x))))))
1810		      (mremprop fun 'hashar)
1811		      (mputprop fun new 'array)))
1812	     (add2lnc fun $arrays)
1813	     (when (eq compp 'fixnum)
1814	       (putprop fun '$fixnum 'array-mode))
1815	     (when (eq compp 'flonum)
1816	       (putprop fun '$float 'array-mode))
1817	     fun))))
1818	(($listp (car x))
1819	 (cons '(mlist) (mapcar #'(lambda (u) (meval `(($array) ,u ,@(cdr x)))) (cdar x))))
1820	(t
1821	 (merror (intl:gettext "array: first argument must be a symbol or a list; found: ~M") (car x)))))
1822
1823
1824(defmfun $show_hash_array (x)
1825  (maphash #'(lambda (k v) (format t "~%~A-->~A" k v)) x))
1826
1827;; If this is T then arrays are stored in the value cell,
1828;; whereas if it is false they are stored in the function cell
1829(defmvar $use_fast_arrays nil)
1830
1831(defun arrstore (l r)
1832	 (let ((fun (caar l)) ary sub (lispsub 0) hashl mqapplyp)
1833	   (cond ((setq ary (mget fun 'array))
1834		  (dimcheck fun (setq sub (mapcar #'meval (cdr l))) t)
1835		  (if (and (member (setq fun (car (arraydims ary))) '(fixnum flonum) :test #'eq)
1836			   (not (eq (ml-typep r) fun)))
1837		      (merror (intl:gettext "assignment: attempt to assign ~M to an array of type ~M.") r fun))
1838		  (setf (apply #'aref (symbol-array ary) sub)  r))
1839		 ((setq ary (mget fun 'hashar))
1840		  (if (not (= (aref (symbol-array ary) 2) (length (cdr l))))
1841		      (merror (intl:gettext "assignment: array ~:M has dimension ~:M, but it was called by ~:M")
1842			      fun (aref (symbol-array ary) 2) l))
1843		  (setq sub (mapcar #'meval (cdr l)))
1844		  (setq hashl (aref (symbol-array ary)
1845				    (setq lispsub (+ 3 (rem (hasher sub)
1846							    (aref (symbol-array ary) 0))))))
1847		  (do ((hashl1 hashl (cdr hashl1)))
1848		      ((null hashl1)
1849		       (cond ((not (eq r munbound))
1850			      (setq sub (ncons (cons sub r)))
1851			      (cond ((null hashl) (setf (aref (symbol-array ary) lispsub) sub))
1852				    (t (nconc hashl sub)))
1853			      (setf (aref (symbol-array ary) 1) (1+ (aref (symbol-array ary) 1))))))
1854		    (cond ((alike (caar hashl1) sub)
1855			   (cond ((eq r munbound) (setf (aref (symbol-array ary) 1)
1856							 (1- (aref (symbol-array ary) 1))))
1857				 (t (nconc hashl (ncons (cons sub r)))))
1858			   (setf (aref (symbol-array ary) lispsub)
1859				  (delete (car hashl1) hashl :count 1 :test #'equal))
1860			   (return nil))))
1861		  (if (> (aref (symbol-array ary) 1) (aref (symbol-array ary) 0))
1862		      (arraysize fun (* 2 (aref (symbol-array ary) 0))))
1863		  r)
1864		 ((and (eq fun 'mqapply) (or (mxorlistp (setq ary (meval (cadr l)))) (arrayp ary))
1865		       (prog2
1866			   (setq mqapplyp t l (cdr l))
1867			   nil)))
1868		 ((and (not mqapplyp)
1869		       (or (not (boundp fun))
1870		           (not (or (mxorlistp (setq ary (symbol-value fun)))
1871		                    (arrayp ary)
1872		                    (typep ary 'hash-table)
1873		                    (eq (type-of ary) 'mgenarray)))))
1874		  (if (member fun '(mqapply $%) :test #'eq) (merror (intl:gettext "assignment: cannot assign to ~M") l))
1875		  (if $use_fast_arrays
1876		    (progn
1877		      ;; (format t "ARRSTORE: use_fast_arrays=true; allocate a new value hash table for ~S~%" fun)
1878		      (meval* `((mset) ,fun ,(make-equal-hash-table (cdr (mevalargs (cdr l)))))))
1879		    (progn
1880		      ;; (format t "ARRSTORE: use_fast_arrays=false; allocate a new property hash table for ~S~%" fun)
1881		  (add2lnc fun $arrays)
1882		  (setq ary (gensym))
1883		  (mputprop fun ary 'hashar)
1884		  (setf (symbol-array ary) (make-array 7 :initial-element nil))
1885		  (setf (aref (symbol-array ary) 0) 4)
1886		  (setf (aref (symbol-array ary) 1) 0)
1887		  (setf (aref (symbol-array ary) 2) (length (cdr l)))))
1888		  (arrstore l r))
1889	         ((or (arrayp ary)
1890	              (typep ary 'hash-table)
1891	              (eq (type-of ary) 'mgenarray))
1892		  (arrstore-extend ary (mevalargs (cdr l)) r))
1893		 ((or (eq (caar ary) 'mlist) (= (length l) 2))
1894		  (cond ((eq (caar ary) '$matrix)
1895			 (cond ((or (not ($listp r)) (not (= (length (cadr ary)) (length r))))
1896				(merror (intl:gettext "assignment: matrix row must be a list, and same length as first row;~%found:~%~M") r))))
1897			((not (= (length l) 2))
1898			 (merror (intl:gettext "assignment: matrix row must have one index; found: ~M") (cons '(mlist) (cdr l)))))
1899		  (let ((index (meval (cadr l))))
1900		    (cond ((not (fixnump index))
1901			   (merror (intl:gettext "assignment: matrix row index must be an integer; found: ~M") index))
1902			  ((and (> index 0) (< index (length ary)))
1903			   (rplaca (nthcdr (1- index) (cdr ary)) r))
1904			  (t (merror (intl:gettext "assignment: matrix row index ~A out of range.") index))))
1905		  r)
1906		 (t (if (not (= (length l) 3))
1907			(merror (intl:gettext "assignment: matrix must have two indices; found: ~M") (cons '(mlist) (cdr l))))
1908		    ($setelmx r (meval (cadr l)) (meval (caddr l)) ary)
1909		    r))))
1910
1911(defun arrfunp (x)
1912  (or (and $transrun (getl x '(a-expr))) (mgetl x '(aexpr))))
1913
1914(defun arrfuncall (arrfun subs form)
1915  (let ((aexprp t))
1916    (case (car arrfun)
1917      (aexpr (mapply1 (cadr arrfun) subs (cadr arrfun) form))
1918      (a-expr (apply (cadr arrfun) subs))
1919      (a-subr (apply (cadr arrfun) subs)))))
1920
1921(defun hasher (l)  ; This is not the best way to write a hasher.  But,
1922  (if (null l)	   ; please don't change this code or you're liable to
1923      0					; break SAVE files.
1924      (logand #o77777
1925	      (let ((x (car l)))
1926		(cond (($ratp x) (merror (intl:gettext "hash function: cannot hash a special expression (CRE or Taylor).")))
1927		      ((or (fixnump x) (floatp x))
1928		       (+ (if (fixnump x) x (floor (+ x 5e-4)))
1929			   (* 7 (hasher (cdr l)))))
1930		      ((atom x) (+ (sxhash x) (hasher (cdr l))))
1931		      (t (+ 1 (sxhash (caar x)) (hasher (cdr x))
1932			     (hasher (cdr l)))))))))
1933
1934(defun arraysize (fun n)
1935  (prog (old new indx ncells cell item i y)
1936     (setq old (symbol-array (mget fun 'hashar)))
1937     (setq new (gensym))
1938     (mputprop fun new 'hashar)
1939     (setf (symbol-array new) (make-array (+ n 3) :initial-element nil))
1940     (setq new (symbol-array new))
1941     (setf (aref new 0) n)
1942     (setf (aref new 1) (aref old 1))
1943     (setf (aref new 2) (aref old 2))
1944     (setq indx 2 ncells (+ 2 (aref old 0)))
1945     a    (if (> (setq indx (1+ indx)) ncells) (return t))
1946     (setq cell (aref old indx))
1947     b    (if (null cell) (go a))
1948     (setq i (+ 3 (rem (hasher (car (setq item (car cell)))) n)))
1949     (if (setq y (aref new i))
1950	 (nconc y (ncons item))
1951	 (setf (aref new i) (ncons item)))
1952     (setq cell (cdr cell))
1953     (go b)))
1954
1955(defun dimcheck (ary sub fixpp)
1956  (do ((x sub (cdr x))
1957       (ret t)
1958       (y (cdr (arraydims (mget ary 'array))) (cdr y)))
1959      ((null y)
1960       (if x (merror (intl:gettext "Array ~:M has dimensions ~:M, but was called with ~:M")
1961		     ary
1962		     `((mlist) ,@(mapcar #'1- (cdr (arraydims (mget ary 'array)))))
1963		     `((mlist) ,@sub))
1964	   ret))
1965    (cond ((or (null x) (and (fixnump (car x)) (or (< (car x) 0) (not (< (car x) (car y))))))
1966	   (setq y nil x (cons nil t)))
1967	  ((not (fixnump (car x)) )
1968	   (if fixpp (setq y nil x (cons nil t)) (setq ret nil))))))
1969
1970(defun constlam (x &aux (lam x))
1971  (if aexprp
1972      `(,(car lam) ,(cadr lam) ,@(mbinding ((mparams (cadr lam)))
1973					   (mapcar #'meval (cddr lam))))
1974
1975      lam))
1976
1977(defmspec $define (l)
1978  (twoargcheck l)
1979  (setq l (cdr l))
1980  (meval `((mdefine)
1981	   ,(cond ((mquotep (car l)) (cadar l))
1982		  ((and (not (atom (car l)))
1983			(member (caaar l) '($ev $funmake $arraymake) :test #'eq))
1984		   (meval (car l)))
1985		  (t (disp2 (car l))))
1986	   ,(meval (cadr l)))))
1987
1988(defun set-lineinfo (fnname lineinfo body)
1989  (cond ((and (consp lineinfo) (eq 'src (third lineinfo)))
1990	 (setf (cdddr lineinfo) (list fnname (first lineinfo)))
1991	 (setf (get fnname 'lineinfo) body))
1992	(t (remprop fnname 'lineinfo))))
1993
1994(defmspec mdefine (l )
1995  (let ($use_fast_arrays) ;;for mdefine's we allow use the oldstyle hasharrays
1996    (twoargcheck l)
1997    (setq l (cdr l))
1998    (let ((fun (car l)) (body (cadr l)) args subs ary fnname mqdef)
1999      (cond ((or (atom fun)
2000		 (and (setq mqdef (eq (caar fun) 'mqapply))
2001		      (member 'array (cdar fun) :test #'eq)))
2002	     (merror (intl:gettext "define: argument cannot be an atom or a subscripted memoizing function; found: ~M") fun))
2003	    (mqdef (if (or (atom (cadr fun))
2004			   (not (setq ary (member 'array (cdaadr fun) :test #'eq))))
2005		       (merror (intl:gettext "define: expected a subscripted expression; found: ~M") (cadr fun)))
2006		   (setq subs (cdadr fun) args (cddr fun) fun (cadr fun)
2007			 fnname (caar fun))
2008		   (if (and (not (mgetl fnname '(hashar array)))
2009			    (get fnname 'specsimp))
2010		       (mtell (intl:gettext "define: warning: redefining built-in subscripted function ~:M~%")
2011			      fnname)))
2012	    ((prog2 (setq fnname (caar fun))
2013		 (or (mopp fnname) (member fnname '($all $allbut $%) :test #'eq)))
2014	     (merror (intl:gettext "define: function name cannot be a built-in operator or special symbol; found: ~:@M") fnname))
2015	    ((setq ary (member 'array (cdar fun) :test #'eq)) (setq subs (cdr fun)))
2016	    (t
2017	     (setq args (cdr fun))
2018	     (mredef-check fnname)))
2019      (if (not ary) (remove1 (ncons fnname) 'mmacro t $macros t))
2020      (mdefchk fnname (or args (and (not mqdef) subs)) ary mqdef)
2021      (if (not (eq fnname (caar fun))) (rplaca (car fun) fnname))
2022      (cond ((not ary) (if (and evp (member fnname (car loclist) :test #'eq))
2023			   (mputprop fnname t 'local-fun)
2024			   (remove-transl-fun-props fnname))
2025	     (add2lnc (cons (ncons fnname) args) $functions)
2026	     (set-lineinfo fnname (cadar fun) body)
2027	     (mputprop fnname (mdefine1 args body) 'mexpr)
2028	     (if $translate (translate-function fnname)))
2029	    ((prog2 (add2lnc fnname $arrays)
2030	       (setq ary (mgetl fnname '(hashar array)))
2031	       (remove-transl-array-fun-props fnname))
2032	     (if (not (= (if (eq (car ary) 'hashar)
2033			     (aref (symbol-array (cadr ary)) 2)
2034			     (length (cdr (arraydims (cadr ary)))))
2035			 (length subs)))
2036		 (merror (intl:gettext "define: ~:M already defined with different number of subscripts.")
2037			 fnname))
2038	     (mdefarray fnname subs args body mqdef))
2039	    (t
2040	     (setq ary (gensym))
2041	     (mputprop fnname ary 'hashar)
2042	     (setf (symbol-array ary) (make-array 7 :initial-element nil))
2043	     (setf (aref (symbol-array ary) 0) 4)
2044	     (setf (aref (symbol-array ary) 1) 0)
2045	     (setf (aref (symbol-array ary) 2) (length subs))
2046	     (mdefarray fnname subs args body mqdef)))
2047      (cons '(mdefine simp) (copy-list l)))))
2048
2049;; Checks to see if a user is clobbering the name of a system function.
2050;; Prints a warning and returns T if he is, and NIL if he isn't.
2051(defun mredef-check (fnname)
2052  (when (and (not (mget fnname 'mexpr))
2053	     (or (and (or (get fnname 'autoload)
2054			  (getl-lm-fcn-prop fnname '(subr)))
2055		      (not (get fnname 'translated)))
2056		 (mopp fnname)))
2057    (format t (intl:gettext "define: warning: redefining the built-in ~:[function~;operator~] ~a~%")
2058	    (getl fnname '(verb operators))
2059	    (print-invert-case (stripdollar fnname)))
2060    t))
2061
2062(defun mdefarray (fun subs args body mqdef)
2063  (when (hash-table-p fun)
2064    ;; PRETTY SURE THIS NEXT MESSAGE IS UNREACHABLE (FUN IS ALWAYS A SYMBOL FROM WHAT I CAN TELL) !!
2065    (error "~a is already a hash table.  Make it a function first" fun))
2066  (cond ((and (null args) (not mqdef)) (mputprop fun (mdefine1 subs body) 'aexpr))
2067	((null (dolist (u subs)
2068		 (unless (or (consp u) ($constantp u) (stringp u))
2069		     (return t))))
2070	 (arrstore (cons (ncons fun) subs) (mdefine1 args body)))
2071	(t (mdefchk fun subs t nil)
2072	   (mputprop fun (mdefine1 subs (mdefine1 args body)) 'aexpr))))
2073
2074(defun mspecfunp (fun)
2075  (and (or (getl-lm-fcn-prop fun '(macro))
2076	   (getl fun '(mfexpr*))
2077	   (and $transrun (get fun 'translated-mmacro))
2078	   (mget fun 'mmacro))
2079       (not (get fun 'evok))))
2080
2081(defun mdefine1 (args body)
2082  (list '(lambda) (cons '(mlist) args) body))
2083
2084(defun mdefchk (fun args ary mqdef)
2085  (let ((dup (find-duplicate args :test #'eq :key #'mparam)))
2086    (when dup
2087      (merror (intl:gettext "define: ~M occurs more than once in the parameter list") (mparam dup))))
2088  (do ((l args (cdr l)) (mfex) (mlex))
2089      ((null l) (and mfex (not mqdef) (mputprop fun mfex 'mfexprp))
2090       (and mlex (not mqdef) (mputprop fun mlex 'mlexprp)))
2091    (if (not (or (mdefparam (car l))
2092		 (and (or (not ary) mqdef)
2093		      (or (and mfexprp (mquotep (car l))
2094			       (mdefparam (cadar l)) (setq mfex t))
2095			  (and (mdeflistp l)
2096			       (or (mdefparam (cadar l))
2097				   (and mfexprp (mquotep (cadar l))
2098					(mdefparam (cadr (cadar l)))
2099					(setq mfex t)))
2100			       (setq mlex t))))))
2101	(merror (intl:gettext "define: in definition of ~:M, parameter must be a symbol and must not be a system constant; found: ~M") fun (car l)))))
2102
2103(defun mdefparam (x)
2104  (and (symbolp x) (not (get x 'sysconst))))
2105
2106(defun mdeflistp (l)
2107  (and (null (cdr l)) ($listp (car l)) (cdar l) (null (cddar l))))
2108
2109(defun mopp (fun)
2110  (and (not (eq fun 'mqapply))
2111       (or (mopp1 fun)
2112	   (and (get fun 'operators) (not (rulechk fun))
2113		(not (member fun rulefcnl :test #'eq)) (not (get fun 'opers))))))
2114
2115(defun mopp1 (fun)
2116  (and (setq fun (get fun 'op)) (not (member fun (cdr $props) :test #'eq))))
2117
2118;; maybe should have a separate version, or a macro..
2119(defun mapply (a b c)
2120  (mapply1 a b c nil))
2121
2122(defmfun $apply (fun arg)
2123  (unless ($listp arg)
2124    (merror (intl:gettext "apply: second argument must be a list; found: ~M") arg))
2125  (let ((fun-opr (getopr fun)))
2126    (autoldchk fun-opr)
2127    (mapply1 fun-opr (cdr arg) fun `(($apply) ,fun ,arg))))
2128
2129(defun autoldchk (fun)
2130  (if (and (symbolp fun)
2131	   (get fun 'autoload)
2132	   (not (or (fboundp fun) (mfboundp fun))))
2133      (load-function fun t)))
2134
2135(defmspec $dispfun (l)
2136  (setq l (cdr l))
2137  (cond ((or (cdr l) (not (eq (car l) '$all))) (dispfun1 l nil nil))
2138	(t
2139	 `((mlist simp)
2140	   ,@(apply #'append
2141		    (list (cdr (dispfun1 (cdr $functions) t nil))
2142			  (cdr (dispfun1
2143				(mapcan #'(lambda (x) (if (mget x 'aexpr) (ncons x)))
2144					(cdr $arrays)) nil t))
2145			  (cdr (dispfun1 (cdr $macros) t nil))))))))
2146
2147(defun dispfun1 (l flag maexprp)
2148  `((mlist simp)
2149    ,@(loop for fun in l collect
2150	    (cadr ($ldisp (consfundef (if flag (caar fun) fun) maexprp nil))))))
2151
2152(defmspec $fundef (x)
2153  (consfundef (fexprcheck x) nil nil))
2154
2155(defun consfundef (x maexprp stringp)
2156  (prog (arryp name fun)
2157     (setq arryp (and (not (atom x)) (not (eq (caar x) 'mqapply)) (member 'array (cdar x) :test #'eq)))
2158     (cond ((atom x) (setq name (if (stringp x) ($verbify x) x)
2159			   fun (or (and (not maexprp) (mgetl name '(mexpr mmacro)))
2160				   (mgetl name '(aexpr)))))
2161	   (arryp (setq fun (meval1 (setq name (cons (list (caar x) 'array) (cdr x)))))
2162		  (if (or (atom fun) (not (eq (caar fun) 'lambda))) (setq fun nil))))
2163     (cond ((not fun)
2164            (when stringp
2165              (return x))
2166            (merror (intl:gettext "fundef: no such function: ~:M") x)))
2167     (return
2168       (cons (if (eq (car fun) 'mmacro) '(mdefmacro simp) '(mdefine simp))
2169	     (cond (arryp (cons (cons '(mqapply) (cons name (cdadr fun))) (cddr fun)))
2170		   (t (funcall #'(lambda (body)
2171				   (cond ((and (eq (car fun) 'aexpr) (not (atom body))
2172					       (eq (caar body) 'lambda))
2173					  (list (cons '(mqapply) (cons (cons (cons name '(array))
2174									     (cdr (cadadr fun)))
2175								       (cdadr body)))
2176						(caddr body)))
2177					 (t (list (cons (cons name (if (eq (car fun) 'aexpr) '(array)))
2178							(cdr (cadadr fun)))
2179						  body))))
2180			       (caddr (cadr fun)))))))))
2181
2182
2183(defmfun $funmake (fun args)
2184  (if (not (or (stringp fun) (symbolp fun) ($subvarp fun)
2185	       (and (not (atom fun)) (eq (caar fun) 'lambda))))
2186      (merror (intl:gettext "funmake: first argument must be a symbol, subscripted symbol, string, or lambda expression; found: ~M") fun))
2187  (if (not ($listp args)) (merror (intl:gettext "funmake: second argument must be a list; found: ~M") args))
2188  (mcons-op-args (getopr fun) (cdr args)))
2189
2190(defun mcons-op-args (op args)
2191  (if (symbolp op)
2192      (cons (ncons op) args)
2193      (list* '(mqapply) op args)))
2194
2195(defun optionp (x)
2196  (and (boundp x)
2197       (not (member x (cdr $values) :test #'eq))
2198       (not (member x (cdr $labels) :test #'eq))))
2199
2200(defmspec mcond (form)
2201  (setq form (cdr form))
2202  (do ((u form (cddr u)) (v))
2203      ((null u) nil)
2204    (cond ((eq (setq v (mevalp (car u))) t) (return (meval (cadr u))))
2205	  (v (return (list* '(mcond) v (mapcar #'meval-atoms (cdr u))))))))
2206
2207(defun meval-atoms (form)
2208  (cond ((atom form) (meval1 form))
2209	((eq (caar form) 'mquote) (cadr form))
2210	((and (getl (caar form) '(mfexpr*))
2211	      (not (member (caar form) '(mcond mand mor mnot mprogn mdo mdoin) :test #'eq)))
2212	 form)
2213	(t (recur-apply #'meval-atoms form))))
2214
2215(defmspec mdo (form)
2216  (setq form (cdr form))
2217  (let ((mdop t) (my-var (or (car form) 'mdo)) my-step next test do-body)
2218    (setq my-step (if (caddr form) (meval (caddr form)) 1)
2219          next (or (cadddr form) (list '(mplus) my-step my-var))
2220          test (list '(mor)
2221                     (cond ((null (car (cddddr form))) nil)
2222                           (t (list (if (mnegp ($numfactor my-step))
2223                                      '(mlessp)
2224                                      '(mgreaterp))
2225                                    my-var (car (cddddr form)))))
2226                     (cadr (cddddr form)))
2227          do-body (caddr (cddddr form)))
2228    (mbinding ((ncons my-var)
2229               (ncons (if (null (cadr form)) 1 (meval (cadr form)))))
2230              (do ((val) (bindl bindlist))
2231                ((is test) '$done)
2232                (cond ((null (setq val (catch 'mprog (prog2 (meval do-body) nil))))
2233                       (mset my-var (meval next)))
2234                      ((atom val) (merror (intl:gettext "do loop: 'go' not within 'block': ~M") val))
2235                      ((not (eq bindl bindlist))
2236                       (merror (intl:gettext "do loop: illegal 'return': ~M") (car val)))
2237                      (t (return (car val))))))))
2238
2239(defmspec mdoin (form)
2240  (setq form (cdr form))
2241  (funcall #'(lambda  (mdop my-var set test action)
2242	       (setq set (if ($atom (setq set (format1 (meval (cadr form)))))
2243			     (merror (intl:gettext "do loop: 'in' argument must be a nonatomic expression; found: ~M") set)
2244			     (margs set))
2245		     test (list '(mor)
2246				(if (car (cddddr form))
2247				    (list '(mgreaterp) my-var (car (cddddr form))))
2248				(cadr (cddddr form)))
2249		     action (caddr (cddddr form)))
2250	       (cond ((atom set) '$done)
2251		     (t (mbinding ((ncons my-var) (ncons (car set)))
2252				  (do ((val) (bindl bindlist))
2253				      ((or (atom set) (is test))
2254				       '$done)
2255				    (cond ((null (setq val (catch 'mprog (prog2 (meval action) nil))))
2256					   (if (setq set (cdr set)) (mset my-var (car set))))
2257					  ((atom val) (merror (intl:gettext "do loop: 'go' not within 'block': ~M") val))
2258					  ((not (eq bindl bindlist))
2259					   (merror (intl:gettext "do loop: illegal 'return': ~M") (car val)))
2260					  (t (return (car val)))))))))
2261	   t (or (car form) 'mdo) nil nil nil))
2262
2263(defmspec mprog (prog)
2264  (setq prog (cdr prog))
2265  (let (vars vals (mlocp t))
2266    (if ($listp (car prog)) (setq vars (cdar prog) prog (cdr prog)))
2267    (do ((l vars (cdr l))) ((null l) (setq vals vars))
2268      (if (not (atom (car l))) (return (setq vals t))))
2269    (if (eq vals t)
2270	(setq vals (mapcar #'(lambda (v)
2271			       (cond ((atom v) v)
2272				     ((eq (caar v) 'msetq) (meval (caddr v)))
2273				     (t (merror
2274					 (intl:gettext "block: variable list must comprise only atoms and assignment expressions; found: ~M")
2275					 v))))
2276			   vars)
2277	      vars (mapcar #'(lambda (v) (if (atom v) v (cadr v))) vars)))
2278    (let ((dup (find-duplicate vars :test #'eq)))
2279      (when dup
2280        (merror (intl:gettext "block: ~M occurs more than once in the variable list") dup)))
2281    (setq loclist (cons nil loclist))
2282    ; Ensure that MUNLOCAL gets called so that we don't leak local
2283    ; properties if we run into an error
2284    (unwind-protect
2285	(mbinding (vars vals)
2286		  (do ((prog prog (cdr prog)) (mprogp prog)
2287		       (bindl bindlist) (val '$done) (retp) (x) ($%% '$%%))
2288		      ((null prog) val)
2289		    (cond ((atom (car prog))
2290			   (if (null (cdr prog))
2291			       (setq retp t val (meval (car prog)))))
2292			  ((null (setq x (catch 'mprog
2293					   (prog2 (setq val (setq $%% (meval (car prog))))
2294					       nil)))))
2295			  ((not (eq bindl bindlist))
2296			   (if (not (atom x))
2297			       ;; DUNNO WHAT'S "ILLEGAL" HERE
2298			       (merror (intl:gettext "block: illegal 'return': ~M") (car x))
2299			       ;; DUNNO WHAT'S "ILLEGAL" HERE
2300			       (merror (intl:gettext "block: illegal 'go': ~M") x)))
2301			  ((not (atom x)) (setq retp t val (car x)))
2302			  ((not (setq prog (member x mprogp :test #'equal)))
2303			   (merror (intl:gettext "block: no such tag: ~:M") x)))
2304		    (if retp (setq prog '(nil)))))
2305      (munlocal))))
2306
2307(defun mreturn (&optional (x nil) &rest args)
2308  (cond
2309    ((not (null args))
2310       (merror (intl:gettext "return: too many arguments; found: ~M") `((mlist) ,x ,@args) ))
2311    ((and (not mprogp) (not mdop))
2312       (merror (intl:gettext "return: not within 'block'")))
2313    (t (throw 'mprog (ncons x)) ) ))
2314
2315(defmspec mgo (tag)
2316  (setq tag (fexprcheck tag))
2317  (cond ((not mprogp) (merror (intl:gettext "go: not within 'block'")))
2318	((atom tag) (throw 'mprog tag))
2319	(t (merror (intl:gettext "go: argument must be an atom; found: ~M") tag))))
2320
2321(defmspec $subvar (l)
2322  (setq l (cdr l))
2323  (if (null l)
2324      (wna-err '$subvar))
2325  (meval (cons '(mqapply array) l)))
2326
2327(defun rat (x y)
2328  `((rat simp) ,x ,y))
2329
2330(defun add2lnc (item llist)
2331  (unless (memalike item (if ($listp llist) (cdr llist) llist))
2332    (unless (atom item)
2333      (setf llist (delete (assoc (car item) llist :test #'equal) llist :count 1 :test #'equal)))
2334    (nconc llist (ncons item))))
2335
2336(defun bigfloatm* (bf)
2337  (unless (member 'simp (cdar bf) :test #'eq)
2338    (setq bf (cons (list* (caar bf) 'simp (cdar bf)) (cdr bf))))
2339  (if $float ($float bf) bf))
2340
2341(defmfun $allbut (&rest args)
2342  (cons '($allbut) args))
2343
2344(defquote dsksetq (&rest l)
2345  (let ((dsksetp t))
2346    (mset (car l) (eval (cadr l)))))
2347
2348(defun dskrat (x)
2349  (orderpointer (caddar x))
2350  (mapc #'(lambda (a b) (dskrat-subst a b (cddddr (car x))) ; for TAYLOR forms
2351		  (dskrat-subst a b (cdr x)))
2352	genvar (cadddr (car x)))
2353  (rplaca (cdddar x) genvar)
2354  (if (member 'trunc (car x) :test #'eq)
2355      (srconvert x) x))			; temporary
2356
2357(defun dskrat-subst (x y z)
2358  (cond ((atom z) z)
2359	(t (if (eq y (car z)) (rplaca z x) (dskrat-subst x y (car z)))
2360	   (dskrat-subst x y (cdr z))
2361	   z)))
2362
2363(defun |''MAKE-FUN| (noun-name x)
2364  (simplifya (list (ncons noun-name) (resimplify x)) t))
2365
2366(macrolet ((|''MAKE| (fun noun)
2367	     `(defun ,fun (x) (|''MAKE-FUN| ',noun x))))
2368  (|''MAKE| $log %log)
2369  (|''MAKE| $sin %sin) (|''MAKE| $cos %cos) (|''MAKE| $tan %tan)
2370  (|''MAKE| $cot %cot) (|''MAKE| $sec %sec) (|''MAKE| $csc %csc)
2371  (|''MAKE| $sinh %sinh) (|''MAKE| $cosh %cosh) (|''MAKE| $tanh %tanh)
2372  (|''MAKE| $coth %coth) (|''MAKE| $sech %sech) (|''MAKE| $csch %csch)
2373  (|''MAKE| $asin %asin) (|''MAKE| $acos %acos) (|''MAKE| $atan %atan)
2374  (|''MAKE| $acot %acot) (|''MAKE| $asec %asec) (|''MAKE| $acsc %acsc)
2375  (|''MAKE| $asinh %asinh) (|''MAKE| $acosh %acosh) (|''MAKE| $atanh %atanh)
2376  (|''MAKE| $acoth %acoth) (|''MAKE| $asech %asech) (|''MAKE| $acsch %acsch)
2377  (|''MAKE| $round %round) (|''MAKE| $truncate %truncate) (|''MAKE| $plog %plog)
2378  (|''MAKE| $signum %signum) (|''MAKE| $gamma %gamma))
2379
2380;; evfun properties
2381(mapc #'(lambda (x) (putprop x t 'evfun))
2382      '($radcan $factor $ratsimp $trigexpand $trigreduce $logcontract
2383	$rootscontract $bfloat $ratexpand $fullratsimp $rectform $polarform))
2384
2385;; evflag properties
2386(mapc #'(lambda (x) (putprop x t 'evflag))
2387      '($exponentialize $%emode $demoivre $logexpand $logarc
2388	$radexpand $keepfloat $listarith $float $ratsimpexpons $ratmx
2389	$simp $simpsum $simpproduct $algebraic $ratalgdenom $factorflag $ratfac
2390	$infeval $%enumer $programmode $lognegint $logabs $letrat
2391	$halfangles $exptisolate $isolate_wrt_times $sumexpand
2392	$cauchysum $numer_pbranch $m1pbranch $dotscrules $trigexpand))
2393
2394;;; Float constants, to 2048 bits of precision.
2395;;; (EXP 1)
2396(mdefprop $%e     2.7182818284590452353602874713526624977572470936999595749669676277240766303535475945713821785251664274274663919320030599218174135966290435729003342952605956307381323286279434907632338298807531952510190115738341879307021540891499348841675092447614606680822648001684774118537423454424371075390777449920695517027618386062613313845830007520449338265602976067371132007093287091274437470472306969772093101416928368190255151086574637721112523897844250569536967707854499699679468644549059879316368892300987931277361782154249992295763514822082698951936680331825288693984964651058209392398294887933203625094431173012381970684161404
2397	  $numer)
2398;;; (ATAN 0 -1)
2399(mdefprop $%pi    3.1415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019091456485669234603486104543266482133936072602491412737245870066063155881748815209209628292540917153643678925903600113305305488204665213841469519415116094330572703657595919530921861173819326117931051185480744623799627495673518857527248912279381830119491298336733624406566430860213949463952247371907021798609437027705392171762931767523846748184676694051320005681271452635608
2400	  $numer)
2401;;; (1+sqrt(5))/2
2402(mdefprop $%phi   1.6180339887498948482045868343656381177203091798057628621354486227052604628189024497072072041893911374847540880753868917521266338622235369317931800607667263544333890865959395829056383226613199282902678806752087668925017116962070322210432162695486262963136144381497587012203408058879544547492461856953648644492410443207713449470495658467885098743394422125448770664780915884607499887124007652170575179788341662562494075890697040002812104276217711177780531531714101170466659914669798731761356006708748071013179523689427521948435305678300228785699782977834784587822891109762500302696156170025046433824377648610283831268330372
2403	  $numer)
2404;;; Euler's constant
2405(mdefprop $%gamma 0.57721566490153286060651209008240243104215933593992359880576723488486772677766467093694706329174674951463144724980708248096050401448654283622417399764492353625350033374293733773767394279259525824709491600873520394816567085323315177661152862119950150798479374508570574002992135478614669402960432542151905877553526733139925401296742051375413954911168510280798423487758720503843109399736137255306088933126760017247953783675927135157722610273492913940798430103417771778088154957066107501016191663340152278935867965497252036212879226555953669628176388792726801324310104765059637039473949576389065729679296010090151251959509223
2406	  $numer)
2407
2408(mdefprop $herald_package (nil $transload t) $props)
2409(mdefprop $load_package (nil $transload t) $props)
2410
2411(defprop bigfloat bigfloatm* mfexpr*)
2412(defprop lambda constlam mfexpr*)
2413(defprop quote cadr mfexpr*)		; Needed by MATCOM/MATRUN.
2414
2415(eval-when
2416    #+gcl (compile eval)
2417    #-gcl (:compile-toplevel :execute)
2418
2419    (setq  *read-base* *old-read-base*))
2420