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