src/ar.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 (macsyma-module ar)
  14
  15 (declare-top (special evarrp munbound flounbound fixunbound $use_fast_arrays))
  16
  17 (defstruct (mgenarray (:conc-name mgenarray-))
  18   aref
  19   aset
  20   type
  21   null
  22   generator
  23   content)
  24
  25 (deftype marray ()
  26   `(or cl:array hash-table mgenarray))
  27
  28 (defun marrayp (x)
  29   (typep x 'marray))
  30
  31 (defun marray-type (x)
  32   ;; XXX: should this be etypecase? -rss
  33   (typecase x
  34     (cl:array   'array)
  35     (hash-table 'hash-table)
  36     (mgenarray  (mgenarray-type x))))
  37
  38 (defmfun $make_array (type &rest diml)
  39   (let ((ltype (assoc type '(($float . flonum)
  40                              ($flonum . flonum)
  41                              ($fixnum . fixnum)))))
  42     ;; Check the dimensions. No check for number of dimensions.
  43     (when (member nil
  44                   (mapcar #'(lambda (u) (fixnump u))
  45                           ;; For a functional array the list of dimensions
  46                           ;; starts at the third element of the list diml
  47                           (if (eq type '$functional)
  48                               (cddr diml)
  49                               diml))
  50                   :test #'eq)
  51       (merror (intl:gettext "make_array: dimensions must be integers; found ~M")
  52               `((mlist) ,@diml)))
  53     (if (not ltype)
  54         (case type
  55           ($any
  56            (make-array diml :initial-element nil))
  57           ($hashed
  58            (make-equal-hash-table (cdr diml)))
  59           ($functional
  60            ;; MAKE_ARRAY('FUNCTIONAL, LAMBDA(...), 'ARRAY_TYPE, ...)
  61            ;; This is a memoizing array.
  62            (unless (> (length diml) 1)
  63              (merror (intl:gettext "make_array: not enough arguments for functional array specification.")))
  64            (let ((ar (apply #'$make_array (cadr diml) (cddr diml)))
  65                  (the-null))
  66              (case (cadr diml)
  67                ($fixnum
  68                  (fillarray ar (list (setq the-null fixunbound))))
  69                (($flonum $float)
  70                 (fillarray ar (list (setq the-null flounbound))))
  71                ($any
  72                 (fillarray ar (list (setq the-null munbound))))
  73                (t
  74                 ;; Nothing to do for hashed arrays. Is FUNCTIONAL here an error?
  75                 ;; No, it is the most useful case for a FUNCTIONAL array.
  76                 (setq the-null nil)))
  77              (make-mgenarray :type '$functional
  78                              :content ar
  79                              :generator (car diml)
  80                              :null the-null)))
  81           (t
  82            (merror (intl:gettext "make_array: array type ~M not recognized.")
  83                    type)))
  84         (make-array diml :initial-element (case (cdr ltype)
  85                                             (fixnum 0)
  86                                             (flonum 0.0)
  87                                             (otherwise nil))))))
  88
  89 (defun dimension-array-object (form result)
  90   (let ((mtype (marray-type form)))
  91     (if (eq mtype '$functional)
  92         (dimension-array-object (mgenarray-content form) result)
  93         (dimension-atom (format nil "{Lisp Array: ~A}" form) result))))
  94
  95 (defun msize-array-object (x l r)
  96   (let ((mtype (marray-type x)))
  97     (if (eq mtype '$functional)
  98         (msize-array-object (mgenarray-content x) l r)
  99         (msize-atom (format nil "{Lisp Array: ~A}" x) l r))))
 100
 101 (defun marray-check (a)
 102   (if (marrayp a)
 103       (case (marray-type a)
 104         (($fixnum $float) a)
 105         (($any) (mgenarray-content a))
 106         (($hashed $functional)
 107          ;; BUG: It does have a number of dimensions! Gosh. -GJC
 108          (merror (intl:gettext "MARRAY-CHECK: hashed array ~M has no dimension data.") a))
 109         (t
 110          (marray-type-unknown a)))
 111       (merror (intl:gettext "MARRAY-CHECK: not an array: ~M") a)))
 112
 113 (defmfun $array_dimension_n (n a)
 114   (array-dimension (marray-check a) n))
 115
 116 (defun marray-type-unknown (x)
 117   (merror (intl:gettext "MARRAY-TYPE-UNKNOWN: array type ~S not recognized.")
 118           x))
 119
 120 (defun marrayref-gensub (aarray ind1 inds)
 121   (case (marray-type aarray)
 122     ;; We are using a CASE on the TYPE instead of a FUNCALL, (or SUBRCALL)
 123     ;; because we are losers. All this stuff uses too many functions from
 124     ;; the "MLISP" modual, which are not really suitable for the kind of
 125     ;; speed and simplicity we want anyway. Ah me. Also, passing the single
 126     ;; unconsed index IND1 around is a dubious optimization, which causes
 127     ;; extra consing in the case of hashed arrays.
 128     ((array)
 129      (unless (and (integerp ind1) (every #'integerp inds))
 130        (bad-index-error (cons ind1 inds)))
 131      (apply #'aref aarray ind1 inds))
 132     ((hash-table) (gethash (if inds (cons ind1 inds) ind1) aarray))
 133     (($functional)
 134      (let ((value (let ((evarrp t))
 135                     ;; special variable changes behavior of hashed-array
 136                     ;; referencing functions in case of not finding an element.
 137                     (catch 'evarrp (marrayref-gensub
 138                                     (mgenarray-content aarray) ind1 inds)))))
 139        (if (equal value (mgenarray-null aarray))
 140            (marrayset-gensub  (apply #'mfuncall
 141                                      (mgenarray-generator aarray)
 142                                      ;; the first argument we pass the
 143                                      ;; function is a SELF variable.
 144 ;                                    aarray
 145                                      ;; extra consing here! LEXPR madness.
 146                                      ind1
 147                                      inds)
 148                               (mgenarray-content aarray) ind1 inds)
 149            value)))
 150     (t
 151      (marray-type-unknown aarray))))
 152
 153 ;; INDICES is a Lisp list, not a Maxima list.
 154 (defun bad-index-error (indices)
 155   (let ((m-indices (cons '(mlist) indices)))
 156     (cond
 157       ((every #'(lambda (x) (or (specrepp x) (integerp x))) indices)
 158        (merror (intl::gettext "array: indices cannot be special expressions (CRE, Taylor or Poisson); found: ~M") m-indices))
 159       ((every #'(lambda (x) (or ($mapatom x) (integerp x))) indices)
 160        (merror (intl::gettext "array: indices cannot be plain or subscripted symbols; found: ~M") m-indices))
 161       (t
 162         (merror (intl::gettext "array: indices must be literal integers; found: ~M") m-indices)))))
 163
 164 (defun marrayset-gensub (val aarray ind1 inds)
 165   (case (marray-type aarray)
 166     ((array)
 167      (unless (and (integerp ind1) (every #'integerp inds))
 168        (bad-index-error (cons ind1 inds)))
 169      (setf (apply #'aref aarray ind1 inds) val))
 170     ((hash-table) (setf (gethash (if inds (cons ind1 inds) ind1) aarray) val))
 171     (($functional)
 172      (marrayset-gensub val (mgenarray-content aarray) ind1 inds))
 173     (t
 174      (marray-type-unknown aarray))))
 175
 176 ;; Extensions to MEVAL.
 177
 178 (defun meval1-extend (form)
 179   (let ((l (mevalargs (cdr form))))
 180     (marrayref-gensub (caar form) (car l) (cdr l))))
 181
 182 (defun arrstore-extend (a l r)
 183   (marrayset-gensub r a (car l) (cdr l)))