src/array.lisp

   1 ;;; arrays.lisp
   2
   3 ;; JSCL is free software: you can redistribute it and/or
   4 ;; modify it under the terms of the GNU General Public License as
   5 ;; published by the Free Software Foundation, either version 3 of the
   6 ;; License, or (at your option) any later version.
   7 ;;
   8 ;; JSCL is distributed in the hope that it will be useful, but
   9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;; General Public License for more details.
  12 ;;
  13 ;; You should have received a copy of the GNU General Public License
  14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 (/debug "loading array.lisp!")
  17
  18 (defun upgraded-array-element-type (typespec &optional environment)
  19   (declare (ignore environment))
  20   (if (eq typespec 'character)
  21       'character
  22       t))
  23
  24 (defun make-array (dimensions &key element-type initial-element adjustable fill-pointer)
  25   (let* ((dimensions (ensure-list dimensions))
  26          (size (!reduce #'* dimensions 1))
  27          (array (make-storage-vector size)))
  28     ;; Upgrade type
  29     (if (eq element-type 'character)
  30         (progn
  31           (oset 1 array "stringp")
  32           (setf element-type 'character
  33                 initial-element (or initial-element #\space)))
  34         (setf element-type t))
  35     ;; Initialize array
  36     (dotimes (i size)
  37       (storage-vector-set array i initial-element))
  38     ;; Record and return the object
  39     (oset element-type array "type")
  40     (oset dimensions array "dimensions")
  41     array))
  42
  43
  44 (defun arrayp (x)
  45   (storage-vector-p x))
  46
  47 (defun adjustable-array-p (array)
  48   (unless (arrayp array)
  49     (error "~S is not an array." array))
  50   t)
  51
  52 (defun array-element-type (array)
  53   (unless (arrayp array)
  54     (error "~S is not an array." array))
  55   (if (eq (oget array "stringp") 1)
  56       'character
  57       (oget array "type")))
  58
  59 (defun array-dimensions (array)
  60   (unless (arrayp array)
  61     (error "~S is not an array." array))
  62   (oget array "dimensions"))
  63
  64 ;; TODO: Error checking
  65 (defun array-dimension (array axis)
  66   (nth axis (array-dimensions array)))
  67
  68 (defun aref (array index)
  69   (unless (arrayp array)
  70     (error "~S is not an array." array))
  71   (storage-vector-ref array index))
  72
  73 (defun aset (array index value)
  74   (unless (arrayp array)
  75     (error "~S is not an array." array))
  76   (storage-vector-set array index value))
  77
  78 (define-setf-expander aref (array index)
  79   (let ((g!array (gensym))
  80         (g!index (gensym))
  81         (g!value (gensym)))
  82     (values (list g!array g!index)
  83             (list array index)
  84             (list g!value)
  85             `(aset ,g!array ,g!index ,g!value)
  86             `(aref ,g!array ,g!index))))
  87
  88
  89 ;;; Vectors
  90
  91 (defun vectorp (x)
  92   (and (arrayp x) (null (cdr (array-dimensions x)))))
  93
  94 (defun vector (&rest objects)
  95   (list-to-vector objects))
  96
  97 ;;; FIXME: should take optional min-extension.
  98 ;;; FIXME: should use fill-pointer instead of the absolute end of array
  99 (defun vector-push-extend (new vector)
 100   (unless (vectorp vector)
 101     (error "~S is not a vector." vector))
 102   (let ((size (storage-vector-size vector)))
 103     (resize-storage-vector vector (1+ size))
 104     (aset vector size new)
 105     size))