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 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))))