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