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