src/acall.lisp

   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 f))))
  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) ind1) 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) ind1) 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 array) ,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 array) ,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) ,@(nreverse 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       (let ((*display-labels-p* (not (null lablist))))
 205         (declare (special *display-labels-p*))
 206         (displa `((mlabel) ,(cond (labelsp *linelabel*)) ,ans)))
 207       (mterpri)
 208       (timeorg tim))))
 209
 210
 211 (defun insure-array-props (fnname ignore-mode number-of-args &aux ary)
 212   (declare (ignore ignore-mode))
 213   ;; called during load or eval time by the defining forms
 214   ;; for translated array-functions.
 215   ;; this duplicates code in JPG;MLISP (however, the code in MLISP
 216   ;; is not callable because it is in a big piece of so-called
 217   ;; multi-purpose code).
 218
 219   ;; This code is incredibly kludgy. For example, what if
 220   ;; the function FOO[J] had a lisp array property gotten
 221   ;; by ARRAY(FOO,FIXNUM,33), how is *THAT* detected by this code?
 222   ;; Well, it is because that will also put an MPROP ARRAY of $FOO,
 223   ;; and (ARRAYDIMS '$FOO) works! (Also checks the array property).
 224   ;; Isn't that something. Shit, I never knew that ARRAYDIMS worked
 225   ;; on symbols. What a crock.
 226   (cond ((prog2
 227              (add2lnc fnname $arrays)
 228              (setq ary (mgetl fnname '(hashar array))))
 229          (unless (= (if (eq (car ary) 'hashar)
 230                         (funcall (cadr ary) 2)
 231                         (length (cdr (arraydims (cadr ary)))))
 232                     number-of-args)
 233            (merror (intl:gettext "INSURE-ARRAY-PROPS: array ~:@M already defined with different dimensions.") fnname)))
 234         (t
 235          (setq ary (gensym))
 236          (mputprop fnname ary 'hashar)
 237          (setf (symbol-array ary) (make-array 7 :initial-element nil))
 238          (setf (aref (symbol-array ary) 0) 4)
 239          (setf (aref (symbol-array ary) 1) 0)
 240          (setf (aref (symbol-array ary) 2) number-of-args))))
 241
 242 ;;; An entry point to $APPLY for translated code.
 243
 244 (defun mapply-tr (fun list)
 245   (unless ($listp list)
 246     (merror (intl:gettext "apply: second argument must be a list; found ~M") list))
 247   (mapply1 fun (cdr list) '|the first arg to a translated `apply'| list))
 248
 249 (defun assign-check (var val)
 250   (let ((a (get var 'assign)))
 251     (if a (funcall a var val))))
 252
 253 (declare-top (special maplp))
 254
 255 (defun maplist_tr (fun  l1 &rest l)
 256   (setq l (cons l1 (copy-list l)))
 257   (simplify (let ((maplp t) res)
 258               (setq res (apply #'map1 (getopr fun) l))
 259               (cond ((atom res) (list '(mlist) res))
 260                     ((eq (caar res) 'mlist) res)
 261                     (t (cons '(mlist) (margs res)))))))
 262
 263 ;;; Entry point into DB for translated code. The main point here
 264 ;;; is that evaluation of a form takes place first, (using the lisp
 265 ;;; evaluator), and then the trueness is checked. It is not correct
 266 ;;; to call the function IS because double-evaluation will then
 267 ;;; result, which is wrong, not to mention being incompatible with
 268 ;;; the interpreter.
 269 ;;;
 270 ;;; This code is taken from the COMPAR module, and altered such that calls to
 271 ;;; the macsyma evaluator do not take place. It would be a lot
 272 ;;; better to simply modify the code in COMPAR! However, mumble...
 273 ;;; Anyway, be careful of changes to COMPAR that break this code.
 274
 275 (defun is-boole-check (form)
 276   (cond ((null form) nil)
 277         ((eq form t) t)
 278         (t
 279          ;; We check for T and NIL quickly, otherwise go for the database.
 280          (mevalp_tr form $prederror nil))))
 281
 282 (defun maybe-boole-check (form)
 283   (mevalp_tr form nil nil))
 284
 285 (defun mevalp_tr (pat error? meval?)
 286   (let (patevalled ans)
 287     (declare (special patevalled))
 288     (setq ans (mevalp1_tr pat error? meval?))
 289     (cond ((member ans '(t nil) :test #'eq) ans)
 290           (error?
 291            (pre-err patevalled))
 292           ('else '$unknown))))
 293
 294 (defun mevalp1_tr (pat error? meval?)
 295   (declare (special patevalled))
 296   (cond ((and (not (atom pat)) (member (caar pat) '(mnot mand mor) :test #'eq))
 297          (cond ((eq 'mnot (caar pat)) (is-mnot_tr (cadr pat) error? meval?))
 298                ((eq 'mand (caar pat)) (is-mand_tr (cdr pat) error? meval?))
 299                (t (is-mor_tr (cdr pat) error? meval?))))
 300         ((atom (setq patevalled (if meval? (meval pat) pat))) patevalled)
 301         ((member (caar patevalled) '(mnot mand mor) :test #'eq) (mevalp1_tr patevalled
 302                                                                             error?
 303                                                                             meval?))
 304         (t (mevalp2 patevalled (caar patevalled) (cadr patevalled) (caddr patevalled)))))
 305
 306 (defun is-mnot_tr (pred error? meval?)
 307   (setq pred (mevalp_tr pred error? meval?))
 308   (cond ((eq t pred) nil)
 309         ((not pred))
 310         (t (pred-reverse pred))))
 311
 312 (defun is-mand_tr (pl error? meval?)
 313   (do ((dummy) (npl))
 314       ((null pl) (cond ((null npl))
 315                        ((null (cdr npl)) (car npl))
 316                        (t (cons '(mand) (nreverse npl)))))
 317     (setq dummy (mevalp_tr (car pl) error? meval?)
 318           pl (cdr pl))
 319     (cond ((eq t dummy))
 320           ((null dummy) (return nil))
 321           (t (setq npl (cons dummy npl))))))
 322
 323 (defun is-mor_tr (pl error? meval?)
 324   (do ((dummy) (npl))
 325       ((null pl) (cond ((null npl) nil)
 326                        ((null (cdr npl)) (car npl))
 327                        (t (cons '(mor) (nreverse npl)))))
 328     (setq dummy (mevalp_tr (car pl) error? meval?)
 329           pl (cdr pl))
 330     (cond ((eq t dummy) (return t))
 331           ((null dummy))
 332           (t (setq npl (cons dummy npl))))))
 333
 334 ;; Some functions for even faster calling of arrays.
 335
 336 (defun marrayref1$ (aarray index)
 337   (typecase aarray
 338     (cl:array
 339      (case (array-element-type aarray)
 340        ((flonum) (aref aarray index))
 341        (t (merror (intl:gettext "MARRAYREF1$: array must be an array of floats; found ~M") aarray))))
 342     (t
 343      (marrayref aarray index))))
 344
 345 (defun marrayset1$ (value aarray index)
 346   (typecase aarray
 347     (cl:array
 348      (case (array-element-type aarray)
 349        ((flonum) (setf (aref aarray index) value))
 350        (t (merror (intl:gettext "MARRAYSET1$: array must be an array of floats; found ~M") aarray))))
 351     (t
 352      (marrayset value aarray index))))
 353
 354
 355 (defun application-operator (form &rest ign)
 356   (declare (ignore ign))
 357   (apply (caar form) (cdr form)))
 358
 359 ;; more efficient operators calls.
 360
 361 (defun *mminus (x)
 362   (if (numberp x)
 363       (- x)
 364       (simplify (list '(mminus) x))))
 365
 366 (defun retlist_tr (&rest args)
 367   (do ((j (- (length args) 2) (- j 2))
 368        (l () (cons (list '(mequal simp) (nth j args) (nth (1+ j) args)) l)))
 369       ((< j 0) (cons '(mlist simp) l))))