From: David Vázquez <davazp@gmail.com>
Date: Fri, 24 May 2013 00:42:18 +0000 (+0100)
Subject: Basic storage vectors operations and array construction
X-Git-Url: http://repo.macrolet.net/gitweb/?p=jscl.git;a=commitdiff_plain;h=72a15805ea06efb88cf7d1dd5958617349aaf8f5

Basic storage vectors operations and array construction
---

diff --git a/jscl.lisp b/jscl.lisp
index 7a5e35a..0f0e6be 100644
--- a/jscl.lisp
+++ b/jscl.lisp
@@ -26,14 +26,15 @@
   '(("boot"             :target)
     ("compat"           :host)
     ("utils"            :both)
+    ("numbers"          :target)
     ("list"             :target)
+    ("arrays"           :target)
     ("string"           :target)
     ("sequence"         :target)
     ("print"            :target)
     ("package"          :target)
     ("ffi"              :target)
     ("misc"             :target)
-    ("numbers"          :target)
     ("read"             :both)
     ("defstruct"        :both)
     ("lambda-list"      :both)
diff --git a/src/arrays.lisp b/src/arrays.lisp
index 0c614cf..0f6698a 100644
--- a/src/arrays.lisp
+++ b/src/arrays.lisp
@@ -19,12 +19,45 @@
       'character
       t))
 
-(defun arrayp (x) (arrayp x))
+(defun make-array (dimensions &key element-type initial-element adjustable fill-pointer)
+  (let* ((dimensions (ensure-list dimensions))
+         (size (!reduce #'* dimensions 1))
+         (array (make-storage-vector size)))
+    ;; Upgrade type
+    (if (eq element-type 'character)
+        (setf element-type 'character
+              initial-element (or initial-element #\space))
+        (setf element-type t))
+    ;; Initialize array
+    (dotimes (i size)
+      (storage-vector-set array i initial-element))
+    ;; Record and return the object
+    (oset array "type" element-type)
+    (oset array "dimensions" dimensions)
+    array))
+
+
+(defun arrayp (x)
+  (storage-vector-p x))
 
 (defun adjustable-array-p (array)
   (unless (arrayp array)
     (error "~S is not an array." array))
   t)
 
-(defun make-array (dimensions &key element-type initial-contents adjustable fill-pointer)
-  )
+(defun array-element-type (array)
+  (unless (arrayp array)
+    (error "~S is not an array." array))
+  (oget array "type"))
+
+(defun array-dimensions (array)
+  (unless (arrayp array)
+    (error "~S is not an array." array))
+  (oget array "dimensions"))
+
+;; TODO: Error checking
+(defun array-dimension (array axis)
+  (nth axis (array-dimensions array)))
+
+(defun vectorp (x)
+  (and (arrayp x) (null (cdr (array-dimensions x)))))
diff --git a/src/compiler.lisp b/src/compiler.lisp
index 763aa92..aca3a2b 100644
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -1544,13 +1544,42 @@
 (define-builtin write-string (x)
   (code "lisp.write(" x ")"))
 
-(define-builtin make-array (n)
+
+;;; Storage vectors. They are used to implement arrays and (in the
+;;; future) structures.
+
+(define-builtin storage-vector-p (x)
+  (js!bool
+   (js!selfcall
+     "var x = " x ";" *newline*
+     "return typeof x === 'object' && 'length' in x;")))
+
+(define-builtin make-storage-vector (n)
   (js!selfcall
     "var r = [];" *newline*
-    "for (var i = 0; i < " n "; i++)" *newline*
-    (indent "r.push(" (ls-compile nil) ");" *newline*)
+    "r.length = " n ";" *newline*
     "return r;" *newline*))
 
+(define-builtin storage-vector-size (x)
+  (code x ".length"))
+
+(define-builtin resize-storage-vector (vector new-size)
+  (code "(" vector ".length = " new-size ")"))
+
+(define-builtin storage-vector-ref (vector n)
+  (js!selfcall
+    "var x = " "(" vector ")[" n "];" *newline*
+    "if (x === undefined) throw 'Out of range';" *newline*
+    "return x;" *newline*))
+
+(define-builtin storage-vector-set (vector n value)
+  (js!selfcall
+    "var x = " vector ";" *newline*
+    "var i = " n ";" *newline*
+    "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
+    "return x[i] = " value ";" *newline*))
+
+
 ;;; FIXME: should take optional min-extension.
 ;;; FIXME: should use fill-pointer instead of the absolute end of array
 (define-builtin vector-push-extend (new vector)
@@ -1559,12 +1588,6 @@
     "v.push(" new ");" *newline*
     "return v;"))
 
-(define-builtin arrayp (x)
-  (js!bool
-   (js!selfcall
-     "var x = " x ";" *newline*
-     "return typeof x === 'object' && 'length' in x;")))
-
 (define-builtin aref (array n)
   (js!selfcall
     "var x = " "(" array ")[" n "];" *newline*
@@ -1590,6 +1613,8 @@
     "var n = " new-size ";" *newline*
     "return x.length = n;" *newline*))
 
+
+
 (define-builtin get-internal-real-time ()
   "(new Date()).getTime()")
 
diff --git a/src/print.lisp b/src/print.lisp
index 7daa143..cb4a442 100644
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -142,7 +142,7 @@
                     (when (mark x)
                       (visit (car x))
                       (visit (cdr x))))
-                   ((arrayp x)
+                   ((vectorp x)
                     (when (mark x)
                       (dotimes (i (length x))
                         (visit (aref x i))))))))
@@ -150,7 +150,7 @@
   (let ((prefix ""))
     (when (and *print-circle*
                (or (consp form)
-                   (arrayp form)
+                   (vectorp form)
                    (and form (symbolp form) (null (symbol-package form)))))
       (let* ((ix (afind form known-objects))
              (id (aref object-ids ix)))
@@ -213,7 +213,7 @@
                                      " . "
                                      (write-to-string (cdr last) known-objects object-ids))))
                        ")"))
-              ((arrayp form)
+              ((vectorp form)
                (let ((result "#(")
                      (sep ""))
                  (dotimes (i (length form))
diff --git a/src/string.lisp b/src/string.lisp
index 8bead9b..7e9ae1e 100644
--- a/src/string.lisp
+++ b/src/string.lisp
@@ -13,6 +13,9 @@
 ;; You should have received a copy of the GNU General Public License
 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
 
+;; (defun stringp (x)
+;;   (and (vectorp x) (eq (array-element-type x) 'character)))
+
 (defun string (x)
   (cond ((stringp x) x)
         ((symbolp x) (symbol-name x))