Implement eq and equal hash tables
[jscl.git] / 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))