From: David Vázquez <davazp@gmail.com>
Date: Tue, 4 Jun 2013 02:01:03 +0000 (+0100)
Subject: Merge branch 'master' into arrays
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9b7eba02ada6840ce6b7cd272e6d3b9bc521180b;hp=6ec52a68fd2a26e18593f189b35722a3ca1011d8;p=jscl.git

Merge branch 'master' into arrays

Conflicts:
	jscl.lisp
	src/prelude.js
---

diff --git a/jscl.lisp b/jscl.lisp
index c975422..4b2ac4a 100644
--- a/jscl.lisp
+++ b/jscl.lisp
@@ -26,15 +26,16 @@
   '(("boot"             :target)
     ("compat"           :host)
     ("utils"            :both)
+    ("numbers"          :target)
+    ("char"             :target)
     ("list"             :target)
+    ("array"            :target)
     ("string"           :target)
     ("sequence"         :target)
     ("print"            :target)
     ("package"          :target)
     ("ffi"              :target)
     ("misc"             :target)
-    ("numbers"          :target)
-    ("char"             :target)
     ("read"             :both)
     ("defstruct"        :both)
     ("lambda-list"      :both)
diff --git a/src/array.lisp b/src/array.lisp
new file mode 100644
index 0000000..44ad0cf
--- /dev/null
+++ b/src/array.lisp
@@ -0,0 +1,90 @@
+;;; arrays.lisp
+
+;; JSCL is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; JSCL is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
+
+(defun upgraded-array-element-type (typespec &optional environment)
+  (declare (ignore environment))
+  (if (eq typespec 'character)
+      'character
+      t))
+
+(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)
+        (progn
+          (oset array "stringp" 1)
+          (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 array-element-type (array)
+  (unless (arrayp array)
+    (error "~S is not an array." array))
+  (if (eq (oget array "stringp") 1)
+      'character
+      (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 aref (array index)
+  (unless (arrayp array)
+    (error "~S is not an array." array))  
+  (storage-vector-ref array index))
+
+(defun aset (array index value)
+  (unless (arrayp array)
+    (error "~S is not an array." array))  
+  (storage-vector-set array index value))
+
+
+;;; Vectors
+
+(defun vectorp (x)
+  (and (arrayp x) (null (cdr (array-dimensions x)))))
+
+;;; FIXME: should take optional min-extension.
+;;; FIXME: should use fill-pointer instead of the absolute end of array
+(defun vector-push-extend (new vector)
+  (unless (vectorp vector)
+    (error "~S is not a vector." vector))  
+  (let ((size (storage-vector-size vector)))
+    (resize-storage-vector vector (1+ size))
+    (aset vector size new)
+    size))
diff --git a/src/boot.lisp b/src/boot.lisp
index 7605a29..dc9b45f 100644
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -526,9 +526,6 @@
 (defun get-universal-time ()
   (+ (get-unix-time) 2208988800))
 
-(defun concat (&rest strs)
-  (!reduce #'concat-two strs ""))
-
 (defun values-list (list)
   (values-array (list-to-vector list)))
 
diff --git a/src/compiler.lisp b/src/compiler.lisp
index e2f9fca..1fb6305 100644
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -1190,12 +1190,6 @@
      "var x = " x ";" *newline*
      "return (typeof(" x ") == \"string\") && (x.length == 1 || x.length == 2);")))
 
-(define-builtin char-to-string (x)
-  (js!selfcall
-    "var r = [" x "];" *newline*
-    "r.type = 'character';"
-    "return r"))
-
 (define-builtin char-upcase (x)
   (code "safe_char_upcase(" x ")"))
 
@@ -1206,30 +1200,7 @@
   (js!bool
    (js!selfcall
      "var x = " x ";" *newline*
-     "return typeof(x) == 'object' && 'length' in x && x.type == 'character';")))
-
-(define-builtin string-upcase (x)
-  (code "make_lisp_string(xstring(" x ").toUpperCase())"))
-
-(define-builtin string-length (x)
-  (code x ".length"))
-
-(define-raw-builtin slice (vector a &optional b)
-  (js!selfcall
-    "var vector = " (ls-compile vector) ";" *newline*
-    "var a = " (ls-compile a) ";" *newline*
-    "var b;" *newline*
-    (when b (code "b = " (ls-compile b) ";" *newline*))
-    "return vector.slice(a,b);" *newline*))
-
-(define-builtin char (string index)
-  (code string "[" index "]"))
-
-(define-builtin concat-two (string1 string2)
-  (js!selfcall
-    "var r = " string1 ".concat(" string2 ");" *newline*
-    "r.type = 'character';"
-    "return r;" *newline*))
+     "return typeof(x) == 'object' && 'length' in x && x.stringp == 1;")))
 
 (define-raw-builtin funcall (func &rest args)
   (js!selfcall
@@ -1303,51 +1274,42 @@
 (define-builtin write-string (x)
   (code "lisp.write(" x ")"))
 
-(define-builtin make-array (n)
-  (js!selfcall
-    "var r = [];" *newline*
-    "for (var i = 0; i < " n "; i++)" *newline*
-    (indent "r.push(" (ls-compile nil) ");" *newline*)
-    "return r;" *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)
-  (js!selfcall
-    "var v = " vector ";" *newline*
-    "v.push(" new ");" *newline*
-    "return v;"))
+;;; Storage vectors. They are used to implement arrays and (in the
+;;; future) structures.
 
-(define-builtin arrayp (x)
+(define-builtin storage-vector-p (x)
   (js!bool
    (js!selfcall
      "var x = " x ";" *newline*
      "return typeof x === 'object' && 'length' in x;")))
 
-(define-builtin aref (array n)
+(define-builtin make-storage-vector (n)
+  (js!selfcall
+    "var r = [];" *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 = " "(" array ")[" n "];" *newline*
+    "var x = " "(" vector ")[" n "];" *newline*
     "if (x === undefined) throw 'Out of range';" *newline*
     "return x;" *newline*))
 
-(define-builtin aset (array n value)
+(define-builtin storage-vector-set (vector n value)
   (js!selfcall
-    "var x = " array ";" *newline*
+    "var x = " vector ";" *newline*
     "var i = " n ";" *newline*
     "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
     "return x[i] = " value ";" *newline*))
 
-(define-builtin afind (value array)
-  (js!selfcall
-    "var v = " value ";" *newline*
-    "var x = " array ";" *newline*
-    "return x.indexOf(v);" *newline*))
 
-(define-builtin aresize (array new-size)
-  (js!selfcall
-    "var x = " array ";" *newline*
-    "var n = " new-size ";" *newline*
-    "return x.length = n;" *newline*))
 
 (define-builtin get-internal-real-time ()
   "(new Date()).getTime()")
diff --git a/src/prelude.js b/src/prelude.js
index 162058e..c40d0fa 100644
--- a/src/prelude.js
+++ b/src/prelude.js
@@ -59,7 +59,7 @@ function codepoints(string) {
 // Create and return a lisp string for the Javascript string STRING.
 function make_lisp_string (string){
     var array = codepoints(string);
-    array.type = 'character'
+    array.stringp = 1
     return array;
 }
 
@@ -112,7 +112,7 @@ function Symbol(name, package_name){
 }
 
 function lisp_to_js (x) {
-    if (typeof x == 'object' && 'length' in x && x.type == 'character')
+    if (typeof x == 'object' && 'length' in x && x.stringp == 1)
         return xstring(x);
     else if (typeof x == 'function'){
         // Trampoline calling the Lisp function
diff --git a/src/print.lisp b/src/print.lisp
index 7daa143..f9b5aff 100644
--- a/src/print.lisp
+++ b/src/print.lisp
@@ -100,6 +100,7 @@
 (defvar *print-escape* t)
 (defvar *print-circle* nil)
 
+;;; FIXME: Please, rewrite this in a more organized way.
 (defun write-to-string (form &optional known-objects object-ids)
   (when (and (not known-objects) *print-circle*)
     ;; To support *print-circle* some objects must be tracked for
@@ -113,22 +114,26 @@
     ;; the id is changed to negative. If an object has an id < 0 then
     ;; #<-n># is printed instead of the object.
     ;;
-    ;; The processing is O(n^2) with n = number of tracked objects,
-    ;; but it should be reasonably fast because is based on afind that
-    ;; is a primitive function that compiles to [].indexOf.
+    ;; The processing is O(n^2) with n = number of tracked
+    ;; objects. Hopefully it will become good enough when the new
+    ;; compiler is available.
     (setf known-objects (make-array 100))
     (setf object-ids (make-array 100))
     (let ((n 0)
           (sz 100)
           (count 0))
       (labels ((mark (x)
-                 (let ((i (afind x known-objects)))
+                 (let ((i (position x known-objects)))
                    (if (= i -1)
                        (progn
                          (when (= n sz)
                            (setf sz (* 2 sz))
-                           (aresize known-objects sz)
-                           (aresize object-ids sz))
+                           ;; KLUDGE: storage vectors are an internal
+                           ;; object which the printer should not know
+                           ;; about. Use standard vector with fill
+                           ;; pointers instead.
+                           (resize-storage-vector known-objects sz)
+                           (resize-storage-vector object-ids sz))
                          (aset known-objects (1- (incf n)) x)
                          t)
                        (unless (aref object-ids i)
@@ -142,7 +147,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,9 +155,9 @@
   (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))
+      (let* ((ix (position form known-objects))
              (id (aref object-ids ix)))
         (cond
           ((and id (> id 0))
@@ -213,7 +218,7 @@
                                      " . "
                                      (write-to-string (cdr last) known-objects object-ids))))
                        ")"))
-              ((arrayp form)
+              ((vectorp form)
                (let ((result "#(")
                      (sep ""))
                  (dotimes (i (length form))
@@ -265,7 +270,7 @@
                (t
                 (concatf res (format-special next (car arguments)))
                 (pop arguments))))
-            (setq res (concat res (char-to-string c))))
+            (setq res (concat res (string c))))
         (incf i)))
     (if destination
         (progn
diff --git a/src/read.lisp b/src/read.lisp
index 3c15f9d..1cbe13e 100644
--- a/src/read.lisp
+++ b/src/read.lisp
@@ -319,7 +319,7 @@
       ;; No package prefix
       ((= index size)
        (setq name string)
-       (setq package *package*)
+       (setq package (package-name *package*))
        (setq internalp t))
       (t
        ;; Package prefix
@@ -332,7 +332,7 @@
          (incf index))
        (setq name (subseq string index))))
     ;; Canonalize symbol name and package
-    (setq name (if (equal package "JS")
+    (setq name (if (string= package "JS")
                    (setq name (unescape-token name))
                    (setq name (string-upcase-noescaped name))))
     (setq package (find-package package))
diff --git a/src/sequence.lisp b/src/sequence.lisp
index 6ac3ebf..7e96df0 100644
--- a/src/sequence.lisp
+++ b/src/sequence.lisp
@@ -143,8 +143,12 @@
               (rplacd pointer ()) 
               drop-a))))
        (copy-list (nthcdr a seq))))
-    ((arrayp seq) 
-     (if b
-       (slice seq a b)
-       (slice seq a)))
+    ((vectorp seq)
+     (let* ((b (or b (length seq)))
+            (size (- b a))
+            (new (make-array size :element-type (array-element-type seq))))
+       (do ((i 0 (1+ i))
+            (j a (1+ j)))
+           ((= j b) new)
+         (aset new i (aref seq j)))))
     (t (not-seq-error seq))))
diff --git a/src/string.lisp b/src/string.lisp
index 8bead9b..7026cb3 100644
--- a/src/string.lisp
+++ b/src/string.lisp
@@ -13,10 +13,23 @@
 ;; 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 (s)
+  (stringp s))
+
+(defun string-length (string)
+  (storage-vector-size string))
+
+(defun make-string (n &key initial-element)
+  (make-array n :element-type 'character :initial-element initial-element))
+
+(defun char (string index)
+  (unless (stringp string) (error "~S is not a string" string))
+  (storage-vector-ref string index))
+
 (defun string (x)
   (cond ((stringp x) x)
         ((symbolp x) (symbol-name x))
-        (t (char-to-string x))))
+        (t (make-string 1 :initial-element x))))
 
 (defun string= (s1 s2)
   (let* ((s1 (string s1))
@@ -38,9 +51,6 @@
                (when (and (= i (1- len-1)) (> len-2 len-1))
                  (return-from string< (1+ i))))))))
 
-(defun stringp (s)
-  (stringp s))
-
 (define-setf-expander char (string index)
   (let ((g!string (gensym))
         (g!index (gensym))
@@ -50,3 +60,31 @@
             (list g!value)
             `(aset ,g!string ,g!index ,g!value)
             `(char ,g!string ,g!index))))
+
+
+(defun concat-two (string1 string2)
+  (let* ((len1 (length string1))
+         (len2 (length string2))
+         (string (make-array (+ len1 len2) :element-type 'character))
+         (i 0))
+    (dotimes (j len1)
+      (aset string i (char string1 j))
+      (incf i))
+    (dotimes (j len2)
+      (aset string i (char string2 j))
+      (incf i))
+    string))
+
+(defun concat (&rest strs)
+  (!reduce #'concat-two strs ""))
+
+
+(defun string-upcase (string)
+  (let ((new (make-string (length string))))
+    (dotimes (i (length string) new)
+      (aset new i (char-upcase (char string i))))))
+
+(defun string-downcase (string)
+  (let ((new (make-string (length string))))
+    (dotimes (i (length string) new)
+      (aset new i (char-downcase (char string i))))))
diff --git a/tests/array.lisp b/tests/array.lisp
new file mode 100644
index 0000000..493cf79
--- /dev/null
+++ b/tests/array.lisp
@@ -0,0 +1,4 @@
+
+(test (arrayp #(1 2 3 4)))
+(test (vectorp #(1 2 3 4)))
+(test (not (vectorp (make-array '(3 3)))))