1;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;; 2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3;;; The data in this file contains enhancments. ;;;;; 4;;; ;;;;; 5;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;; 6;;; All rights reserved ;;;;; 7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; 9;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 11(in-package :maxima) 12 13;;; Run-time support for translated code. 14 15;;; GJC: Experimental macsyma array lisp level support for translated code. 16;;; To quickly handle the array reference and setting syntax in macsyma, 17 18;;; In macsyma arrays go by an atomic name. Lists and matrices 19;;; may be hacked with the array syntax, which is convient. 20 21;;; additions for handling arrays in value cell on cl --wfs 22 23(macsyma-module acall) 24 25(defun interval-error (fun low high) 26 (merror (intl:gettext "~@:M: lower bound ~M is greater than upper bound ~M") fun low high)) 27 28(defun mfuncall (f &rest l) 29 (cond ((functionp f) 30 (apply f l)) 31 ((and (symbolp f) (or (macro-function f) (special-operator-p f))) 32 (eval (cons f l))) 33 (t 34 (mapply f l nil)))) 35 36;;; ((MQAPPLY ARRAY) X Y) is a strange form, meaning (X)[Y]. 37 38(defun marrayref (aarray ind1 &rest inds) 39 (declare (special fixunbound flounbound)) 40 (typecase aarray 41 (cl:array 42 (case (array-element-type aarray) 43 ((flonum fixnum t) 44 (apply #'aref aarray ind1 inds)) 45 (t 46 (merror (intl:gettext "MARRAYREF: encountered array ~M of unknown type.") aarray)))) 47 (cl:hash-table 48 (gethash (if inds (cons ind1 inds) inds) aarray)) 49 (cl:symbol 50 (if $use_fast_arrays 51 (let ((tem (and (boundp aarray) (symbol-value aarray)))) 52 (simplify (cond ((arrayp tem) 53 (apply #'aref tem ind1 inds)) 54 ((hash-table-p tem) 55 (gethash (if inds (cons ind1 inds) inds) tem)) 56 ((eq aarray 'mqapply) 57 (apply #'marrayref ind1 inds)) 58 ((mget aarray 'hashar) 59 (harrfind `((,aarray array) ,ind1 ,@inds))) 60 ((symbolp tem) 61 `((,tem array) ,ind1 ,@inds)) 62 (t 63 (error "unknown type of array for use_fast_arrays. ~ 64 the value cell should have the array or hash table"))))) 65 (let (ap) ; no fast arrays 66 (simplify (cond ((setq ap (get aarray 'array)) 67 (let ((val (if (null inds) 68 (aref ap ind1) 69 (apply #'aref (append (list ap ind1) inds))))) 70 ;; Check for KLUDGING array function implementation. 71 (if (case (array-element-type ap) 72 ((flonum) (= val flounbound)) 73 ((fixnum) (= val fixunbound)) 74 ((t) (eq val munbound)) 75 (t (merror (intl:gettext "MARRAYREF: encountered array pointer ~S of unknown type.") ap))) 76 (arrfind `((,aarray ,aarray) ,ind1 ,@inds)) 77 val))) 78 ((setq ap (mget aarray 'array)) 79 (arrfind `((,aarray array) ,ind1 ,@inds))) 80 ((setq ap (mget aarray 'hashar)) 81 (harrfind `((,aarray array) ,ind1 ,@inds))) 82 ((eq aarray 'mqapply) 83 (apply #'marrayref ind1 inds)) 84 (t 85 `((,aarray array) ,ind1 ,@inds))))))) 86 (cl:list 87 (simplify (if (member (caar aarray) '(mlist $matrix) :test #'eq) 88 (list-ref aarray (cons ind1 inds)) 89 `((mqapply aarray) ,aarray ,ind1 ,@inds)))) 90 (t 91 (merror (intl:gettext "MARRAYREF: cannot retrieve an element of ~M") aarray)))) 92 93(defmfun $arrayapply (ar inds) 94 (unless ($listp inds) 95 (merror (intl:gettext "arrayapply: second argument must be a list; found ~M") inds)) 96 (apply #'marrayref ar (cdr inds))) 97 98(defmfun $arraysetapply (ar inds val) 99 (unless ($listp inds) 100 (merror (intl:gettext "arraysetapply: second argument must be a list; found ~M") inds)) 101 (apply #'marrayset val ar (cdr inds))) 102 103(defun marrayset (val aarray &rest all-inds) 104 (let ((ind1 (first all-inds)) 105 (inds (rest all-inds))) 106 (typecase aarray 107 (cl:array 108 (case (array-element-type aarray) 109 ((fixnum flonum t) 110 (setf (apply #'aref aarray ind1 inds) val)) 111 (t 112 (merror (intl:gettext "MARRAYSET: encountered array ~M of unknown type.") aarray)))) 113 (cl:hash-table 114 (setf (gethash (if (cdr all-inds) 115 (copy-list all-inds) 116 (car all-inds)) 117 aarray) val)) 118 (cl:symbol 119 (let (ap) 120 (cond ((setq ap (get aarray 'array)) 121 (if (null inds) 122 (setf (aref ap ind1) val) 123 (setf (apply #'aref ap all-inds) val))) 124 ((setq ap (mget aarray 'array)) 125 ;; the macsyma ARRAY frob is NOT an array pointer, it 126 ;; is a GENSYM with a lisp array property, don't 127 ;; ask me why. 128 (if (null inds) 129 (setf (aref (symbol-array ap) ind1) val) 130 (setf (apply #'aref (symbol-array ap) all-inds) val))) 131 ((setq ap (mget aarray 'hashar)) 132 (arrstore `((,aarray ,'array) 133 ,@(mapcar #'(lambda (u) `((mquote simp) ,u)) all-inds)) 134 val)) 135 ((eq aarray 'mqapply) 136 (apply #'marrayset val ind1 inds)) 137 (t 138 (arrstore `((,aarray ,'array) 139 ,@(mapcar #'(lambda (u) `((mquote simp) ,u)) all-inds)) 140 val))))) 141 (cl:list (if (member (caar aarray) '(mlist $matrix) :test #'eq) 142 (list-ref aarray all-inds t val) 143 (merror (intl:gettext "MARRAYSET: cannot assign to an element of ~M") aarray))) 144 (t 145 (merror (intl:gettext "MARRAYSET: ~M is not an array.") aarray))) ) 146 val) 147 148;;; Note that all these have HEADERS on the list. The CAR of a list I 149;;; will call element 0. So [1,2][1] => 1 150 151(defun list-ref (l indexl &optional set-flag val) 152 (cond ((atom l) 153 (merror (intl:gettext "LIST-REF: argument must be a list; found ~M") l)) 154 ((null (cdr indexl)) 155 (let ((n (car indexl))) 156 (cond ((and (integerp n) (plusp n) 157 (or (eq (caar l) 'mlist) 158 (eq (caar l) '$matrix))) 159 (let ((ret (do ((j 1 (1+ j)) 160 (l (cdr l) (cdr l))) 161 ((or (null l) (= j n)) 162 (cond ((null l) 163 (merror (intl:gettext "LIST-REF: invalid subscript: ~M") n)) 164 (set-flag 165 (rplaca l val)) 166 (t 167 (car l))))))) 168 (if set-flag l ret))) 169 (t 170 (merror (intl:gettext "LIST-REF: invalid subscript: ~M") n))))) 171 (set-flag 172 (list-ref (list-ref l `(,(car indexl))) (cdr indexl) set-flag val) 173 l) 174 (t 175 (list-ref (list-ref l `(,(car indexl))) (cdr indexl))))) 176 177(declare-top (special $dispflag)) 178 179(defun display-for-tr (labelsp equationsp &rest argl) 180 (declare (special *linelabel*)) 181 (do ((argl argl (cdr argl)) 182 (lablist nil) 183 (tim 0)) 184 ((null argl) (if labelsp `((mlist) ,@lablist) '$done)) 185 (let ((ans (car argl))) 186 (cond ((and equationsp 187 ;; ((MEQUAL) FOO BAR) 188 (not (atom (caddr ans))) 189 (eq (caar (caddr ans)) 'mequal)) 190 ;; if the ANS evaluats to something with an "=" 191 ;; already then of course he really meant to use 192 ;; DISP, but we might as well do what he means right? 193 (setq ans (caddr ans)))) 194 (when labelsp 195 (unless (checklabel $linechar) 196 (incf $linenum)) 197 (makelabel $linechar) 198 ;; setqs the free variable *LINELABEL*, what a win, 199 ;; how convenient, now I don't need to use LET ! 200 (push *linelabel* lablist) 201 (unless $nolabels 202 (setf (symbol-value *linelabel*) ans))) 203 (setq tim (get-internal-run-time)) 204 (displa `((mlabel) ,(cond (labelsp *linelabel*)) ,ans)) 205 (mterpri) 206 (timeorg tim)))) 207 208 209(defun insure-array-props (fnname ignore-mode number-of-args &aux ary) 210 (declare (ignore ignore-mode)) 211 ;; called during load or eval time by the defining forms 212 ;; for translated array-functions. 213 ;; this duplicates code in JPG;MLISP (however, the code in MLISP 214 ;; is not callable because it is in a big piece of so-called 215 ;; multi-purpose code). 216 217 ;; This code is incredibly kludgy. For example, what if 218 ;; the function FOO[J] had a lisp array property gotten 219 ;; by ARRAY(FOO,FIXNUM,33), how is *THAT* detected by this code? 220 ;; Well, it is because that will also put an MPROP ARRAY of $FOO, 221 ;; and (ARRAYDIMS '$FOO) works! (Also checks the array property). 222 ;; Isn't that something. Shit, I never knew that ARRAYDIMS worked 223 ;; on symbols. What a crock. 224 (cond ((prog2 225 (add2lnc fnname $arrays) 226 (setq ary (mgetl fnname '(hashar array)))) 227 (unless (= (if (eq (car ary) 'hashar) 228 (funcall (cadr ary) 2) 229 (length (cdr (arraydims (cadr ary))))) 230 number-of-args) 231 (merror (intl:gettext "INSURE-ARRAY-PROPS: array ~:@M already defined with different dimensions.") fnname))) 232 (t 233 (setq ary (gensym)) 234 (mputprop fnname ary 'hashar) 235 (setf (symbol-array ary) (make-array 7 :initial-element nil)) 236 (setf (aref (symbol-array ary) 0) 4) 237 (setf (aref (symbol-array ary) 1) 0) 238 (setf (aref (symbol-array ary) 2) number-of-args)))) 239 240;;; An entry point to $APPLY for translated code. 241 242(defun mapply-tr (fun list) 243 (unless ($listp list) 244 (merror (intl:gettext "apply: second argument must be a list; found ~M") list)) 245 (mapply1 fun (cdr list) '|the first arg to a translated `apply'| list)) 246 247(defun assign-check (var val) 248 (let ((a (get var 'assign))) 249 (if a (funcall a var val)))) 250 251(declare-top (special maplp)) 252 253(defun maplist_tr (fun l1 &rest l) 254 (setq l (cons l1 (copy-list l))) 255 (simplify (let ((maplp t) res) 256 (setq res (apply #'map1 (getopr fun) l)) 257 (cond ((atom res) (list '(mlist) res)) 258 ((eq (caar res) 'mlist) res) 259 (t (cons '(mlist) (margs res))))))) 260 261;;; Entry point into DB for translated code. The main point here 262;;; is that evaluation of a form takes place first, (using the lisp 263;;; evaluator), and then the trueness is checked. It is not correct 264;;; to call the function IS because double-evaluation will then 265;;; result, which is wrong, not to mention being incompatible with 266;;; the interpreter. 267;;; 268;;; This code is taken from the COMPAR module, and altered such that calls to 269;;; the macsyma evaluator do not take place. It would be a lot 270;;; better to simply modify the code in COMPAR! However, mumble... 271;;; Anyway, be careful of changes to COMPAR that break this code. 272 273(defun is-boole-check (form) 274 (cond ((null form) nil) 275 ((eq form t) t) 276 (t 277 ;; We check for T and NIL quickly, otherwise go for the database. 278 (mevalp_tr form $prederror nil)))) 279 280(defun maybe-boole-check (form) 281 (mevalp_tr form nil nil)) 282 283(defun mevalp_tr (pat error? meval?) 284 (let (patevalled ans) 285 (declare (special patevalled)) 286 (setq ans (mevalp1_tr pat error? meval?)) 287 (cond ((member ans '(t nil) :test #'eq) ans) 288 (error? 289 (pre-err patevalled)) 290 ('else '$unknown)))) 291 292(defun mevalp1_tr (pat error? meval?) 293 (declare (special patevalled)) 294 (cond ((and (not (atom pat)) (member (caar pat) '(mnot mand mor) :test #'eq)) 295 (cond ((eq 'mnot (caar pat)) (is-mnot_tr (cadr pat) error? meval?)) 296 ((eq 'mand (caar pat)) (is-mand_tr (cdr pat) error? meval?)) 297 (t (is-mor_tr (cdr pat) error? meval?)))) 298 ((atom (setq patevalled (if meval? (meval pat) pat))) patevalled) 299 ((member (caar patevalled) '(mnot mand mor) :test #'eq) (mevalp1_tr patevalled 300 error? 301 meval?)) 302 (t (mevalp2 patevalled (caar patevalled) (cadr patevalled) (caddr patevalled))))) 303 304(defun is-mnot_tr (pred error? meval?) 305 (setq pred (mevalp_tr pred error? meval?)) 306 (cond ((eq t pred) nil) 307 ((not pred)) 308 (t (pred-reverse pred)))) 309 310(defun is-mand_tr (pl error? meval?) 311 (do ((dummy) (npl)) 312 ((null pl) (cond ((null npl)) 313 ((null (cdr npl)) (car npl)) 314 (t (cons '(mand) (nreverse npl))))) 315 (setq dummy (mevalp_tr (car pl) error? meval?) 316 pl (cdr pl)) 317 (cond ((eq t dummy)) 318 ((null dummy) (return nil)) 319 (t (setq npl (cons dummy npl)))))) 320 321(defun is-mor_tr (pl error? meval?) 322 (do ((dummy) (npl)) 323 ((null pl) (cond ((null npl) nil) 324 ((null (cdr npl)) (car npl)) 325 (t (cons '(mor) (nreverse npl))))) 326 (setq dummy (mevalp_tr (car pl) error? meval?) 327 pl (cdr pl)) 328 (cond ((eq t dummy) (return t)) 329 ((null dummy)) 330 (t (setq npl (cons dummy npl)))))) 331 332;; Some functions for even faster calling of arrays. 333 334(defun marrayref1$ (aarray index) 335 (typecase aarray 336 (cl:array 337 (case (array-element-type aarray) 338 ((flonum) (aref aarray index)) 339 (t (merror (intl:gettext "MARRAYREF1$: array must be an array of floats; found ~M") aarray)))) 340 (t 341 (marrayref aarray index)))) 342 343(defun marrayset1$ (value aarray index) 344 (typecase aarray 345 (cl:array 346 (case (array-element-type aarray) 347 ((flonum) (setf (aref aarray index) value)) 348 (t (merror (intl:gettext "MARRAYSET1$: array must be an array of floats; found ~M") aarray)))) 349 (t 350 (marrayset value aarray index)))) 351 352 353(defun application-operator (form &rest ign) 354 (declare (ignore ign)) 355 (apply (caar form) (cdr form))) 356 357;; more efficient operators calls. 358 359(defun *mminus (x) 360 (if (numberp x) 361 (- x) 362 (simplify (list '(mminus) x)))) 363 364(defun retlist_tr (&rest args) 365 (do ((j (- (length args) 2) (- j 2)) 366 (l () (cons (list '(mequal simp) (nth j args) (nth (1+ j) args)) l))) 367 ((< j 0) (cons '(mlist simp) l)))) 368