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