'(("boot" :target)
("compat" :host)
("utils" :both)
+ ("numbers" :target)
("list" :target)
+ ("array" :target)
("string" :target)
("sequence" :target)
("print" :target)
("package" :target)
("ffi" :target)
("misc" :target)
- ("numbers" :target)
("read" :both)
("defstruct" :both)
("lambda-list" :both)
--- /dev/null
+;;; 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))
(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)))
"var x = " x ";" *newline*
"return (typeof(" x ") == \"string\") && x.length == 1;")))
-(define-builtin char-to-string (x)
- (js!selfcall
- "var r = [" x "];" *newline*
- "r.type = 'character';"
- "return r"))
-
(define-builtin char-upcase (x)
(code x ".toUpperCase()"))
(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
(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()")
// Create and return a lisp string for the Javascript string STRING.
function make_lisp_string (string){
var array = string.split("");
- array.type = 'character'
+ array.stringp = 1;
return array;
}
}
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
(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
;; 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)
(when (mark x)
(visit (car x))
(visit (cdr x))))
- ((arrayp x)
+ ((vectorp x)
(when (mark x)
(dotimes (i (length x))
(visit (aref x i))))))))
(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))
" . "
(write-to-string (cdr last) known-objects object-ids))))
")"))
- ((arrayp form)
+ ((vectorp form)
(let ((result "#(")
(sep ""))
(dotimes (i (length form))
(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
;; No package prefix
((= index size)
(setq name string)
- (setq package *package*)
+ (setq package (package-name *package*))
(setq internalp t))
(t
;; Package prefix
(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))
(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))))
;; 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))
(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))
(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))))))
--- /dev/null
+
+(test (arrayp #(1 2 3 4)))
+(test (vectorp #(1 2 3 4)))
+(test (not (vectorp (make-array '(3 3)))))
projects / jscl.git / commitdiff