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 (defun upgraded-array-element-type (typespec &optional environment)
  17   (declare (ignore environment))
  18   (if (eq typespec 'character)
  19       'character
  20       t))
  21
  22 (defun make-array (dimensions &key element-type initial-element adjustable fill-pointer)
  23   (let* ((dimensions (ensure-list dimensions))
  24          (size (!reduce #'* dimensions 1))
  25          (array (make-storage-vector size)))
  26     ;; Upgrade type
  27     (if (eq element-type 'character)
  28         (progn
  29           (oset array "stringp" 1)
  30           (setf element-type 'character
  31                 initial-element (or initial-element #\space)))
  32         (setf element-type t))
  33     ;; Initialize array
  34     (dotimes (i size)
  35       (storage-vector-set array i initial-element))
  36     ;; Record and return the object
  37     (oset array "type" element-type)
  38     (oset array "dimensions" dimensions)
  39     array))
  40
  41
  42 (defun arrayp (x)
  43   (storage-vector-p x))
  44
  45 (defun adjustable-array-p (array)
  46   (unless (arrayp array)
  47     (error "~S is not an array." array))
  48   t)
  49
  50 (defun array-element-type (array)
  51   (unless (arrayp array)
  52     (error "~S is not an array." array))
  53   (if (eq (oget array "stringp") 1)
  54       'character
  55       (oget array "type")))
  56
  57 (defun array-dimensions (array)
  58   (unless (arrayp array)
  59     (error "~S is not an array." array))
  60   (oget array "dimensions"))
  61
  62 ;; TODO: Error checking
  63 (defun array-dimension (array axis)
  64   (nth axis (array-dimensions array)))
  65
  66 (defun aref (array index)
  67   (unless (arrayp array)
  68     (error "~S is not an array." array))
  69   (storage-vector-ref array index))
  70
  71 (defun aset (array index value)
  72   (unless (arrayp array)
  73     (error "~S is not an array." array))
  74   (storage-vector-set array index value))
  75
  76
  77 ;;; Vectors
  78
  79 (defun vectorp (x)
  80   (and (arrayp x) (null (cdr (array-dimensions x)))))
  81
  82 ;;; FIXME: should take optional min-extension.
  83 ;;; FIXME: should use fill-pointer instead of the absolute end of array
  84 (defun vector-push-extend (new vector)
  85   (unless (vectorp vector)
  86     (error "~S is not a vector." vector))
  87   (let ((size (storage-vector-size vector)))
  88     (resize-storage-vector vector (1+ size))
  89     (aset vector size new)
  90     size))