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