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.
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.
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/>.
16 (defun upgraded-array-element-type (typespec &optional environment)
17 (declare (ignore environment))
18 (if (eq typespec 'character)
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)))
27 (if (eq element-type 'character)
29 (oset 1 array "stringp")
30 (setf element-type 'character
31 initial-element (or initial-element #\space)))
32 (setf element-type t))
35 (storage-vector-set array i initial-element))
36 ;; Record and return the object
37 (oset element-type array "type")
38 (oset dimensions array "dimensions")
45 (defun adjustable-array-p (array)
46 (unless (arrayp array)
47 (error "~S is not an array." array))
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)
57 (defun array-dimensions (array)
58 (unless (arrayp array)
59 (error "~S is not an array." array))
60 (oget array "dimensions"))
62 ;; TODO: Error checking
63 (defun array-dimension (array axis)
64 (nth axis (array-dimensions array)))
66 (defun aref (array index)
67 (unless (arrayp array)
68 (error "~S is not an array." array))
69 (storage-vector-ref array index))
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))
76 (define-setf-expander aref (array index)
77 (let ((g!array (gensym))
80 (values (list g!array g!index)
83 `(aset ,g!array ,g!index ,g!value)
84 `(aref ,g!array ,g!index))))
90 (and (arrayp x) (null (cdr (array-dimensions x)))))
92 (defun vector (&rest objects)
93 (let* ((length (length objects))
94 (array (make-array length :element-type t))
96 (dolist (element objects array) ;; poor-man's :initial-contents
97 (aset array i element)
100 ;;; FIXME: should take optional min-extension.
101 ;;; FIXME: should use fill-pointer instead of the absolute end of array
102 (defun vector-push-extend (new vector)
103 (unless (vectorp vector)
104 (error "~S is not a vector." vector))
105 (let ((size (storage-vector-size vector)))
106 (resize-storage-vector vector (1+ size))
107 (aset vector size new)