src/acall.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancements.                   ;;;;;
   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   (typecase aarray
  40     (cl:array
  41      (case (array-element-type aarray)
  42        ((flonum fixnum t)
  43         (apply #'aref aarray ind1 inds))
  44        (t
  45         (merror (intl:gettext "MARRAYREF: encountered array ~M of unknown type.") aarray))))
  46     (cl:hash-table
  47      (gethash (if inds (cons ind1 inds) ind1) aarray))
  48     (cl:symbol
  49      (if $use_fast_arrays
  50          (let ((tem (and (boundp aarray) (symbol-value aarray))))
  51            (simplify (cond ((arrayp tem)
  52                             (apply #'aref tem ind1 inds))
  53                            ((hash-table-p tem)
  54                             (gethash (if inds (cons ind1 inds) ind1) tem))
  55                            ((eq aarray 'mqapply)
  56                             (apply #'marrayref ind1 inds))
  57                            ((mget aarray 'hashar)
  58                             (harrfind `((,aarray array) ,ind1 ,@inds)))
  59                            ((symbolp tem)
  60                             `((,tem array) ,ind1 ,@inds))
  61                            (t
  62                             (error "unknown type of array for use_fast_arrays. ~
  63                                the value cell should have the array or hash table")))))
  64          (let (ap)                      ; no fast arrays
  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 array) ,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     (cl:list
  86      (simplify (if (member (caar aarray) '(mlist $matrix) :test #'eq)
  87                    (list-ref aarray (cons ind1 inds))
  88                    `((mqapply array) ,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 (defun marrayset (val aarray &rest all-inds)
 103   (let ((ind1 (first all-inds))
 104         (inds (rest all-inds)))
 105     (typecase aarray
 106       (cl:array
 107        (case (array-element-type aarray)
 108          ((fixnum flonum t)
 109           (setf (apply #'aref aarray ind1 inds) val))
 110          (t
 111           (merror (intl:gettext "MARRAYSET: encountered array ~M of unknown type.") aarray))))
 112       (cl:hash-table
 113        (setf (gethash (if (cdr all-inds)
 114                           (copy-list all-inds)
 115                           (car all-inds))
 116                       aarray) val))
 117       (cl:symbol
 118        (let (ap)
 119          (cond ((setq ap (get aarray 'array))
 120                 (if (null inds)
 121                     (setf (aref ap ind1) val)
 122                     (setf (apply #'aref ap all-inds) val)))
 123                ((setq ap (mget aarray 'array))
 124                 ;; the macsyma ARRAY frob is NOT an array pointer, it
 125                 ;; is a GENSYM with a lisp array property, don't
 126                 ;; ask me why.
 127                 (if (null inds)
 128                     (setf (aref (symbol-array ap) ind1) val)
 129                     (setf (apply #'aref (symbol-array ap) all-inds) val)))
 130                ((setq ap (mget aarray 'hashar))
 131                 (arrstore `((,aarray ,'array)
 132                             ,@(mapcar #'(lambda (u) `((mquote simp) ,u)) all-inds))
 133                           val))
 134                ((eq aarray 'mqapply)
 135                 (apply #'marrayset val ind1 inds))
 136                (t
 137                 (arrstore `((,aarray ,'array)
 138                             ,@(mapcar #'(lambda (u) `((mquote simp) ,u)) all-inds))
 139                           val)))))
 140       (cl:list (if (member (caar aarray) '(mlist $matrix) :test #'eq)
 141                    (list-ref aarray all-inds t val)
 142                    (merror (intl:gettext "MARRAYSET: cannot assign to an element of ~M") aarray)))
 143       (t
 144        (merror (intl:gettext "MARRAYSET: ~M is not an array.") aarray)))      )
 145   val)
 146
 147 ;;; Note that all these have HEADERS on the list. The CAR of a list I
 148 ;;; will call element 0. So [1,2][1] => 1
 149
 150 (defun list-ref (l indexl &optional set-flag val)
 151   (cond ((atom l)
 152          (merror (intl:gettext "LIST-REF: argument must be a list; found ~M") l))
 153         ((null (cdr indexl))
 154          (let ((n (car indexl)))
 155            (cond ((and (integerp n) (plusp n)
 156                        (or (eq (caar l) 'mlist)
 157                            (eq (caar l) '$matrix)))
 158                   (let ((ret (do ((j 1 (1+ j))
 159                                   (l (cdr l) (cdr l)))
 160                                  ((or (null l) (= j n))
 161                                   (cond ((null l)
 162                                          (merror (intl:gettext "LIST-REF: invalid subscript: ~M") n))
 163                                         (set-flag
 164                                          (rplaca l val))
 165                                         (t
 166                                          (car l)))))))
 167                     (if set-flag l ret)))
 168                  (t
 169                   (merror (intl:gettext "LIST-REF: invalid subscript: ~M") n)))))
 170         (set-flag
 171          (list-ref (list-ref l `(,(car indexl))) (cdr indexl) set-flag val)
 172          l)
 173         (t
 174          (list-ref (list-ref l `(,(car indexl))) (cdr indexl)))))
 175
 176 (defun display-for-tr (labelsp equationsp &rest argl)
 177   (do ((argl argl (cdr argl))
 178        (lablist nil)
 179        (tim 0))
 180       ((null argl) (if labelsp `((mlist) ,@(nreverse 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              ;; already 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       (let ((*display-labels-p* (not (null lablist))))
 201         (displa `((mlabel) ,(cond (labelsp *linelabel*)) ,ans)))
 202       (mterpri)
 203       (timeorg tim))))
 204
 205
 206 (defun insure-array-props (fnname ignore-mode number-of-args &aux ary)
 207   (declare (ignore ignore-mode))
 208   ;; called during load or eval time by the defining forms
 209   ;; for translated array-functions.
 210   ;; this duplicates code in JPG;MLISP (however, the code in MLISP
 211   ;; is not callable because it is in a big piece of so-called
 212   ;; multi-purpose code).
 213
 214   ;; This code is incredibly kludgy. For example, what if
 215   ;; the function FOO[J] had a lisp array property gotten
 216   ;; by ARRAY(FOO,FIXNUM,33), how is *THAT* detected by this code?
 217   ;; Well, it is because that will also put an MPROP ARRAY of $FOO,
 218   ;; and (ARRAYDIMS '$FOO) works! (Also checks the array property).
 219   ;; Isn't that something. Shit, I never knew that ARRAYDIMS worked
 220   ;; on symbols. What a crock.
 221   (cond ((prog2
 222              (add2lnc fnname $arrays)
 223              (setq ary (mgetl fnname '(hashar array))))
 224          (unless (= (if (eq (car ary) 'hashar)
 225                         (aref (symbol-array (cadr ary)) 2)
 226                         (length (cdr (arraydims (cadr ary)))))
 227                     number-of-args)
 228            (merror (intl:gettext "INSURE-ARRAY-PROPS: array ~:@M already defined with different dimensions.") fnname)))
 229         (t
 230          (setq ary (gensym))
 231          (mputprop fnname ary 'hashar)
 232          (setf (symbol-array ary) (make-array 7 :initial-element nil))
 233          (setf (aref (symbol-array ary) 0) 4)
 234          (setf (aref (symbol-array ary) 1) 0)
 235          (setf (aref (symbol-array ary) 2) number-of-args))))
 236
 237 ;;; An entry point to $APPLY for translated code.
 238
 239 (defun mapply-tr (fun list)
 240   (unless ($listp list)
 241     (merror (intl:gettext "apply: second argument must be a list; found ~M") list))
 242   (mapply1 fun (cdr list) '|the first arg to a translated `apply'| list))
 243
 244 (defun assign-check (var val)
 245   (let ((a (get var 'assign)))
 246     (if a (funcall a var val))))
 247
 248 (defun maplist_tr (fun  l1 &rest l)
 249   (setq l (cons l1 (copy-list l)))
 250   (simplify (let ((maplp t) res)
 251               (setq res (apply #'map1 (getopr fun) l))
 252               (cond ((atom res) (list '(mlist) res))
 253                     ((eq (caar res) 'mlist) res)
 254                     (t (cons '(mlist) (margs res)))))))
 255
 256 ;;; Entry point into DB for translated code. The main point here
 257 ;;; is that evaluation of a form takes place first, (using the lisp
 258 ;;; evaluator), and then the trueness is checked. It is not correct
 259 ;;; to call the function IS because double-evaluation will then
 260 ;;; result, which is wrong, not to mention being incompatible with
 261 ;;; the interpreter.
 262
 263 (defun boole-verify (form error? $unknown?)
 264   (cond ((typep form 'boolean)
 265          form)
 266         (error?
 267          (pre-err form))
 268         ($unknown?
 269          '$unknown)
 270         (t
 271          form)))
 272
 273 (defun boole-eval (form error? $unknown?)
 274   (if (typep form 'boolean)
 275       form
 276       (let ((ans (mevalp_tr form error?)))
 277         (if (or (typep ans 'boolean)
 278                 (not $unknown?))
 279             ans
 280             '$unknown))))
 281
 282 (defun $is-boole-verify (form)
 283   (boole-verify form $prederror t))
 284
 285 (defun $is-boole-eval (form)
 286   (boole-eval form $prederror t))
 287
 288 (setf (get '$is 'tr-boole-verify) '$is-boole-verify)
 289 (setf (get '$is 'tr-boole-eval) '$is-boole-eval)
 290
 291 (defun $maybe-boole-verify (form)
 292   (boole-verify form nil t))
 293
 294 (defun $maybe-boole-eval (form)
 295   (boole-eval form nil t))
 296
 297 (setf (get '$maybe 'tr-boole-verify) '$maybe-boole-verify)
 298 (setf (get '$maybe 'tr-boole-eval) '$maybe-boole-eval)
 299
 300 (defun mcond-boole-verify (form)
 301   (boole-verify form $prederror nil))
 302
 303 (defun mcond-boole-eval (form)
 304   (boole-eval form $prederror nil))
 305
 306 (setf (get 'mcond 'tr-boole-verify) 'mcond-boole-verify)
 307 (setf (get 'mcond 'tr-boole-eval) 'mcond-boole-eval)
 308
 309 (defun mevalp_tr (pat error?)
 310   (boole-verify (mevalp1_tr pat error?) error? nil))
 311
 312 (defun mevalp1_tr (pat error?)
 313   (cond ((atom pat) pat)
 314         ((member (caar pat) '(mnot mand mor) :test #'eq)
 315          (flet ((pred-eval (o) (mevalp_tr o error?)))
 316            (cond ((eq 'mnot (caar pat)) (is-mnot #'pred-eval (cadr pat)))
 317                  ((eq 'mand (caar pat)) (is-mand #'pred-eval (cdr pat)))
 318                  (t (is-mor #'pred-eval (cdr pat))))))
 319         (t
 320          (let ((ans (mevalp2 pat (caar pat) (cadr pat) (caddr pat))))
 321            (if (typep ans 'boolean)
 322                ans
 323                pat)))))
 324
 325 ;; Some functions for even faster calling of arrays.
 326
 327 (defun marrayref1$ (aarray index)
 328   (typecase aarray
 329     (cl:array
 330      (case (array-element-type aarray)
 331        ((flonum) (aref aarray index))
 332        (t (merror (intl:gettext "MARRAYREF1$: array must be an array of floats; found ~M") aarray))))
 333     (t
 334      (marrayref aarray index))))
 335
 336 (defun marrayset1$ (value aarray index)
 337   (typecase aarray
 338     (cl:array
 339      (case (array-element-type aarray)
 340        ((flonum) (setf (aref aarray index) value))
 341        (t (merror (intl:gettext "MARRAYSET1$: array must be an array of floats; found ~M") aarray))))
 342     (t
 343      (marrayset value aarray index))))
 344
 345
 346 (defun application-operator (form &rest ign)
 347   (declare (ignore ign))
 348   (apply (caar form) (cdr form)))
 349
 350 ;; more efficient operators calls.
 351
 352 (defun *mminus (x)
 353   (if (numberp x)
 354       (- x)
 355       (simplify (list '(mminus) x))))
 356
 357 (defun retlist_tr (&rest args)
 358   (do ((j (- (length args) 2) (- j 2))
 359        (l () (cons (list '(mequal simp) (nth j args) (nth (1+ j) args)) l)))
 360       ((< j 0) (cons '(mlist simp) l))))