|
Warning: this is an htmlized version!
The original is here, and the conversion rules are here. |
;; This file:
;; http://anggtwu.net/MAXIMA/2025-meval1.lisp.html
;; http://anggtwu.net/MAXIMA/2025-meval1.lisp
;; (find-angg "MAXIMA/2025-meval1.lisp")
;; Author: Eduardo Ochs <eduardoochs@gmail.com>
;;
;; (defun e () (interactive) (find-angg "MAXIMA/2025-meval1.lisp"))
;; (find-es "maxima" "hash-assign")
;; (find-maximagitfile "src/ar.lisp" "(defun marrayset-gensub ")
;; (find-maximagitfile "src/mlisp.lisp" "(defun meval1 ")
;; (find-maximagitfile "src/mlisp.lisp" "(defun meval ")
;; (find-maximagitfile "src/suprv1.lisp" "(defun meval* ")
;; (find-maximagitfile "src/mlisp.lisp" "(defun arrstore ")
(in-package :maxima)
(declaim (notinline safe-get safe-getl))
;; Original: (find-maximagitfile "src/clmacs.lisp" "(defun safe-get ")
(defun safe-get (sym prop)
(and (symbolp sym) (get sym prop)))
;; Original: (find-maximagitfile "src/clmacs.lisp" "(defun safe-getl ")
(defun safe-getl (sym prop)
(declare (optimize (debug 3)))
(and (symbolp sym) (getl sym prop)))
;; Original: (find-maximagitfile "src/mlisp.lisp" "(defun meval1 ")
(defun meval1 (form)
(declare (special *nounl* *break-points* *break-step*))
(declare (optimize (debug 3)))
(cond
((atom form)
(prog (val)
(cond ((not (symbolp form)) (return form))
((and $numer
(setq val (safe-mget form '$numer))
(or (not (eq form '$%e)) $%enumer))
(return (meval1 val)))
((not (boundp form))
(let ((bindtest-value (safe-get form 'bindtest)))
(cond ((eq bindtest-value :deprecated)
;; Variable is deprecated. Print a warning,
;; and set the value of the variable so it can
;; still be used.
;;
;; TODO? Should we now remove the 'bindtest
;; property and also the entry in
;; *bindtest-messages*? It doesn't usually
;; matter, since we won't reach this again,
;; unless someone goes and makes the variable
;; unbound. Not changing this allows for
;; easier debugging by just manually making the
;; variable unbound again.
(let ((info (cdr (assoc form *bindtest-deprecation-messages* :test 'eq))))
;; Just throw an error if something is messed
;; up with deprecation.
(unless info
(merror
(intl:gettext "Internal error: Deprecated variable ~M but no corresponding information found.")
form))
;; Extract the info, and issue the warning,
;; and bind the value to the variable.
(destructuring-bind (msg . val)
info
(mwarning (aformat nil (intl:gettext msg) form))
(setf (symbol-value form) val))))
(bindtest-value
(merror (intl:gettext "evaluation: unbound variable ~:M")
form))
(t
(return form)))))
)
(setq val (symbol-value form))
(when (and $refcheck
(member form (cdr $values) :test #'eq)
(not (member form *refchkl* :test #'eq)))
(setq *refchkl* (cons form *refchkl*))
(mtell (intl:gettext "evaluation: ~:M has the value ~:M.~%") form val))
(return val)))
((or (and (atom (car form))
(setq form (cons (ncons (car form)) (cdr form))))
(atom (caar form)))
(let (transp)
(prog (u aryp)
(setq *last-meval1-form* form)
(setq aryp (member 'array (cdar form) :test #'eq))
(cond ((and (not aryp)
(member (caar form)
'(mplus mtimes mexpt mnctimes) :test #'eq))
(go c))
((and *mdebug*
(progn
;; if wanting to step, the *break-points*
;; variable will be set to a vector (possibly empty).
(when (and *break-points*
(or (null *break-step*)
(null (funcall *break-step* form))))
(let ((ar *break-points*))
(declare (type (vector t) ar))
(loop for i below (fill-pointer ar)
when (eq (car (aref ar i)) form)
do (*break-points* form)
(loop-finish))))
nil)))
((eq (caar form) 'mqapply) (return (mqapply1 form))))
(badfunchk (caar form) (caar form) nil)
a
(setq u
(or (safe-getl (caar form) '(noun))
(and *nounsflag*
(and (symbolp (caar form)) (char= (get-first-char (caar form)) #\%))
(not (or (getl-lm-fcn-prop (caar form) '(subr))
(safe-getl (caar form) '(mfexpr*))))
(prog2 ($verbify (caar form))
(safe-getl (caar form) '(noun))))
(and (not aryp)
$transrun
(setq transp
(safe-getl (caar form) '(translated-mmacro))))
(and (not aryp)
(setq u
(or (safe-mget (caar form) 'trace)
(and $transrun
(safe-get (caar form) 'translated)
(not (safe-mget (caar form) 'local-fun))
(setq transp t)
(caar form))))
(getl-lm-fcn-prop u '(subr mfexpr)))
(cond (aryp (safe-mgetl (caar form) '(hashar array)))
((safe-mgetl (caar form) '(mexpr mmacro)))
(t
(or (safe-getl (caar form) '(mfexpr*)) ; here
(getl-lm-fcn-prop (caar form) '(subr macro)))))))
(when (null u) (go b))
(return
(cond ((eq (car u) 'hashar)
(harrfind (cons (car form) (mevalargs (cdr form)))))
((eq (car u) 'subr)
(apply (caar form) (mevalargs (cdr form))))
((eq (car u) 'noun)
(cond ((or (member (caar form) *nounl* :test #'eq) *nounsflag*)
(setq form (cons (cons (cadr u) (cdar form))
(cdr form)))
(go a))
(aryp (go b))
((member (caar form) '(%sum %product) :test #'eq)
(setq u (do%sum (cdr form) (caar form))
noevalargs nil)
(cons (ncons (caar form)) u))
(t (meval2 (mevalargs (cdr form)) form))))
((eq (car u) 'array)
(arrfind (cons (car form) (mevalargs (cdr form)))))
((eq (car u) 'mexpr)
(mlambda (cadr u) (cdr form) (caar form) noevalargs form))
((member (car u) '(mmacro translated-mmacro) :test #'eq)
(setq noevalargs nil)
(meval (mmacro-apply (cadr u) form)))
((eq (car u) 'mfexpr*)
(setq noevalargs nil)
(apply (cadr u) (ncons form)))
((eq (car u) 'mfexpr)
(mlambda (cadr u) (cdr form) (caar form) noevalargs form))
((eq (car u) 'macro)
(setq noevalargs nil)
(setq form (cons(caar form) (cdr form)))
(eval form))
(t
(apply (cadr u) (mevalargs (cdr form))))))
b
(if (and (not aryp) (load-function (caar form) t)) (go a))
(badfunchk (caar form) (caar form) nil)
(if (symbolp (caar form))
(setq u (boundp (caar form)))
(return (meval1-extend form)))
c
(cond ((or (null u)
(and (safe-get (caar form) 'operators) (not aryp))
(eq (caar form) (setq u (symbol-value (caar form)))))
(setq form (meval2 (mevalargs (cdr form)) form))
(return (or (and (safe-mget (caar form) 'atvalues)
(at1 form))
form)))
((and aryp
(safe-get (caar form) 'nonarray))
(return (cons (cons (caar form) aryp)
(mevalargs (cdr form)))))
((atom u)
(badfunchk (caar form) u nil)
(setq form (cons (cons (getopr u) aryp) (cdr form)))
(go a))
((eq (caar u) 'lambda)
(if aryp
(merror (intl:gettext "lambda: cannot apply lambda as an array function."))
(return (mlambda u (cdr form)
(caar form) noevalargs form))))
(t
(return
(mapply1 u (mevalargs (cdr form)) (caar form) form)))))))
(t
(mapply1 (caar form) (mevalargs (cdr form)) (caar form) form))))
;; Original: (find-maximagitfile "src/mlisp.lisp" "(defun arrstore ")
(defun arrstore (l r)
(declare (optimize (debug 3)))
(let ((fun (caar l)) ary sub (lispsub 0) hashl mqapplyp)
(cond ((setq ary (mget fun 'array))
(dimcheck fun (setq sub (mapcar #'meval (cdr l))) t)
(if (and (member (setq fun (car (arraydims ary))) '(fixnum flonum) :test #'eq)
(not (eq (ml-typep r) fun)))
(merror (intl:gettext "assignment: attempt to assign ~M to an array of type ~M.") r fun))
(setf (apply #'aref (symbol-array ary) sub) r))
((setq ary (mget fun 'hashar))
(if (not (= (aref (symbol-array ary) 2) (length (cdr l))))
(merror (intl:gettext "assignment: array ~:M has dimension ~:M, but it was called by ~:M")
fun (aref (symbol-array ary) 2) l))
(setq sub (mapcar #'meval (cdr l)))
(setq hashl (aref (symbol-array ary)
(setq lispsub (+ 3 (rem (hasher sub)
(aref (symbol-array ary) 0))))))
(do ((hashl1 hashl (cdr hashl1)))
((null hashl1)
(cond ((not (eq r munbound))
(setq sub (ncons (cons sub r)))
(cond ((null hashl) (setf (aref (symbol-array ary) lispsub) sub))
(t (nconc hashl sub)))
(setf (aref (symbol-array ary) 1) (1+ (aref (symbol-array ary) 1))))))
(cond ((alike (caar hashl1) sub)
(cond ((eq r munbound) (setf (aref (symbol-array ary) 1)
(1- (aref (symbol-array ary) 1))))
(t (nconc hashl (ncons (cons sub r)))))
(setf (aref (symbol-array ary) lispsub)
(delete (car hashl1) hashl :count 1 :test #'equal))
(return nil))))
(if (> (aref (symbol-array ary) 1) (aref (symbol-array ary) 0))
(arraysize fun (* 2 (aref (symbol-array ary) 0))))
r)
((and (eq fun 'mqapply) (or (mxorlistp (setq ary (meval (cadr l)))) (arrayp ary))
(prog2
(setq mqapplyp t l (cdr l))
nil)))
((and (not mqapplyp)
(or (not (boundp fun))
(not (or (mxorlistp (setq ary (symbol-value fun)))
(arrayp ary)
(typep ary 'hash-table)
(eq (type-of ary) 'mgenarray)))))
(if (member fun '(mqapply $%) :test #'eq) (merror (intl:gettext "assignment: cannot assign to ~M") l))
(if $use_fast_arrays
(progn
;; (format t "ARRSTORE: use_fast_arrays=true; allocate a new value hash table for ~S~%" fun)
(meval* `((mset) ,fun ,(make-equal-hash-table (cdr (mevalargs (cdr l)))))))
(progn
;; (format t "ARRSTORE: use_fast_arrays=false; allocate a new property hash table for ~S~%" fun)
(add2lnc fun $arrays)
(setq ary (gensym))
(mputprop fun ary 'hashar)
(setf (symbol-array ary) (make-array 7 :initial-element nil))
(setf (aref (symbol-array ary) 0) 4)
(setf (aref (symbol-array ary) 1) 0)
(setf (aref (symbol-array ary) 2) (length (cdr l)))))
(arrstore l r))
((or (arrayp ary)
(typep ary 'hash-table)
(eq (type-of ary) 'mgenarray))
(arrstore-extend ary (mevalargs (cdr l)) r))
((or (eq (caar ary) 'mlist) (= (length l) 2))
(cond ((eq (caar ary) '$matrix)
(cond ((or (not ($listp r)) (not (= (length (cadr ary)) (length r))))
(merror (intl:gettext "assignment: matrix row must be a list, and same length as first row;~%found:~%~M") r))))
((not (= (length l) 2))
(merror (intl:gettext "assignment: matrix row must have one index; found: ~M") (cons '(mlist) (cdr l)))))
(let ((index (meval (cadr l))))
(cond ((not (fixnump index))
(merror (intl:gettext "assignment: matrix row index must be an integer; found: ~M") index))
((and (> index 0) (< index (length ary)))
(rplaca (nthcdr (1- index) (cdr ary)) r))
(t (merror (intl:gettext "assignment: matrix row index ~A out of range.") index))))
r)
(t (if (not (= (length l) 3))
(merror (intl:gettext "assignment: matrix must have two indices; found: ~M") (cons '(mlist) (cdr l))))
($setelmx r (meval (cadr l)) (meval (caddr l)) ary)
r))))
;; Original: (find-maximagitfile "src/ar.lisp" "(defun marrayset-gensub ")
(defun marrayset-gensub (val aarray ind1 inds)
(declare (optimize (debug 3)))
(case (marray-type aarray)
((array)
(unless (and (integerp ind1) (every #'integerp inds))
(bad-index-error (cons ind1 inds)))
(setf (apply #'aref aarray ind1 inds) val))
((hash-table) (setf (gethash (if inds (cons ind1 inds) ind1) aarray) val))
(($functional)
(marrayset-gensub val (mgenarray-content aarray) ind1 inds))
(t
(marray-type-unknown aarray))))
;; Original: (find-maximagitfile "src/ar.lisp" "(defun meval1-extend ")
(defun meval1-extend (form)
(declare (optimize (debug 3)))
(let ((l (mevalargs (cdr form))))
(marrayref-gensub (caar form) (car l) (cdr l))))
;; Original: (find-maximagitfile "src/ar.lisp" "(defun arrstore-extend ")
(defun arrstore-extend (a l r)
(declare (optimize (debug 3)))
(marrayset-gensub r a (car l) (cdr l)))
#|
* (eepitch-slime-kill 'show-only)
* (eepitch-slime-kill)
* (eepitch-b '(slime "sbcl"))
* (eepitch-slime-select)
* (eepitch-maxima)
* (eepitch-kill)
* (eepitch-maxima)
load("startslime");
* (eepitch-b '(slime-connect "localhost" 4005))
* (eepitch-slime-set-pkgbuffers)
* (eepitch-slime-select-pkgbuffer "MAXIMA")
* (eepitch-maxima)
load("~/MAXIMA/2025-meval1.lisp");
a1 : make_array(hashed);
a1[2]:3;
* (eepitch-slime-select-pkgbuffer "MAXIMA")
(trace marrayset-gensub)
(trace safe-get)
(trace safe-mget)
(trace safe-getl)
(trace meval1 :break t)
(trace arrstore :break t)
#$a1[4]:5$
(describe 'msetq)
(inspect (get 'msetq 'mfexpr*))
* (eepitch-sbcl)
* (eepitch-kill)
* (eepitch-sbcl)
(load "2025-meval1.lisp")
|#
;; Local Variables:
;; coding: utf-8-unix
;; End: