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                         (aref (symbol-array (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 (defun boole-verify (form error? $unknown?)
 271   (cond ((typep form 'boolean)
 272          form)
 273         (error?
 274          (pre-err form))
 275         ($unknown?
 276          '$unknown)
 277         (t
 278          form)))
 279
 280 (defun boole-eval (form error? $unknown?)
 281   (if (typep form 'boolean)
 282       form
 283       (let ((ans (mevalp_tr form error?)))
 284         (if (or (typep ans 'boolean)
 285                 (not $unknown?))
 286             ans
 287             '$unknown))))
 288
 289 (defun $is-boole-verify (form)
 290   (boole-verify form $prederror t))
 291
 292 (defun $is-boole-eval (form)
 293   (boole-eval form $prederror t))
 294
 295 (setf (get '$is 'tr-boole-verify) '$is-boole-verify)
 296 (setf (get '$is 'tr-boole-eval) '$is-boole-eval)
 297
 298 (defun $maybe-boole-verify (form)
 299   (boole-verify form nil t))
 300
 301 (defun $maybe-boole-eval (form)
 302   (boole-eval form nil t))
 303
 304 (setf (get '$maybe 'tr-boole-verify) '$maybe-boole-verify)
 305 (setf (get '$maybe 'tr-boole-eval) '$maybe-boole-eval)
 306
 307 (defun mcond-boole-verify (form)
 308   (boole-verify form $prederror nil))
 309
 310 (defun mcond-boole-eval (form)
 311   (boole-eval form $prederror nil))
 312
 313 (setf (get 'mcond 'tr-boole-verify) 'mcond-boole-verify)
 314 (setf (get 'mcond 'tr-boole-eval) 'mcond-boole-eval)
 315
 316 (defun mevalp_tr (pat error?)
 317   (boole-verify (mevalp1_tr pat error?) error? nil))
 318
 319 (defun mevalp1_tr (pat error?)
 320   (cond ((atom pat) pat)
 321         ((member (caar pat) '(mnot mand mor) :test #'eq)
 322          (flet ((pred-eval (o) (mevalp_tr o error?)))
 323            (cond ((eq 'mnot (caar pat)) (is-mnot #'pred-eval (cadr pat)))
 324                  ((eq 'mand (caar pat)) (is-mand #'pred-eval (cdr pat)))
 325                  (t (is-mor #'pred-eval (cdr pat))))))
 326         (t
 327          (let ((ans (mevalp2 pat (caar pat) (cadr pat) (caddr pat))))
 328            (if (typep ans 'boolean)
 329                ans
 330                pat)))))
 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))))