Menu
▾
▴
[Maxima-commits] CVS: maxima/src mlisp.lisp,1.55,1.56
|
From: Andreas E. <ar...@us...> - 2007-10-12 16:13:48
|
Update of /cvsroot/maxima/maxima/src In directory sc8-pr-cvs16.sourceforge.net:/tmp/cvs-serv4446/src Modified Files: mlisp.lisp Log Message: replaced *array calls by the CL make-array function; replaced la,bda binding in $array with let binding; Index: mlisp.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/mlisp.lisp,v retrieving revision 1.55 retrieving revision 1.56 diff -u -d -r1.55 -r1.56 --- mlisp.lisp 16 Sep 2007 19:46:34 -0000 1.55 +++ mlisp.lisp 12 Oct 2007 16:13:43 -0000 1.56 @@ -30,7 +30,7 @@ $float $numer aryp msump state-pdl evarrp $setval nounl $setcheckbreak $refcheck *mdebug* refchkl baktrcl maplp $norepeat $detout $doallmxops $doscmxops opers factlist opexprp - $translate $transrun $maperror outargs1 outargs2 fmaplvl mopl + $translate $transrun $maperror fmaplvl mopl $powerdisp $subscrmap $dispflag $optionset dsksetp fexprerrp $features *alphabet* $%enumer $infeval $savedef $%% %e-val featurel outfiles fundefsimp mfexprp transp @@ -1232,18 +1232,17 @@ (apply #'fmapl1 (mmapev l))) (defmfun fmapl1 (fun &rest args) - (let ((header '(mlist)) argl) - (setq argl (fmap1 fun - (mapcar - #'(lambda (z) - (cond ((not (mxorlistp z)) - (merror "Argument to `fullmapl' is not a list or matrix.")) - ((eq (caar z) '$matrix) - (setq header '($matrix)) - (cons '(mlist simp) (cdr z))) - (t z))) - args) - 'mlist)) + (let* ((header '(mlist)) + (argl (fmap1 fun + (mapcar #'(lambda (z) + (cond ((not (mxorlistp z)) + (merror "Argument to `fullmapl' is not a list or matrix.")) + ((eq (caar z) '$matrix) + (setq header '($matrix)) + (cons '(mlist simp) (cdr z))) + (t z))) + args) + 'mlist))) (if (dolist (e (cdr argl)) (unless ($listp e) (return t))) argl @@ -1251,23 +1250,25 @@ (defun $outermap (x y &rest z) (if z - (apply #'outermap1 `(,x ,y ,@z)) + (apply #'outermap1 x y z) (fmapl1 x y))) (defmfun outermap1 n (let (outargs1 outargs2) + (declare (special outargs1 outargs2)) (cond ((mxorlistp (arg 2)) (setq outargs1 (ncons (arg 1)) outargs2 (listify (- 2 n))) - (fmapl1 'outermap2 (arg 2))) + (fmapl1 #'outermap2 (arg 2))) (t (do ((i 3 (1+ i))) ((> i n) (funcer (arg 1) (listify (- 1 n)))) (when (mxorlistp (arg i)) (setq outargs1 (listify (1- i)) outargs2 (if (< i n) (listify (- i n)))) - (return (fmapl1 'outermap2 (arg i))))))))) + (return (fmapl1 #'outermap2 (arg i))))))))) (defmfun outermap2 (&rest args) + (declare (special outargs1 outargs2)) (unless (null args) (apply #'outermap1 (append outargs1 (list (first args)) outargs2)))) @@ -1626,66 +1627,69 @@ (cond ($use_fast_arrays (mset (car x) (apply '$make_array '$any (mapcar #'1+ (cdr x))))) ((symbolp (car x)) - (funcall #'(lambda (compp) - (funcall #'(lambda (fun diml funp old new ncells) - (cond ((member '$function diml :test #'eq) - (setq diml (delete '$function (copy-list diml) - :count 1 :test #'eq) funp t))) - (setq diml (mapcar #'meval diml)) - (cond ((null diml) - (wna-err '$array)) - ((> (length diml) 5) - (merror "`array' takes at most 5 indices")) - ((member nil (mapcar #'(lambda (u) (eq (ml-typep u) 'fixnum)) - diml) :test #'eq) - (merror "Non-integer dimension - `array'"))) - (setq diml (mapcar #'1+ diml)) - (setq new (apply #'*array (cons (if compp fun (gensym)) - (cons t diml)))) - (cond ((eq compp 'fixnum) (fillarray new '(0))) - ((eq compp 'flonum) (fillarray new '(0.0d0)))) - (cond ((not (member compp '(fixnum flonum) :test #'eq)) - (fillarray new (list munbound))) - ((or funp (arrfunp fun)) - (fillarray new (list (cond ((eq compp 'fixnum) fixunbound) - (t flounbound)))))) - (cond ((null (setq old (mget fun 'hashar))) - (mputprop fun new 'array)) - (t (cond ((not (= (aref (symbol-array old) 2) (length diml))) - (merror "Array ~:M already has ~:M dimension(s)" - fun (aref (symbol-array old) 2)))) - (setq ncells (+ 2 (aref (symbol-array old) 0))) - (do ((n 3 (1+ n))) ((> n ncells)) - (do ((items (aref (symbol-array old) n) (cdr items))) ((null items)) - (do ((x (caar items) (cdr x)) (y diml (cdr y))) - ((null x) - (if (and (member compp '(fixnum flonum) :test #'eq) - (not (eq (ml-typep (cdar items)) compp))) - (merror "Element and array type do not match:~%~M" - (cdar items))) - - (setf (apply #'aref (symbol-array new) - (caar items)) - (cdar items))) - (if (or (not (eq (ml-typep (car x)) 'fixnum)) - (< (car x) 0) - (not (< (car x) (car y)))) - (merror "Improper index for declared array:~%~M" - (car x)))))) - (mremprop fun 'hashar) - (mputprop fun new 'array))) - (add2lnc fun $arrays) - (if (eq compp 'fixnum) (putprop fun '$fixnum 'array-mode)) - (if (eq compp 'flonum) (putprop fun '$float 'array-mode)) - fun) - ($verbify (car x)) (cond (compp (setq compp (cdr compp)) (cddr x)) (t (cdr x))) - nil nil nil 0)) - (assoc (cadr x) '(($complete . t) ($integer . fixnum) ($fixnum . fixnum) - ($float . flonum) ($flonum . flonum)) :test #'eq))) + (let ((compp (assoc (cadr x) '(($complete . t) ($integer . fixnum) ($fixnum . fixnum) + ($float . flonum) ($flonum . flonum))))) + (let ((fun ($verbify (car x))) + (diml (cond (compp (setq compp (cdr compp)) + (cddr x)) + (t (cdr x)))) + funp + old + new + (ncells 0)) + (when (member '$function diml :test #'eq) + (setq diml (delete '$function diml :count 1 :test #'eq) + funp t)) + (setq diml (mapcar #'meval diml)) + (cond ((null diml) + (wna-err '$array)) + ((> (length diml) 5) + (merror "`array' takes at most 5 indices")) + ((member nil (mapcar #'(lambda (u) (eq (ml-typep u) 'fixnum)) diml) + :test #'eq) + (merror "Non-integer dimension - `array'"))) + (setq diml (mapcar #'1+ diml)) + (setq new (if compp fun (gensym))) + (setf (symbol-array new) (make-array diml :initial-element (case compp + (fixnum 0) + (flonum 0d0) + (otherwise munbound)))) + (when (or funp (arrfunp fun)) + (fillarray new (list (if (eq compp 'fixnum) fixunbound flounbound)))) + (cond ((null (setq old (mget fun 'hashar))) + (mputprop fun new 'array)) + (t (unless (= (aref (symbol-array old) 2) (length diml)) + (merror "Array ~:M already has ~:M dimension(s)" fun (aref (symbol-array old) 2))) + (setq ncells (+ 2 (aref (symbol-array old) 0))) + (do ((n 3 (1+ n))) + ((> n ncells)) + (do ((items (aref (symbol-array old) n) (cdr items))) + ((null items)) + (do ((x (caar items) (cdr x)) (y diml (cdr y))) + ((null x) + (if (and (member compp '(fixnum flonum) :test #'eq) + (not (eq (ml-typep (cdar items)) compp))) + (merror "Element and array type do not match:~%~M" (cdar items))) + (setf (apply #'aref (symbol-array new) (caar items)) + (cdar items))) + (if (or (not (eq (ml-typep (car x)) 'fixnum)) + (< (car x) 0) + (not (< (car x) (car y)))) + (merror "Improper index for declared array:~%~M" (car x)))))) + (mremprop fun 'hashar) + (mputprop fun new 'array))) + (add2lnc fun $arrays) + (when (eq compp 'fixnum) + (putprop fun '$fixnum 'array-mode)) + (when (eq compp 'flonum) + (putprop fun '$float 'array-mode)) + fun))) (($listp (car x)) - (do ((u (cdar x) (cdr u))) ((null u)) (meval `(($array) ,(car u) ,@(cdr x)))) + (dolist (u (cdar x)) + (meval `(($array) ,u ,@(cdr x)))) (car x)) - (t (merror "Improper first argument to `array':~%~M" (car x))))) + (t + (merror "Improper first argument to `array':~%~M" (car x))))) (defmfun $show_hash_array (x) @@ -1708,11 +1712,11 @@ (error "Array has dimension 1"))) (t (or (cdr index) (error "Array has dimension > 1")))) - (setf (gethash - (if (cdr index) index - (car index)) - tem) r)) - ((eq the-type 'list) + (setf (gethash (if (cdr index) + index + (car index)) + tem) r)) + ((eq the-type 'list) (cond ((eq (caar tem) 'mlist) (setq index (car index)) (setf (nth index tem) r) @@ -1723,13 +1727,14 @@ (t (error "The value of ~A is not a hash-table ,an ~ array, Maxima list, or a matrix" (caar l))))) - (t(cond ((eq tem (caar l)) - (meval* `((mset) ,(caar l) - ,(make-equal-hash-table - (cdr (mevalargs (cdr l)))))) - (arrstore l r)) - (t - (error "The value of ~A is not a hash-table , ~ + (t + (cond ((eq tem (caar l)) + (meval* `((mset) ,(caar l) + ,(make-equal-hash-table + (cdr (mevalargs (cdr l)))))) + (arrstore l r)) + (t + (error "The value of ~A is not a hash-table, ~ an array, a Maxima list, or a matrix" (caar l)))))))) (t (cond ((mget (caar l) 'hashar) @@ -1787,8 +1792,9 @@ (eq (ml-typep ary) 'array))))) (if (member fun '(mqapply $%) :test #'eq) (merror "Illegal use of :")) (add2lnc fun $arrays) - (mputprop fun (setq ary (gensym)) 'hashar) - (*array ary t 7) + (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))) @@ -1840,8 +1846,9 @@ (defun arraysize (fun n) (prog (old new indx ncells cell item i y) (setq old (symbol-array (mget fun 'hashar))) - (mputprop fun (setq new (gensym)) 'hashar) - (*array new t (+ n 3)) + (setq new (gensym)) + (mputprop fun new 'hashar) + (setf (symbol-array new) (make-array (+ n 3) :initial-element nil)) (setq new (symbol-array new)) (setf (aref new 0) n) (setf (aref new 1) (aref old 1)) @@ -1863,10 +1870,9 @@ (y (cdr (arraydims (mget ary 'array))) (cdr y))) ((null y) (if x (merror "Array ~:M has dimensions ~:M, but was called with ~:M" - ary `((mlist) - ,.(mapcar #'1- - (cdr (arraydims (mget ary 'array))))) - `((mlist) ,.sub)) + ary + `((mlist) ,@(mapcar #'1- (cdr (arraydims (mget ary 'array))))) + `((mlist) ,@sub)) ret)) (cond ((or (null x) (and (eq (ml-typep (car x)) 'fixnum) (or (< (car x) 0) (not (< (car x) (car y)))))) @@ -1945,37 +1951,37 @@ (merror "Array ~:M already defined with different dimensions" fnname)) (mdefarray fnname subs args body mqdef)) - (t (mputprop fnname (setq ary (gensym)) 'hashar) - (*array ary t 7) - (setf (aref (symbol-array ary) 0) 4) - (setf (aref (symbol-array ary) 1) 0) - (setf (aref (symbol-array ary) 2) (length subs)) - (mdefarray fnname subs args body mqdef))) + (t + (setq ary (gensym)) + (mputprop fnname 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 subs)) + (mdefarray fnname subs args body mqdef))) (cons '(mdefine simp) (copy-list l))))) ;; Checks to see if a user is clobbering the name of a system function. ;; Prints a warning and returns T if he is, and NIL if he isn't. (defun mredef-check (fnname) - (cond ((and (not (mget fnname 'mexpr)) - (or (and (or (get fnname 'autoload) - (getl-lm-fcn-prop fnname '(subr fsubr lsubr)) - (get fnname 'mfexpr*s)) - (not (get fnname 'translated))) - (mopp fnname))) - (princ "Warning - you are redefining the Maxima ") - (if (getl fnname '(verb operators)) - (princ "command ") (princ "function ")) - (princ (print-invert-case (stripdollar fnname))) - (terpri) - t))) + (when (and (not (mget fnname 'mexpr)) + (or (and (or (get fnname 'autoload) + (getl-lm-fcn-prop fnname '(subr fsubr lsubr)) + (get fnname 'mfexpr*s)) + (not (get fnname 'translated))) + (mopp fnname))) + (format t "Warning - you are redefining the Maxima ~:[function~;command~] ~a~%" + (getl fnname '(verb operators)) + (print-invert-case (stripdollar fnname))) + t)) (defun mdefarray (fun subs args body mqdef) - (cond ((and (boundp fun) (hash-table-p fun)) - (error "~a is already a hash table. Make it a function first" fun))) + (when (hash-table-p fun) + (error "~a is already a hash table. Make it a function first" fun)) (cond ((and (null args) (not mqdef)) (mputprop fun (mdefine1 subs body) 'aexpr)) ((null (dolist (u subs) - (if (not (or (consp u) ($constantp u) (char= (char (symbol-name u) 0) #\&))) - (return t)))) + (unless (or (consp u) ($constantp u) (char= (char (symbol-name u) 0) #\&)) + (return t)))) (arrstore (cons (ncons fun) subs) (mdefine1 args body))) (t (mdefchk fun subs t nil) (mputprop fun (mdefine1 subs (mdefine1 args body)) 'aexpr)))) |