Merge branch 'fill-pointers'

jscl.lisp

@@ -18,7 +18,7 @@
 
 (defpackage :jscl
   (:use :cl)
-  (:export #:bootstrap #:run-tests-in-host))
+  (:export #:bootstrap #:compile-application #:run-tests-in-host))
 
 (in-package :jscl)
 
@@ -63,6 +63,7 @@
     ("utils"         :both)
     ("defstruct"     :both)
     ("lambda-list"   :both)
+    ("ffi"           :target)
     ("numbers"       :target)
     ("char"          :target)
     ("list"          :target)
@@ -74,7 +75,6 @@
     ("print"         :target)
     ("format"        :target)
     ("misc"          :target)
-    ("ffi"           :target)
     ("symbol"        :target)
     ("package"       :target)
     ("ansiloop"

src/array.lisp

@@ -32,15 +32,20 @@
           (setf element-type 'character
                 initial-element (or initial-element #\space)))
         (setf element-type t))
+
+    (when (and (listp dimensions)
+               (not (null (cdr dimensions)))
+               fill-pointer)
+      (error "FILL-POINTER cannot be specified on multidimensional arrays."))
+
     ;; Initialize array
-    (dotimes (i size)
-      (storage-vector-set array i initial-element))
+    (storage-vector-fill array initial-element)
     ;; Record and return the object
-    (oset element-type array "type")
-    (oset dimensions array "dimensions")
+    (setf (oget array "type") element-type)
+    (setf (oget array "dimensions") dimensions)
+    (setf (oget array "fillpointer") fill-pointer)
     array))
 
-
 (defun arrayp (x)
   (storage-vector-p x))
 
@@ -86,6 +91,26 @@
             `(aref ,g!array ,g!index))))
 
 
+(defun array-has-fill-pointer-p (array)
+  (and (oget array "fillpointer") t))
+
+(defun fill-pointer (array)
+  (unless (arrayp array)
+    (error "~S is not an array" array))
+  (unless (array-has-fill-pointer-p array)
+    (error "~S does not have a fill pointer" array))
+  (oget array "fillpointer"))
+
+(defun set-fill-pointer (array new-value)
+  (unless (arrayp array)
+    (error "~S is not an array" array))
+  (unless (array-has-fill-pointer-p array)
+    (error "~S does not have a fill pointer" array))
+  (setf (oget array "fillpointer") new-value))
+
+(defsetf fill-pointer set-fill-pointer)
+
+
 ;;; Vectors
 
 (defun vectorp (x)
@@ -94,12 +119,10 @@
 (defun vector (&rest objects)
   (list-to-vector objects))
 
-;;; FIXME: should take optional min-extension.
-;;; FIXME: should use fill-pointer instead of the absolute end of array
-(defun vector-push-extend (new vector)
+(defun vector-push-extend (new-element 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))
+    (error "~S is not a vector." vector))
+  ;; Note that JS will automatically grow the array as new elements
+  ;; are assigned, so no need to do `adjust-array` here.
+  (storage-vector-set! vector (fill-pointer vector) new-element)
+  (incf (fill-pointer vector)))

src/compiler/compiler.lisp

@@ -1314,6 +1314,12 @@
         (throw "Out of range."))
     (return (= (property x i) ,value))))
 
+(define-builtin storage-vector-set! (vector n value)
+  `(= (property ,vector ,n) ,value))
+
+(define-builtin storage-vector-fill (vector value)
+  `(method-call ,vector "fill" ,value))
+
 (define-builtin concatenate-storage-vector (sv1 sv2)
   `(selfcall
      (var (sv1 ,sv1))

src/prelude.js

@@ -205,7 +205,9 @@ internals.safe_char_downcase = function(x) {
 };
 
 internals.xstring = function(x){
-  return x.join('');
+  const hasFillPointer = typeof x.fillpointer === 'number'
+  const activechars = hasFillPointer? x.slice(0, x.fillpointer): x
+  return activechars.join('');
 };
 
 

src/sequence.lisp

@@ -23,10 +23,10 @@
 
 (defun length (seq)
   (cond
-    ((stringp seq)
-     (string-length seq))
     ((arrayp seq)
-     (oget seq "length"))
+     (if (array-has-fill-pointer-p seq)
+         (fill-pointer seq)
+         (oget seq "length")))
     ((listp seq)
      (list-length seq))
     (t
@@ -216,7 +216,7 @@
              ;; Copy the beginning of the vector only when we find an element
              ;; that does not match.
              (unless vector
-               (setq vector (make-array 0))
+               (setq vector (make-array 0 :fill-pointer 0))
                (dotimes (i index)
                  (vector-push-extend (aref seq i) vector)))
              (when vector
@@ -256,7 +256,7 @@
         (cons (car list) (list-remove-if func (cdr list) negate))))))
 
 (defun vector-remove-if (func vector negate)
-  (let ((out-vector (make-array 0)))
+  (let ((out-vector (make-array 0 :fill-pointer 0)))
     (do-sequence (element vector i)
       (let ((test (funcall func element)))
         (when (if negate test (not test))

src/stream.lisp

@@ -71,7 +71,7 @@
   (funcall (stream-write-fn stream) string))
 
 (defun make-string-output-stream ()
-  (let ((buffer (make-string 0)))
+  (let ((buffer (make-array 0 :element-type 'character :fill-pointer 0)))
     (make-stream
      :write-fn (lambda (string)
        (dotimes (i (length string))

src/symbol.lisp

@@ -38,3 +38,8 @@
 
 (defun get (symbol indicator &optional default)
   (getf (symbol-plist symbol) indicator default))
+
+(defun symbol-function (symbol)
+  (symbol-function symbol))
+
+(defsetf symbol-function fset)

tests/array.lisp

@@ -2,3 +2,12 @@
 (test (arrayp #(1 2 3 4)))
 (test (vectorp #(1 2 3 4)))
 (test (not (vectorp (make-array '(3 3)))))
+
+(let ((array #(1 2 3 4)))
+  (setf (aref array 0) t)
+  (test (eq (aref array 0) t)))
+
+(let ((vector (make-array 20 :initial-element 3 :fill-pointer 0)))
+  (test (= (length vector) 0))
+  (setf (fill-pointer vector) 20)
+  (test (= (length vector) 20)))