*~
*.fasl
-ecmalisp.js
+jscl.js
+tests.js
+++ /dev/null
-David Vazquez <davazp at gmail.com>
-Raimon Grau <rgrau at gmail.com>
-Alfredo Beaumont <alfredo.beaumont at gmail.com>
--- /dev/null
+David Vazquez <davazp at gmail.com>
+Raimon Grau <rgrau at gmail.com>
+Alfredo Beaumont <alfredo.beaumont at gmail.com>
+Owen Rodley
+Andrea Griffini <agriff at tin.it>
+Nikodemus Siivola <nikodemus at random-state.net>
var startPrompt = function () {
// Start the prompt with history enabled.
- jqconsole.Write(lisp.evalString(pv, '(CL:PACKAGE-NAME CL:*PACKAGE*)') + '> ', 'jqconsole-prompt');
+ jqconsole.Write(lisp.evalString(pv, 1, '(CL:PACKAGE-NAME CL:*PACKAGE*)') + '> ', 'jqconsole-prompt');
jqconsole.Prompt(true, function (input) {
// Output input with the class jqconsole-return.
if (input[0] != ','){
try {
- var vs = lisp.evalInput(mv, input);
+ var vs = lisp.evalInput(mv, 1, input);
for (var i=0; i<vs.length; i++){
- jqconsole.Write(lisp.print(pv, vs[i]) + '\n', 'jqconsole-return');
+ jqconsole.Write(lisp.print(pv, 1, vs[i]) + '\n', 'jqconsole-return');
}
} catch(error) {
jqconsole.Write('ERROR: ' + (error.message || error) + '\n', 'jqconsole-error');
}
} else {
- jqconsole.Write(lisp.compileString(pv, input.slice(1)) + '\n', 'jqconsole-return');
+ jqconsole.Write(lisp.compileString(pv, 1, input.slice(1)) + '\n', 'jqconsole-return');
}
// Restart the prompt.
startPrompt();
}, function(input){
try {
- lisp.read(pv, input[0]==','? input.slice(1): input);
+ lisp.read(pv, 1, input[0]==','? input.slice(1): input);
} catch(error) {
return 0;
}
;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
-;; This program is free software: you can redistribute it and/or
+;; 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.
;;
-;; This program is distributed in the hope that it will be useful, but
+;; 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 this program. If not, see <http://www.gnu.org/licenses/>.
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
(defvar *source*
'(("boot" :target)
("compat" :host)
("utils" :both)
+ ("list" :target)
("print" :target)
+ ("package" :target)
("read" :both)
("compiler" :both)
- ("toplevel" :target)
- ;; Tests
- ("tests" :test)
- ("format" :test)
- ("setf" :test)
- ("eval" :test)
- ("tests-report" :test)))
+ ("toplevel" :target)))
(defun source-pathname
(filename &key (directory '(:relative "src")) (type nil) (defaults filename))
(with-compilation-unit ()
(dolist (input *source*)
(when (member (cadr input) '(:host :both))
- (compile-file (source-pathname (car input))))))
+ (let ((fname (source-pathname (car input))))
+ (multiple-value-bind (fasl warn fail) (compile-file fname)
+ (declare (ignore fasl warn))
+ (when fail
+ (error "Compilation of ~A failed." fname)))))))
;;; Load jscl into the host
(dolist (input *source*)
(load (source-pathname (car input)))))
(defun read-whole-file (filename)
- (with-open-file (in filename)
+ (with-open-file (in filename :external-format :latin-1)
(let ((seq (make-array (file-length in) :element-type 'character)))
(read-sequence seq in)
seq)))
(defun bootstrap ()
(setq *environment* (make-lexenv))
- (setq *literal-symbols* nil)
+ (setq *literal-table* nil)
(setq *variable-counter* 0
*gensym-counter* 0
- *literal-counter* 0
- *block-counter* 0)
+ *literal-counter* 0)
(with-open-file (out "jscl.js" :direction :output :if-exists :supersede)
(write-string (read-whole-file (source-pathname "prelude.js")) out)
(dolist (input *source*)
(ls-compile-file (source-pathname (car input) :type "lisp") out))))
;; Tests
(with-open-file (out "tests.js" :direction :output :if-exists :supersede)
- (dolist (input *source*)
- (when (member (cadr input) '(:test))
- (ls-compile-file (source-pathname (car input)
- :directory '(:relative "tests")
- :type "lisp")
- out)))))
+ (dolist (input (append (directory "tests.lisp")
+ (directory "tests/*.lisp")
+ (directory "tests-report.lisp")))
+ (ls-compile-file input out))))
+
+
+;;; Run the tests in the host Lisp implementation. It is a quick way
+;;; to improve the level of trust of the tests.
+(defun run-tests-in-host ()
+ (load "tests.lisp")
+ (let ((*use-html-output-p* nil))
+ (declare (special *use-html-output-p*))
+ (dolist (input (directory "tests/*.lisp"))
+ (load input)))
+ (load "tests-report.lisp"))
;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
-;; This program is free software: you can redistribute it and/or
+;; 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.
;;
-;; This program is distributed in the hope that it will be useful, but
+;; 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 this program. If not, see <http://www.gnu.org/licenses/>.
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
;;; This code is executed when JSCL compiles this file itself. The
;;; compiler provides compilation of some special forms, as well as
,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
',name))
-(defmacro named-lambda (name args &rest body)
- (let ((x (gensym "FN")))
- `(let ((,x (lambda ,args ,@body)))
- (oset ,x "fname" ,name)
- ,x)))
-
(defmacro defun (name args &rest body)
`(progn
- (fset ',name
- (named-lambda ,(symbol-name name) ,args
- ,@(if (and (stringp (car body)) (not (null (cdr body))))
- `(,(car body) (block ,name ,@(cdr body)))
- `((block ,name ,@body)))))
+ (fset ',name #'(named-lambda ,name ,args ,@body))
',name))
-(defun null (x)
- (eq x nil))
-
-(defun endp (x)
- (if (null x)
- t
- (if (consp x)
- nil
- (error "type-error"))))
-
(defmacro return (&optional value)
`(return-from nil ,value))
(defun 1+ (x) (+ x 1))
(defun 1- (x) (- x 1))
(defun zerop (x) (= x 0))
-(defun truncate (x y) (floor (/ x y)))
+
+(defun truncate (x &optional (y 1))
+ (floor (/ x y)))
(defun eql (x y) (eq x y))
(defun not (x) (if x nil t))
-(defun cons (x y ) (cons x y))
-(defun consp (x) (consp x))
-
-(defun car (x)
- "Return the CAR part of a cons, or NIL if X is null."
- (car x))
-
-(defun cdr (x) (cdr x))
-(defun caar (x) (car (car x)))
-(defun cadr (x) (car (cdr x)))
-(defun cdar (x) (cdr (car x)))
-(defun cddr (x) (cdr (cdr x)))
-(defun cadar (x) (car (cdr (car x))))
-(defun caddr (x) (car (cdr (cdr x))))
-(defun cdddr (x) (cdr (cdr (cdr x))))
-(defun cadddr (x) (car (cdr (cdr (cdr x)))))
-(defun first (x) (car x))
-(defun second (x) (cadr x))
-(defun third (x) (caddr x))
-(defun fourth (x) (cadddr x))
-(defun rest (x) (cdr x))
-
-(defun list (&rest args) args)
-(defun atom (x)
- (not (consp x)))
-
;; Basic macros
(defmacro incf (place &optional (delta 1))
(defmacro cond (&rest clausules)
(if (null clausules)
- nil
- (if (eq (caar clausules) t)
- `(progn ,@(cdar clausules))
- `(if ,(caar clausules)
- (progn ,@(cdar clausules))
- (cond ,@(cdr clausules))))))
+ nil
+ (if (eq (caar clausules) t)
+ `(progn ,@(cdar clausules))
+ (let ((test-symbol (gensym)))
+ `(let ((,test-symbol ,(caar clausules)))
+ (if ,test-symbol
+ ,(if (null (cdar clausules))
+ test-symbol
+ `(progn ,@(cdar clausules)))
+ (cond ,@(cdr clausules))))))))
(defmacro case (form &rest clausules)
(let ((!form (gensym)))
`(let ((,!form ,form))
(cond
,@(mapcar (lambda (clausule)
- (if (eq (car clausule) t)
- clausule
+ (if (or (eq (car clausule) t)
+ (eq (car clausule) 'otherwise))
+ `(t ,@(cdr clausule))
`((eql ,!form ',(car clausule))
,@(cdr clausule))))
clausules)))))
,@body)
(cdr ,head))))
-(defun map1 (func list)
- (with-collect
- (while list
- (collect (funcall func (car list)))
- (setq list (cdr list)))))
(defmacro loop (&body body)
`(while t ,@body))
-(defun mapcar (func list &rest lists)
- (let ((lists (cons list lists)))
- (with-collect
- (block loop
- (loop
- (let ((elems (map1 #'car lists)))
- (do ((tail lists (cdr tail)))
- ((null tail))
- (when (null (car tail)) (return-from loop))
- (rplaca tail (cdar tail)))
- (collect (apply func elems))))))))
-
(defun identity (x) x)
(defun constantly (x)
(lambda (&rest args)
x))
-(defun copy-list (x)
- (mapcar #'identity x))
+(defun code-char (x)
+ (code-char x))
-(defun list* (arg &rest others)
- (cond ((null others) arg)
- ((null (cdr others)) (cons arg (car others)))
- (t (do ((x others (cdr x)))
- ((null (cddr x)) (rplacd x (cadr x))))
- (cons arg others))))
+(defun char-code (x)
+ (char-code x))
-(defun code-char (x) x)
-(defun char-code (x) x)
-(defun char= (x y) (= x y))
+(defun char= (x y)
+ (eql x y))
(defun integerp (x)
(and (numberp x) (= (floor x) x)))
(defun plusp (x) (< 0 x))
(defun minusp (x) (< x 0))
-(defun listp (x)
- (or (consp x) (null x)))
-
-(defun nthcdr (n list)
- (while (and (plusp n) list)
- (setq n (1- n))
- (setq list (cdr list)))
- list)
-
-(defun nth (n list)
- (car (nthcdr n list)))
-
-(defun last (x)
- (while (consp (cdr x))
- (setq x (cdr x)))
- x)
-
-(defun butlast (x)
- (and (consp (cdr x))
- (cons (car x) (butlast (cdr x)))))
-
-(defun member (x list)
- (while list
- (when (eql x (car list))
- (return list))
- (setq list (cdr list))))
+(defun atom (x)
+ (not (consp x)))
(defun find (item list &key key (test #'eql))
(dolist (x list)
(remove-if-not func (cdr list)))))
(defun digit-char-p (x)
- (if (and (<= #\0 x) (<= x #\9))
- (- x #\0)
+ (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
+ (- (char-code x) (char-code #\0))
nil))
(defun digit-char (weight)
(incf pos))
pos))
-(defun assoc (x alist)
- (while alist
- (if (eql x (caar alist))
- (return)
- (setq alist (cdr alist))))
- (car alist))
-
(defun string (x)
(cond ((stringp x) x)
((symbolp x) (symbol-name x))
(t (char-to-string x))))
+(defun equal (x y)
+ (cond
+ ((eql x y) t)
+ ((consp x)
+ (and (consp y)
+ (equal (car x) (car y))
+ (equal (cdr x) (cdr y))))
+ ((arrayp x)
+ (and (arrayp y)
+ (let ((n (length x)))
+ (when (= (length y) n)
+ (dotimes (i n)
+ (unless (equal (aref x i) (aref y i))
+ (return-from equal nil)))
+ t))))
+ (t nil)))
+
(defun string= (s1 s2)
(equal s1 s2))
((null (cddr pairs))
(let ((place (ls-macroexpand-1 (first pairs)))
(value (second pairs)))
- (multiple-value-bind (vars vals store-vars writer-form reader-form)
+ (multiple-value-bind (vars vals store-vars writer-form)
(get-setf-expansion place)
;; TODO: Optimize the expansion a little bit to avoid let*
;; or multiple-value-bind when unnecesary.
((null pairs)
(reverse result)))))))
-(define-setf-expander car (x)
- (let ((cons (gensym))
- (new-value (gensym)))
- (values (list cons)
- (list x)
- (list new-value)
- `(progn (rplaca ,cons ,new-value) ,new-value)
- `(car ,cons))))
-
-(define-setf-expander cdr (x)
- (let ((cons (gensym))
- (new-value (gensym)))
- (values (list cons)
- (list x)
- (list new-value)
- `(progn (rplacd ,cons ,new-value) ,new-value)
- `(car ,cons))))
-
;; Incorrect typecase, but used in NCONC.
(defmacro typecase (x &rest clausules)
(let ((value (gensym)))
`((,(ecase (car c)
(integer 'integerp)
(cons 'consp)
+ (symbol 'symbolp)
+ (array 'arrayp)
(string 'stringp)
(atom 'atom)
(null 'null))
(list nil)))))
clausules)))))
-;; The NCONC function is based on the SBCL's one.
-(defun nconc (&rest lists)
- (flet ((fail (object)
- (error "type-error in nconc")))
- (do ((top lists (cdr top)))
- ((null top) nil)
- (let ((top-of-top (car top)))
- (typecase top-of-top
- (cons
- (let* ((result top-of-top)
- (splice result))
- (do ((elements (cdr top) (cdr elements)))
- ((endp elements))
- (let ((ele (car elements)))
- (typecase ele
- (cons (rplacd (last splice) ele)
- (setf splice ele))
- (null (rplacd (last splice) nil))
- (atom (if (cdr elements)
- (fail ele)
- (rplacd (last splice) ele))))))
- (return result)))
- (null)
- (atom
- (if (cdr top)
- (fail top-of-top)
- (return top-of-top))))))))
-
-(defun nreconc (x y)
- (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
- (2nd x 1st) ; 2nd follows first down the list.
- (3rd y 2nd)) ;3rd follows 2nd down the list.
- ((atom 2nd) 3rd)
- (rplacd 2nd 3rd)))
-
(defun notany (fn seq)
(not (some fn seq)))
-;; Packages
-
-(defvar *package-list* nil)
-
-(defun list-all-packages ()
- *package-list*)
-
-(defun make-package (name &key use)
- (let ((package (new))
- (use (mapcar #'find-package-or-fail use)))
- (oset package "packageName" name)
- (oset package "symbols" (new))
- (oset package "exports" (new))
- (oset package "use" use)
- (push package *package-list*)
- package))
-
-(defun packagep (x)
- (and (objectp x) (in "symbols" x)))
-
-(defun find-package (package-designator)
- (when (packagep package-designator)
- (return-from find-package package-designator))
- (let ((name (string package-designator)))
- (dolist (package *package-list*)
- (when (string= (package-name package) name)
- (return package)))))
-
-(defun find-package-or-fail (package-designator)
- (or (find-package package-designator)
- (error "Package unknown.")))
-
-(defun package-name (package-designator)
- (let ((package (find-package-or-fail package-designator)))
- (oget package "packageName")))
+(defconstant internal-time-units-per-second 1000)
-(defun %package-symbols (package-designator)
- (let ((package (find-package-or-fail package-designator)))
- (oget package "symbols")))
+(defun get-internal-real-time ()
+ (get-internal-real-time))
-(defun package-use-list (package-designator)
- (let ((package (find-package-or-fail package-designator)))
- (oget package "use")))
-
-(defun %package-external-symbols (package-designator)
- (let ((package (find-package-or-fail package-designator)))
- (oget package "exports")))
-
-(defvar *common-lisp-package*
- (make-package "CL"))
-
-(defvar *js-package*
- (make-package "JS"))
-
-(defvar *user-package*
- (make-package "CL-USER" :use (list *common-lisp-package*)))
-
-(defvar *keyword-package*
- (make-package "KEYWORD"))
-
-(defun keywordp (x)
- (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
-
-(defvar *package* *common-lisp-package*)
-
-(defmacro in-package (package-designator)
- `(eval-when-compile
- (setq *package* (find-package-or-fail ,package-designator))))
-
-;; This function is used internally to initialize the CL package
-;; with the symbols built during bootstrap.
-(defun %intern-symbol (symbol)
- (let* ((package
- (if (in "package" symbol)
- (find-package-or-fail (oget symbol "package"))
- *common-lisp-package*))
- (symbols (%package-symbols package)))
- (oset symbol "package" package)
- (when (eq package *keyword-package*)
- (oset symbol "value" symbol))
- (oset symbols (symbol-name symbol) symbol)))
-
-(defun find-symbol (name &optional (package *package*))
- (let* ((package (find-package-or-fail package))
- (externals (%package-external-symbols package))
- (symbols (%package-symbols package)))
- (cond
- ((in name externals)
- (values (oget externals name) :external))
- ((in name symbols)
- (values (oget symbols name) :internal))
- (t
- (dolist (used (package-use-list package) (values nil nil))
- (let ((exports (%package-external-symbols used)))
- (when (in name exports)
- (return (values (oget exports name) :inherit)))))))))
-
-(defun intern (name &optional (package *package*))
- (let ((package (find-package-or-fail package)))
- (multiple-value-bind (symbol foundp)
- (find-symbol name package)
- (if foundp
- (values symbol foundp)
- (let ((symbols (%package-symbols package)))
- (oget symbols name)
- (let ((symbol (make-symbol name)))
- (oset symbol "package" package)
- (when (eq package *keyword-package*)
- (oset symbol "value" symbol)
- (export (list symbol) package))
- (when (eq package *js-package*)
- (let ((sym-name (symbol-name symbol))
- (args (gensym)))
- ;; Generate a trampoline to call the JS function
- ;; properly. This trampoline is very inefficient,
- ;; but it still works. Ideas to optimize this are
- ;; provide a special lambda keyword
- ;; cl::&rest-vector to avoid list argument
- ;; consing, as well as allow inline declarations.
- (fset symbol
- (eval `(lambda (&rest ,args)
- (let ((,args (list-to-vector ,args)))
- (%js-call (%js-vref ,sym-name) ,args)))))
- ;; Define it as a symbol macro to access to the
- ;; Javascript variable literally.
- (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
- (oset symbols name symbol)
- (values symbol nil)))))))
-
-(defun symbol-package (symbol)
- (unless (symbolp symbol)
- (error "it is not a symbol"))
- (oget symbol "package"))
-
-(defun export (symbols &optional (package *package*))
- (let ((exports (%package-external-symbols package)))
- (dolist (symb symbols t)
- (oset exports (symbol-name symb) symb))))
+(defun get-unix-time ()
+ (truncate (/ (get-internal-real-time) 1000)))
(defun get-universal-time ()
(+ (get-unix-time) 2208988800))
;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
-;; This program is free software: you can redistribute it and/or
+;; 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.
;;
-;; This program is distributed in the hope that it will be useful, but
+;; 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 this program. If not, see <http://www.gnu.org/licenses/>.
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
;;; Duplicate from boot.lisp by now
(defmacro with-collect (&body body)
;; copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
-;; This program is free software: you can redistribute it and/or
+;; 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.
;;
-;; This program is distributed in the hope that it will be useful, but
+;; 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 this program. If not, see <http://www.gnu.org/licenses/>.
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
;;;; Compiler
(defvar *variable-counter* 0)
(defun gvarname (symbol)
+ (declare (ignore symbol))
(code "v" (incf *variable-counter*)))
(defun translate-variable (symbol)
(ll-optional-arguments-canonical lambda-list))))
(remove nil (mapcar #'third args))))
-(defun lambda-docstring-wrapper (docstring &rest strs)
- (if docstring
+(defun lambda-name/docstring-wrapper (name docstring &rest strs)
+ (if (or name docstring)
(js!selfcall
"var func = " (join strs) ";" *newline*
- "func.docstring = '" docstring "';" *newline*
+ (when name
+ (code "func.fname = '" (escape-string name) "';" *newline*))
+ (when docstring
+ (code "func.docstring = '" (escape-string docstring) "';" *newline*))
"return func;" *newline*)
(apply #'code strs)))
(n-required-arguments n-optional-arguments rest-p)
;; Note: Remember that we assume that the number of arguments of a
;; call is at least 1 (the values argument).
- (let ((min (1+ n-required-arguments))
- (max (if rest-p 'n/a (+ 1 n-required-arguments n-optional-arguments))))
+ (let ((min n-required-arguments)
+ (max (if rest-p 'n/a (+ n-required-arguments n-optional-arguments))))
(block nil
;; Special case: a positive exact number of arguments.
- (when (and (< 1 min) (eql min max))
- (return (code "checkArgs(arguments, " min ");" *newline*)))
+ (when (and (< 0 min) (eql min max))
+ (return (code "checkArgs(nargs, " min ");" *newline*)))
;; General case:
(code
- (when (< 1 min)
- (code "checkArgsAtLeast(arguments, " min ");" *newline*))
+ (when (< 0 min)
+ (code "checkArgsAtLeast(nargs, " min ");" *newline*))
(when (numberp max)
- (code "checkArgsAtMost(arguments, " max ");" *newline*))))))
+ (code "checkArgsAtMost(nargs, " max ");" *newline*))))))
(defun compile-lambda-optional (ll)
(let* ((optional-arguments (ll-optional-arguments-canonical ll))
(n-required-arguments (length (ll-required-arguments ll)))
(n-optional-arguments (length optional-arguments)))
(when optional-arguments
- (code (mapconcat (lambda (arg)
- (code "var " (translate-variable (first arg)) "; " *newline*
- (when (third arg)
- (code "var " (translate-variable (third arg))
- " = " (ls-compile t)
- "; " *newline*))))
- optional-arguments)
- "switch(arguments.length-1){" *newline*
+ (code "switch(nargs){" *newline*
(let ((cases nil)
(idx 0))
(progn
(when rest-argument
(let ((js!rest (translate-variable rest-argument)))
(code "var " js!rest "= " (ls-compile nil) ";" *newline*
- "for (var i = arguments.length-1; i>="
- (+ 1 n-required-arguments n-optional-arguments)
+ "for (var i = nargs-1; i>=" (+ n-required-arguments n-optional-arguments)
"; i--)" *newline*
- (indent js!rest " = {car: arguments[i], cdr: ") js!rest "};"
- *newline*)))))
+ (indent js!rest " = {car: arguments[i+2], cdr: " js!rest "};" *newline*))))))
(defun compile-lambda-parse-keywords (ll)
(let ((n-required-arguments
;; Parse keywords
(flet ((parse-keyword (keyarg)
;; ((keyword-name var) init-form)
- (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
- "; i<arguments.length; i+=2){" *newline*
+ (code "for (i=" (+ n-required-arguments n-optional-arguments)
+ "; i<nargs; i+=2){" *newline*
(indent
- "if (arguments[i] === " (ls-compile (caar keyarg)) "){" *newline*
+ "if (arguments[i+2] === " (ls-compile (caar keyarg)) "){" *newline*
(indent (translate-variable (cadr (car keyarg)))
- " = arguments[i+1];"
+ " = arguments[i+3];"
*newline*
(let ((svar (third keyarg)))
(when svar
"}" *newline*)
"}" *newline*
;; Default value
- "if (i == arguments.length){" *newline*
+ "if (i == nargs){" *newline*
(indent (translate-variable (cadr (car keyarg))) " = " (ls-compile (cadr keyarg)) ";" *newline*)
"}" *newline*)))
(when keyword-arguments
(mapconcat #'parse-keyword keyword-arguments))))
;; Check for unknown keywords
(when keyword-arguments
- (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
- "; i<arguments.length; i+=2){" *newline*
+ (code "for (i=" (+ n-required-arguments n-optional-arguments)
+ "; i<nargs; i+=2){" *newline*
(indent "if ("
(join (mapcar (lambda (x)
- (concat "arguments[i] !== " (ls-compile (caar x))))
+ (concat "arguments[i+2] !== " (ls-compile (caar x))))
keyword-arguments)
" && ")
")" *newline*
"throw 'Unknown keyword argument ' + arguments[i].name;" *newline*))
"}" *newline*)))))
-(defun compile-lambda (ll body)
- (let ((required-arguments (ll-required-arguments ll))
- (optional-arguments (ll-optional-arguments ll))
- (keyword-arguments (ll-keyword-arguments ll))
- (rest-argument (ll-rest-argument ll))
- documentation)
- ;; Get the documentation string for the lambda function
- (when (and (stringp (car body))
+(defun parse-lambda-list (ll)
+ (values (ll-required-arguments ll)
+ (ll-optional-arguments ll)
+ (ll-keyword-arguments ll)
+ (ll-rest-argument ll)))
+
+;;; Process BODY for declarations and/or docstrings. Return as
+;;; multiple values the BODY without docstrings or declarations, the
+;;; list of declaration forms and the docstring.
+(defun parse-body (body &key declarations docstring)
+ (let ((value-declarations)
+ (value-docstring))
+ ;; Parse declarations
+ (when declarations
+ (do* ((rest body (cdr rest))
+ (form (car rest) (car rest)))
+ ((or (atom form) (not (eq (car form) 'declare)))
+ (setf body rest))
+ (push form value-declarations)))
+ ;; Parse docstring
+ (when (and docstring
+ (stringp (car body))
(not (null (cdr body))))
- (setq documentation (car body))
+ (setq value-docstring (car body))
(setq body (cdr body)))
- (let ((n-required-arguments (length required-arguments))
- (n-optional-arguments (length optional-arguments))
- (*environment* (extend-local-env
- (append (ensure-list rest-argument)
- required-arguments
- optional-arguments
- keyword-arguments
- (ll-svars ll)))))
- (lambda-docstring-wrapper
- documentation
- "(function ("
- (join (cons "values"
- (mapcar #'translate-variable
- (append required-arguments optional-arguments)))
- ",")
- "){" *newline*
- (indent
- ;; Check number of arguments
- (lambda-check-argument-count n-required-arguments
- n-optional-arguments
- (or rest-argument keyword-arguments))
- (compile-lambda-optional ll)
- (compile-lambda-rest ll)
- (compile-lambda-parse-keywords ll)
- (let ((*multiple-value-p* t))
- (ls-compile-block body t)))
- "})"))))
+ (values body value-declarations value-docstring)))
+
+;;; Compile a lambda function with lambda list LL and body BODY. If
+;;; NAME is given, it should be a constant string and it will become
+;;; the name of the function. If BLOCK is non-NIL, a named block is
+;;; created around the body. NOTE: No block (even anonymous) is
+;;; created if BLOCk is NIL.
+(defun compile-lambda (ll body &key name block)
+ (multiple-value-bind (required-arguments
+ optional-arguments
+ keyword-arguments
+ rest-argument)
+ (parse-lambda-list ll)
+ (multiple-value-bind (body decls documentation)
+ (parse-body body :declarations t :docstring t)
+ (declare (ignore decls))
+ (let ((n-required-arguments (length required-arguments))
+ (n-optional-arguments (length optional-arguments))
+ (*environment* (extend-local-env
+ (append (ensure-list rest-argument)
+ required-arguments
+ optional-arguments
+ keyword-arguments
+ (ll-svars ll)))))
+ (lambda-name/docstring-wrapper name documentation
+ "(function ("
+ (join (list* "values"
+ "nargs"
+ (mapcar #'translate-variable
+ (append required-arguments optional-arguments)))
+ ",")
+ "){" *newline*
+ (indent
+ ;; Check number of arguments
+ (lambda-check-argument-count n-required-arguments
+ n-optional-arguments
+ (or rest-argument keyword-arguments))
+ (compile-lambda-optional ll)
+ (compile-lambda-rest ll)
+ (compile-lambda-parse-keywords ll)
+ (let ((*multiple-value-p* t))
+ (if block
+ (ls-compile-block `((block ,block ,@body)) t)
+ (ls-compile-block body t))))
+ "})")))))
(defun setq-pair (var val)
output))
-(defvar *literal-symbols* nil)
+(defvar *literal-table* nil)
(defvar *literal-counter* 0)
(defun genlit ()
(code "l" (incf *literal-counter*)))
+(defun dump-symbol (symbol)
+ #+common-lisp
+ (let ((package (symbol-package symbol)))
+ (if (eq package (find-package "KEYWORD"))
+ (code "{name: \"" (escape-string (symbol-name symbol))
+ "\", 'package': '" (package-name package) "'}")
+ (code "{name: \"" (escape-string (symbol-name symbol)) "\"}")))
+ #+jscl
+ (let ((package (symbol-package symbol)))
+ (if (null package)
+ (code "{name: \"" (escape-string (symbol-name symbol)) "\"}")
+ (ls-compile `(intern ,(symbol-name symbol) ,(package-name package))))))
+
+(defun dump-cons (cons)
+ (let ((head (butlast cons))
+ (tail (last cons)))
+ (code "QIList("
+ (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
+ (literal (car tail) t)
+ ","
+ (literal (cdr tail) t)
+ ")")))
+
+(defun dump-array (array)
+ (let ((elements (vector-to-list array)))
+ (concat "[" (join (mapcar #'literal elements) ", ") "]")))
+
(defun literal (sexp &optional recursive)
(cond
((integerp sexp) (integer-to-string sexp))
((floatp sexp) (float-to-string sexp))
+ ((characterp sexp) (code "\"" (escape-string (string sexp)) "\""))
((stringp sexp) (code "\"" (escape-string sexp) "\""))
- ((symbolp sexp)
- (or (cdr (assoc sexp *literal-symbols*))
- (let ((v (genlit))
- (s #+common-lisp
- (let ((package (symbol-package sexp)))
- (if (eq package (find-package "KEYWORD"))
- (code "{name: \"" (escape-string (symbol-name sexp))
- "\", 'package': '" (package-name package) "'}")
- (code "{name: \"" (escape-string (symbol-name sexp)) "\"}")))
- #+jscl
- (let ((package (symbol-package sexp)))
- (if (null package)
- (code "{name: \"" (escape-string (symbol-name sexp)) "\"}")
- (ls-compile `(intern ,(symbol-name sexp) ,(package-name package)))))))
- (push (cons sexp v) *literal-symbols*)
- (toplevel-compilation (code "var " v " = " s))
- v)))
- ((consp sexp)
- (let* ((head (butlast sexp))
- (tail (last sexp))
- (c (code "QIList("
- (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
- (literal (car tail) t)
- ","
- (literal (cdr tail) t)
- ")")))
- (if recursive
- c
- (let ((v (genlit)))
- (toplevel-compilation (code "var " v " = " c))
- v))))
- ((arrayp sexp)
- (let ((elements (vector-to-list sexp)))
- (let ((c (concat "[" (join (mapcar #'literal elements) ", ") "]")))
- (if recursive
- c
- (let ((v (genlit)))
- (toplevel-compilation (code "var " v " = " c))
- v)))))))
+ (t
+ (or (cdr (assoc sexp *literal-table*))
+ (let ((dumped (typecase sexp
+ (symbol (dump-symbol sexp))
+ (cons (dump-cons sexp))
+ (array (dump-array sexp)))))
+ (if (and recursive (not (symbolp sexp)))
+ dumped
+ (let ((jsvar (genlit)))
+ (push (cons sexp jsvar) *literal-table*)
+ (toplevel-compilation (code "var " jsvar " = " dumped))
+ jsvar)))))))
(define-compilation quote (sexp)
(literal sexp))
(cond
((and (listp x) (eq (car x) 'lambda))
(compile-lambda (cadr x) (cddr x)))
+ ((and (listp x) (eq (car x) 'named-lambda))
+ ;; TODO: destructuring-bind now! Do error checking manually is
+ ;; very annoying.
+ (let ((name (cadr x))
+ (ll (caddr x))
+ (body (cdddr x)))
+ (compile-lambda ll body
+ :name (symbol-name name)
+ :block name)))
((symbolp x)
(let ((b (lookup-in-lexenv x *environment* 'function)))
(if b
(define-compilation flet (definitions &rest body)
(let* ((fnames (mapcar #'car definitions))
- (fbody (mapcar #'cdr definitions))
- (cfuncs (mapcar #'compile-function-definition fbody))
+ (cfuncs (mapcar (lambda (def)
+ (compile-lambda (cadr def)
+ `((block ,(car def)
+ ,@(cddr def)))))
+ definitions))
(*environment*
(extend-lexenv (mapcar #'make-function-binding fnames)
*environment*
(js!selfcall
(mapconcat (lambda (func)
(code "var " (translate-function (car func))
- " = " (compile-lambda (cadr func) (cddr func))
+ " = " (compile-lambda (cadr func)
+ `((block ,(car func) ,@(cddr func))))
";" *newline*))
definitions)
(ls-compile-block body t))))
(let*-binding-wrapper specials body)))))
-(defvar *block-counter* 0)
-
(define-compilation block (name &rest body)
- (let* ((tr (incf *block-counter*))
- (b (make-binding :name name :type 'block :value tr)))
+ ;; We use Javascript exceptions to implement non local control
+ ;; transfer. Exceptions has dynamic scoping, so we use a uniquely
+ ;; generated object to identify the block. The instance of a empty
+ ;; array is used to distinguish between nested dynamic Javascript
+ ;; exceptions. See https://github.com/davazp/jscl/issues/64 for
+ ;; futher details.
+ (let* ((idvar (gvarname name))
+ (b (make-binding :name name :type 'block :value idvar)))
(when *multiple-value-p*
(push 'multiple-value (binding-declarations b)))
(let* ((*environment* (extend-lexenv (list b) *environment* 'block))
(if (member 'used (binding-declarations b))
(js!selfcall
"try {" *newline*
+ "var " idvar " = [];" *newline*
(indent cbody)
"}" *newline*
"catch (cf){" *newline*
- " if (cf.type == 'block' && cf.id == " tr ")" *newline*
+ " if (cf.type == 'block' && cf.id == " idvar ")" *newline*
(if *multiple-value-p*
" return values.apply(this, forcemv(cf.values));"
" return cf.values;")
(when (null b)
(error (concat "Unknown block `" (symbol-name name) "'.")))
(push 'used (binding-declarations b))
+ ;; The binding value is the name of a variable, whose value is the
+ ;; unique identifier of the block as exception. We can't use the
+ ;; variable name itself, because it could not to be unique, so we
+ ;; capture it in a closure.
(js!selfcall
(when multiple-value-p (code "var values = mv;" *newline*))
"throw ({"
"message: 'Throw uncatched.'"
"})"))
-
-(defvar *tagbody-counter* 0)
-(defvar *go-tag-counter* 0)
-
(defun go-tag-p (x)
(or (integerp x) (symbolp x)))
(defun declare-tagbody-tags (tbidx body)
- (let ((bindings
- (mapcar (lambda (label)
- (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
- (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
- (remove-if-not #'go-tag-p body))))
+ (let* ((go-tag-counter 0)
+ (bindings
+ (mapcar (lambda (label)
+ (let ((tagidx (integer-to-string (incf go-tag-counter))))
+ (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
+ (remove-if-not #'go-tag-p body))))
(extend-lexenv bindings *environment* 'gotag)))
(define-compilation tagbody (&rest body)
(unless (go-tag-p (car body))
(push (gensym "START") body))
;; Tagbody compilation
- (let ((tbidx *tagbody-counter*))
+ (let ((branch (gvarname 'branch))
+ (tbidx (gvarname 'tbidx)))
(let ((*environment* (declare-tagbody-tags tbidx body))
initag)
(let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
(setq initag (second (binding-value b))))
(js!selfcall
- "var tagbody_" tbidx " = " initag ";" *newline*
+ ;; TAGBODY branch to take
+ "var " branch " = " initag ";" *newline*
+ "var " tbidx " = [];" *newline*
"tbloop:" *newline*
"while (true) {" *newline*
(indent "try {" *newline*
(indent (let ((content ""))
- (code "switch(tagbody_" tbidx "){" *newline*
+ (code "switch(" branch "){" *newline*
"case " initag ":" *newline*
(dolist (form (cdr body) content)
(concatf content
"}" *newline*
"catch (jump) {" *newline*
" if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
- " tagbody_" tbidx " = jump.label;" *newline*
+ " " branch " = jump.label;" *newline*
" else" *newline*
" throw(jump);" *newline*
"}" *newline*)
(define-compilation multiple-value-call (func-form &rest forms)
(js!selfcall
"var func = " (ls-compile func-form) ";" *newline*
- "var args = [" (if *multiple-value-p* "values" "pv") "];" *newline*
+ "var args = [" (if *multiple-value-p* "values" "pv") ", 0];" *newline*
"return "
(js!selfcall
"var values = mv;" *newline*
"else" *newline*
(indent "args.push(vs);" *newline*)))
forms)
+ "args[1] = args.length-2;" *newline*
"return func.apply(window, args);" *newline*) ";" *newline*))
(define-compilation multiple-value-prog1 (first-form &rest forms)
(define-builtin lambda-code (x)
(code "(" x ").toString()"))
-(define-builtin eq (x y) (js!bool (code "(" x " === " y ")")))
-(define-builtin equal (x y) (js!bool (code "(" x " == " y ")")))
+(define-builtin eq (x y)
+ (js!bool (code "(" x " === " y ")")))
+
+(define-builtin char-code (x)
+ (type-check (("x" "string" x))
+ "x.charCodeAt(0)"))
+
+(define-builtin code-char (x)
+ (type-check (("x" "number" x))
+ "String.fromCharCode(x)"))
+
+(define-builtin characterp (x)
+ (js!bool
+ (js!selfcall
+ "var x = " x ";" *newline*
+ "return (typeof(" x ") == \"string\") && x.length == 1;")))
(define-builtin char-to-string (x)
(type-check (("x" "number" x))
(define-builtin char (string index)
(type-check (("string" "string" string)
("index" "number" index))
- "string.charCodeAt(index)"))
+ "string.charAt(index)"))
(define-builtin concat-two (string1 string2)
(type-check (("string1" "string" string1)
(js!selfcall
"var f = " (ls-compile func) ";" *newline*
"return (typeof f === 'function'? f: f.fvalue)("
- (join (cons (if *multiple-value-p* "values" "pv")
- (mapcar #'ls-compile args))
+ (join (list* (if *multiple-value-p* "values" "pv")
+ (integer-to-string (length args))
+ (mapcar #'ls-compile args))
", ")
")"))
(last (car (last args))))
(js!selfcall
"var f = " (ls-compile func) ";" *newline*
- "var args = [" (join (cons (if *multiple-value-p* "values" "pv")
- (mapcar #'ls-compile args))
+ "var args = [" (join (list* (if *multiple-value-p* "values" "pv")
+ (integer-to-string (length args))
+ (mapcar #'ls-compile args))
", ")
"];" *newline*
"var tail = (" (ls-compile last) ");" *newline*
"while (tail != " (ls-compile nil) "){" *newline*
" args.push(tail.car);" *newline*
+ " args[1] += 1;" *newline*
" tail = tail.cdr;" *newline*
"}" *newline*
"return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*))))
(type-check (("string" "string" string))
(if *multiple-value-p*
(js!selfcall
- "var v = eval.apply(window, [string]);" *newline*
- "if (typeof v !== 'object' || !('multiple-value' in v)){" *newline*
- (indent "v = [v];" *newline*
- "v['multiple-value'] = true;" *newline*)
- "}" *newline*
- "return values.apply(this, v);" *newline*)
- "eval.apply(window, [string])")))
+ "var v = globalEval(string);" *newline*
+ "return values.apply(this, forcemv(v));" *newline*)
+ "globalEval(string)")))
(define-builtin error (string)
(js!selfcall "throw " string ";" *newline*))
"if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
"return x[i] = " value ";" *newline*))
-(define-builtin get-unix-time ()
- (code "(Math.round(new Date() / 1000))"))
+(define-builtin get-internal-real-time ()
+ "(new Date()).getTime()")
(define-builtin values-array (array)
(if *multiple-value-p*
(defun compile-funcall (function args)
(let* ((values-funcs (if *multiple-value-p* "values" "pv"))
- (arglist (concat "(" (join (cons values-funcs (mapcar #'ls-compile args)) ", ") ")")))
+ (arglist (concat "(" (join (list* values-funcs
+ (integer-to-string (length args))
+ (mapcar #'ls-compile args)) ", ") ")")))
(unless (or (symbolp function)
(and (consp function)
(eq (car function) 'lambda)))
(ls-compile `(symbol-value ',sexp))))))
((integerp sexp) (integer-to-string sexp))
((floatp sexp) (float-to-string sexp))
+ ((characterp sexp) (code "\"" (escape-string (string sexp)) "\""))
((stringp sexp) (code "\"" (escape-string sexp) "\""))
((arrayp sexp) (literal sexp))
((listp sexp)
--- /dev/null
+;;; list.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/>.
+
+;;;; Various list functions
+
+(defun cons (x y ) (cons x y))
+(defun consp (x) (consp x))
+
+(defun listp (x)
+ (or (consp x) (null x)))
+
+(defun null (x)
+ (eq x nil))
+
+(defun endp (x)
+ (if (null x)
+ t
+ (if (consp x)
+ nil
+ (error "type-error"))))
+
+(defun car (x)
+ "Return the CAR part of a cons, or NIL if X is null."
+ (car x))
+
+(defun cdr (x) (cdr x))
+
+(defun first (x) (car x))
+(defun second (x) (cadr x))
+(defun third (x) (caddr x))
+(defun fourth (x) (cadddr x))
+(defun rest (x) (cdr x))
+
+(defun list (&rest args)
+ args)
+
+(defun list* (arg &rest others)
+ (cond ((null others) arg)
+ ((null (cdr others)) (cons arg (car others)))
+ (t (do ((x others (cdr x)))
+ ((null (cddr x)) (rplacd x (cadr x))))
+ (cons arg others))))
+
+(defun nthcdr (n list)
+ (while (and (plusp n) list)
+ (setq n (1- n))
+ (setq list (cdr list)))
+ list)
+
+(defun nth (n list)
+ (car (nthcdr n list)))
+
+;;; The rest of the C[AD]*R functions; only a few were defined in boot.lisp
+(defun caar (x) (car (car x)))
+(defun cadr (x) (car (cdr x)))
+(defun cdar (x) (cdr (car x)))
+(defun cddr (x) (cdr (cdr x)))
+(defun cadar (x) (car (cdr (car x))))
+(defun caddr (x) (car (cdr (cdr x))))
+(defun cdddr (x) (cdr (cdr (cdr x))))
+(defun cadddr (x) (car (cdr (cdr (cdr x)))))
+
+(defun cadar (x) (car (cdar x)))
+(defun caaar (x) (car (caar x)))
+(defun caadr (x) (car (cadr x)))
+(defun cdaar (x) (cdr (caar x)))
+(defun cdadr (x) (cdr (cadr x)))
+(defun cddar (x) (cdr (cdar x)))
+(defun caaaar (x) (car (caaar x)))
+(defun caaadr (x) (car (caadr x)))
+(defun caadar (x) (car (cadar x)))
+(defun caaddr (x) (car (caddr x)))
+(defun cadaar (x) (car (cdaar x)))
+(defun cadadr (x) (car (cdadr x)))
+(defun caddar (x) (car (cddar x)))
+(defun cdaaar (x) (cdr (caaar x)))
+(defun cdaadr (x) (cdr (caadr x)))
+(defun cdadar (x) (cdr (cadar x)))
+(defun cdaddr (x) (cdr (caddr x)))
+(defun cddaar (x) (cdr (cdaar x)))
+(defun cddadr (x) (cdr (cdadr x)))
+(defun cdddar (x) (cdr (cddar x)))
+(defun cddddr (x) (cdr (cdddr x)))
+
+
+(defun copy-list (x)
+ (mapcar #'identity x))
+
+(defun copy-tree (tree)
+ (if (consp tree)
+ (cons (copy-tree (car tree))
+ (copy-tree (cdr tree)))
+ tree))
+
+(defun subst (new old tree &key (key #'identity) (test #'eql))
+ (cond
+ ((funcall test (funcall key tree) (funcall key old))
+ new)
+ ((consp tree)
+ (cons (subst new old (car tree) :key key :test test)
+ (subst new old (cdr tree) :key key :test test)))
+ (t tree)))
+
+(defmacro pop (place)
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-expansion place)
+ (let ((head (gensym)))
+ `(let* (,@(mapcar #'list dummies vals)
+ (,head ,getter)
+ (,(car newval) (cdr ,head))
+ ,@(cdr newval))
+ ,setter
+ (car ,head)))))
+
+
+(defun map1 (func list)
+ (with-collect
+ (while list
+ (collect (funcall func (car list)))
+ (setq list (cdr list)))))
+
+(defun mapcar (func list &rest lists)
+ (let ((lists (cons list lists)))
+ (with-collect
+ (block loop
+ (loop
+ (let ((elems (map1 #'car lists)))
+ (do ((tail lists (cdr tail)))
+ ((null tail))
+ (when (null (car tail)) (return-from loop))
+ (rplaca tail (cdar tail)))
+ (collect (apply func elems))))))))
+
+(defun last (x)
+ (while (consp (cdr x))
+ (setq x (cdr x)))
+ x)
+
+(defun butlast (x)
+ (and (consp (cdr x))
+ (cons (car x) (butlast (cdr x)))))
+
+(defun member (x list)
+ (while list
+ (when (eql x (car list))
+ (return list))
+ (setq list (cdr list))))
+
+
+(defun assoc (x alist &key (test #'eql))
+ (while alist
+ (if (funcall test x (caar alist))
+ (return)
+ (setq alist (cdr alist))))
+ (car alist))
+
+
+
+(define-setf-expander car (x)
+ (let ((cons (gensym))
+ (new-value (gensym)))
+ (values (list cons)
+ (list x)
+ (list new-value)
+ `(progn (rplaca ,cons ,new-value) ,new-value)
+ `(car ,cons))))
+
+(define-setf-expander cdr (x)
+ (let ((cons (gensym))
+ (new-value (gensym)))
+ (values (list cons)
+ (list x)
+ (list new-value)
+ `(progn (rplacd ,cons ,new-value) ,new-value)
+ `(car ,cons))))
+
+
+;; The NCONC function is based on the SBCL's one.
+(defun nconc (&rest lists)
+ (flet ((fail (object)
+ (error "type-error in nconc")))
+ (do ((top lists (cdr top)))
+ ((null top) nil)
+ (let ((top-of-top (car top)))
+ (typecase top-of-top
+ (cons
+ (let* ((result top-of-top)
+ (splice result))
+ (do ((elements (cdr top) (cdr elements)))
+ ((endp elements))
+ (let ((ele (car elements)))
+ (typecase ele
+ (cons (rplacd (last splice) ele)
+ (setf splice ele))
+ (null (rplacd (last splice) nil))
+ (atom (if (cdr elements)
+ (fail ele)
+ (rplacd (last splice) ele))))))
+ (return result)))
+ (null)
+ (atom
+ (if (cdr top)
+ (fail top-of-top)
+ (return top-of-top))))))))
+
+
+(defun nreconc (x y)
+ (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
+ (2nd x 1st) ; 2nd follows first down the list.
+ (3rd y 2nd)) ;3rd follows 2nd down the list.
+ ((atom 2nd) 3rd)
+ (rplacd 2nd 3rd)))
--- /dev/null
+;;; package.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/>.
+
+(defvar *package-list* nil)
+
+(defun list-all-packages ()
+ *package-list*)
+
+(defun make-package (name &key use)
+ (let ((package (new))
+ (use (mapcar #'find-package-or-fail use)))
+ (oset package "packageName" name)
+ (oset package "symbols" (new))
+ (oset package "exports" (new))
+ (oset package "use" use)
+ (push package *package-list*)
+ package))
+
+(defun packagep (x)
+ (and (objectp x) (in "symbols" x)))
+
+(defun find-package (package-designator)
+ (when (packagep package-designator)
+ (return-from find-package package-designator))
+ (let ((name (string package-designator)))
+ (dolist (package *package-list*)
+ (when (string= (package-name package) name)
+ (return package)))))
+
+(defun find-package-or-fail (package-designator)
+ (or (find-package package-designator)
+ (error "Package unknown.")))
+
+(defun package-name (package-designator)
+ (let ((package (find-package-or-fail package-designator)))
+ (oget package "packageName")))
+
+(defun %package-symbols (package-designator)
+ (let ((package (find-package-or-fail package-designator)))
+ (oget package "symbols")))
+
+(defun package-use-list (package-designator)
+ (let ((package (find-package-or-fail package-designator)))
+ (oget package "use")))
+
+(defun %package-external-symbols (package-designator)
+ (let ((package (find-package-or-fail package-designator)))
+ (oget package "exports")))
+
+(defvar *common-lisp-package*
+ (make-package "CL"))
+
+(defvar *js-package*
+ (make-package "JS"))
+
+(defvar *user-package*
+ (make-package "CL-USER" :use (list *common-lisp-package*)))
+
+(defvar *keyword-package*
+ (make-package "KEYWORD"))
+
+(defun keywordp (x)
+ (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
+
+(defvar *package* *common-lisp-package*)
+
+(defmacro in-package (package-designator)
+ `(eval-when-compile
+ (setq *package* (find-package-or-fail ,package-designator))))
+
+;; This function is used internally to initialize the CL package
+;; with the symbols built during bootstrap.
+(defun %intern-symbol (symbol)
+ (let* ((package
+ (if (in "package" symbol)
+ (find-package-or-fail (oget symbol "package"))
+ *common-lisp-package*))
+ (symbols (%package-symbols package)))
+ (oset symbol "package" package)
+ (when (eq package *keyword-package*)
+ (oset symbol "value" symbol))
+ (oset symbols (symbol-name symbol) symbol)))
+
+(defun find-symbol (name &optional (package *package*))
+ (let* ((package (find-package-or-fail package))
+ (externals (%package-external-symbols package))
+ (symbols (%package-symbols package)))
+ (cond
+ ((in name externals)
+ (values (oget externals name) :external))
+ ((in name symbols)
+ (values (oget symbols name) :internal))
+ (t
+ (dolist (used (package-use-list package) (values nil nil))
+ (let ((exports (%package-external-symbols used)))
+ (when (in name exports)
+ (return (values (oget exports name) :inherit)))))))))
+
+(defun intern (name &optional (package *package*))
+ (let ((package (find-package-or-fail package)))
+ (multiple-value-bind (symbol foundp)
+ (find-symbol name package)
+ (if foundp
+ (values symbol foundp)
+ (let ((symbols (%package-symbols package)))
+ (oget symbols name)
+ (let ((symbol (make-symbol name)))
+ (oset symbol "package" package)
+ (when (eq package *keyword-package*)
+ (oset symbol "value" symbol)
+ (export (list symbol) package))
+ (when (eq package *js-package*)
+ (let ((sym-name (symbol-name symbol))
+ (args (gensym)))
+ ;; Generate a trampoline to call the JS function
+ ;; properly. This trampoline is very inefficient,
+ ;; but it still works. Ideas to optimize this are
+ ;; provide a special lambda keyword
+ ;; cl::&rest-vector to avoid list argument
+ ;; consing, as well as allow inline declarations.
+ (fset symbol
+ (eval `(lambda (&rest ,args)
+ (let ((,args (list-to-vector ,args)))
+ (%js-call (%js-vref ,sym-name) ,args)))))
+ ;; Define it as a symbol macro to access to the
+ ;; Javascript variable literally.
+ (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
+ (oset symbols name symbol)
+ (values symbol nil)))))))
+
+(defun symbol-package (symbol)
+ (unless (symbolp symbol)
+ (error "it is not a symbol"))
+ (oget symbol "package"))
+
+(defun export (symbols &optional (package *package*))
+ (let ((exports (%package-external-symbols package)))
+ (dolist (symb symbols t)
+ (oset exports (symbol-name symb) symb))))
var window = this;
var nil;
-function globalEval (x) {
- return eval.call (window, x);
-}
+globalEval = eval; // Just an indirect eval
function pv (x) { return x==undefined? nil: x; }
var values = mv;
function checkArgsAtLeast(args, n){
- if (args.length < n) throw 'too few arguments';
+ if (args < n) throw 'too few arguments';
}
function checkArgsAtMost(args, n){
- if (args.length > n) throw 'too many arguments';
+ if (args > n) throw 'too many arguments';
}
function checkArgs(args, n){
;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
-;; This program is free software: you can redistribute it and/or
+;; 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.
;;
-;; This program is distributed in the hope that it will be useful, but
+;; 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 this program. If not, see <http://www.gnu.org/licenses/>.
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
;;; Printer
(defun write-to-string (form)
(cond
- ((symbolp form)
- (multiple-value-bind (symbol foundp)
- (find-symbol (symbol-name form) *package*)
- (if (and foundp (eq symbol form))
- (symbol-name form)
- (let ((package (symbol-package form))
- (name (symbol-name form)))
- (concat (cond
- ((null package) "#")
- ((eq package (find-package "KEYWORD")) "")
- (t (package-name package)))
- ":" name)))))
- ((integerp form) (integer-to-string form))
- ((floatp form) (float-to-string form))
- ((stringp form) (if *print-escape*
- (concat "\"" (escape-string form) "\"")
- form))
- ((functionp form)
- (let ((name (oget form "fname")))
- (if name
- (concat "#<FUNCTION " name ">")
- (concat "#<FUNCTION>"))))
- ((listp form)
- (concat "("
- (join-trailing (mapcar #'write-to-string (butlast form)) " ")
- (let ((last (last form)))
- (if (null (cdr last))
- (write-to-string (car last))
- (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
- ")"))
- ((arrayp form)
- (concat "#" (if (zerop (length form))
- "()"
- (write-to-string (vector-to-list form)))))
- ((packagep form)
- (concat "#<PACKAGE " (package-name form) ">"))
- (t
- (concat "#<javascript object>"))))
+ ((symbolp form)
+ (multiple-value-bind (symbol foundp)
+ (find-symbol (symbol-name form) *package*)
+ (if (and foundp (eq symbol form))
+ (symbol-name form)
+ (let ((package (symbol-package form))
+ (name (symbol-name form)))
+ (concat (cond
+ ((null package) "#")
+ ((eq package (find-package "KEYWORD")) "")
+ (t (package-name package)))
+ ":" name)))))
+ ((integerp form) (integer-to-string form))
+ ((floatp form) (float-to-string form))
+ ((characterp form)
+ (concat "#\\"
+ (case form
+ (#\newline "newline")
+ (#\space "space")
+ (otherwise (string form)))))
+ ((stringp form) (concat "\"" (escape-string form) "\""))
+ ((functionp form)
+ (let ((name (oget form "fname")))
+ (if name
+ (concat "#<FUNCTION " name ">")
+ (concat "#<FUNCTION>"))))
+ ((listp form)
+ (concat "("
+ (join-trailing (mapcar #'write-to-string (butlast form)) " ")
+ (let ((last (last form)))
+ (if (null (cdr last))
+ (write-to-string (car last))
+ (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
+ ")"))
+ ((arrayp form)
+ (concat "#" (if (zerop (length form))
+ "()"
+ (write-to-string (vector-to-list form)))))
+ ((packagep form)
+ (concat "#<PACKAGE " (package-name form) ">"))
+ (t
+ (concat "#<javascript object>"))))
(defun prin1-to-string (form)
(let ((*print-escape* t))
;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
-;; This program is free software: you can redistribute it and/or
+;; 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.
;;
-;; This program is distributed in the hope that it will be useful, but
+;; 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 this program. If not, see <http://www.gnu.org/licenses/>.
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
;;;; Reader
(setq ch (%peek-char stream)))
string))
+(defun read-escaped-until (stream func)
+ (let ((string "")
+ (ch (%peek-char stream))
+ (multi-escape nil))
+ (while (and ch (or multi-escape (not (funcall func ch))))
+ (cond
+ ((char= ch #\|)
+ (if multi-escape
+ (setf multi-escape nil)
+ (setf multi-escape t)))
+ ((char= ch #\\)
+ (%read-char stream)
+ (setf ch (%peek-char stream))
+ (setf string (concat string "\\" (string ch))))
+ (t
+ (if multi-escape
+ (setf string (concat string "\\" (string ch)))
+ (setf string (concat string (string ch))))))
+ (%read-char stream)
+ (setf ch (%peek-char stream)))
+ string))
+
(defun skip-whitespaces-and-comments (stream)
(let (ch)
(skip-whitespaces stream)
((char= ch #\))
(%read-char stream)
nil)
- ((char= ch #\.)
- (%read-char stream)
- (prog1 (ls-read-1 stream)
- (skip-whitespaces-and-comments stream)
- (unless (char= (%read-char stream) #\))
- (error "')' was expected."))))
(t
- (cons (ls-read-1 stream) (%read-list stream))))))
+ (let ((car (ls-read-1 stream)))
+ (skip-whitespaces-and-comments stream)
+ (cons car
+ (if (char= (%peek-char stream) #\.)
+ (progn
+ (%read-char stream)
+ (if (terminalp (%peek-char stream))
+ (ls-read-1 stream) ; Dotted pair notation
+ (cons (let ((string (concat "." (read-escaped-until stream #'terminalp))))
+ (or (values (!parse-integer string nil))
+ (read-float string)
+ (read-symbol string)))
+ (%read-list stream))))
+ (%read-list stream))))))))
(defun read-string (stream)
(let ((string "")
(concat (string (%read-char stream))
(read-until stream #'terminalp))))
(cond
- ((string= cname "space") (char-code #\space))
- ((string= cname "tab") (char-code #\tab))
- ((string= cname "newline") (char-code #\newline))
- (t (char-code (char cname 0))))))
+ ((string= cname "space") #\space)
+ ((string= cname "tab") #\tab)
+ ((string= cname "newline") #\newline)
+ (t (char cname 0)))))
(#\+
(let ((feature (read-until stream #'terminalp)))
(cond
(t
(error "Unknown reader form.")))))))
+(defun unescape (x)
+ (let ((result ""))
+ (dotimes (i (length x))
+ (unless (char= (char x i) #\\)
+ (setq result (concat result (string (char x i))))))
+ result))
+
+(defun escape-all (x)
+ (let ((result ""))
+ (dotimes (i (length x))
+ (setq result (concat result "\\"))
+ (setq result (concat result (string (char x i)))))
+ result))
+
+(defun string-upcase-noescaped (s)
+ (let ((result "")
+ (last-escape nil))
+ (dotimes (i (length s))
+ (let ((ch (char s i)))
+ (if last-escape
+ (progn
+ (setf last-escape nil)
+ (setf result (concat result (string ch))))
+ (if (char= ch #\\)
+ (setf last-escape t)
+ (setf result (concat result (string-upcase (string ch))))))))
+ result))
+
;;; Parse a string of the form NAME, PACKAGE:NAME or
;;; PACKAGE::NAME and return the name. If the string is of the
;;; form 1) or 3), but the symbol does not exist, it will be created
(setq index 0)
(while (and (< index size)
(not (char= (char string index) #\:)))
+ (when (char= (char string index) #\\)
+ (incf index))
(incf index))
(cond
;; No package prefix
;; Package prefix
(if (zerop index)
(setq package "KEYWORD")
- (setq package (string-upcase (subseq string 0 index))))
+ (setq package (string-upcase-noescaped (subseq string 0 index))))
(incf index)
(when (char= (char string index) #\:)
(setq internalp t)
(incf index))
(setq name (subseq string index))))
;; Canonalize symbol name and package
- (when (not (eq package "JS"))
- (setq name (string-upcase name)))
+ (setq name (if (equal package "JS")
+ (setq name (unescape name))
+ (setq name (string-upcase-noescaped name))))
(setq package (find-package package))
- ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
- ;; external symbol from PACKAGE.
(if (or internalp
(eq package (find-package "KEYWORD"))
(eq package (find-package "JS")))
(intern name package)
- (find-symbol name package))))
+ (multiple-value-bind (symbol external)
+ (find-symbol name package)
+ (if (eq external :external)
+ symbol
+ (error (concat "The symbol '" name "' is not external")))))))
+
+(defun read-integer (string)
+ (let ((sign 1)
+ (number nil)
+ (size (length string)))
+ (dotimes (i size)
+ (let ((elt (char string i)))
+ (cond
+ ((digit-char-p elt)
+ (setq number (+ (* (or number 0) 10) (digit-char-p elt))))
+ ((zerop i)
+ (case elt
+ (#\+ nil)
+ (#\- (setq sign -1))
+ (t (return-from read-integer))))
+ ((and (= i (1- size)) (char= elt #\.)) nil)
+ (t (return-from read-integer)))))
+ (and number (* sign number))))
(defun read-float (string)
(block nil
(incf index)))
(unless (< index size) (return))
;; Optional integer part
- (let ((value (digit-char-p (char string index))))
- (when value
- (setq integer-part t)
- (while (and (< index size)
- (setq value (digit-char-p (char string index))))
- (setq number (+ (* number 10) value))
- (incf index))))
+ (awhen (digit-char-p (char string index))
+ (setq integer-part t)
+ (while (and (< index size)
+ (setq it (digit-char-p (char string index))))
+ (setq number (+ (* number 10) it))
+ (incf index)))
(unless (< index size) (return))
;; Decimal point is mandatory if there's no integer part
(unless (or integer-part (char= #\. (char string index))) (return))
(when (char= #\. (char string index))
(incf index)
(unless (< index size) (return))
- (let ((value (digit-char-p (char string index))))
- (when value
- (setq fractional-part t)
- (while (and (< index size)
- (setq value (digit-char-p (char string index))))
- (setq number (+ (* number 10) value))
- (setq divisor (* divisor 10))
- (incf index)))))
+ (awhen (digit-char-p (char string index))
+ (setq fractional-part t)
+ (while (and (< index size)
+ (setq it (digit-char-p (char string index))))
+ (setq number (+ (* number 10) it))
+ (setq divisor (* divisor 10))
+ (incf index))))
;; Either left or right part of the dot must be present
(unless (or integer-part fractional-part) (return))
;; Exponent is mandatory if there is no fractional part
(incf index))))
(unless (= index size) (return))
;; Everything went ok, we have a float
- (/ (* sign (expt 10 (* exponent-sign exponent)) number) divisor))))
-
+ ;; XXX: Use FLOAT when implemented.
+ (/ (* sign (expt 10.0 (* exponent-sign exponent)) number) divisor))))
(defun !parse-integer (string junk-allow)
(block nil
(defun parse-integer (string &key junk-allowed)
(multiple-value-bind (num index)
(!parse-integer string junk-allowed)
- (when num
- (values num index)
- (error "junk detected."))))
+ (if num
+ (values num index)
+ (error "junk detected."))))
(defvar *eof* (gensym))
(defun ls-read-1 (stream)
((char= ch #\#)
(read-sharp stream))
(t
- (let ((string (read-until stream #'terminalp)))
- (or (values (!parse-integer string nil))
+ (let ((string (read-escaped-until stream #'terminalp)))
+ (or (read-integer string)
(read-float string)
(read-symbol string)))))))
(defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
(ls-read (make-string-stream string) eof-error-p eof-value))
+
+#+jscl
+(defun read-from-string (string &optional (eof-errorp t) eof-value)
+ (ls-read-from-string string eof-errorp eof-value))
;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
-;; This program is free software: you can redistribute it and/or
+;; 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.
;;
-;; This program is distributed in the hope that it will be useful, but
+;; 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 this program. If not, see <http://www.gnu.org/licenses/>.
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
(defun eval (x)
*** **
** *
* (car results)))
+ (unless (boundp '*)
+ ;; FIXME: Handle error
+ (setf * nil))
(setf +++ ++
++ +
+ -)
(values-list /))
(export '(&body &key &optional &rest * ** *** *gensym-counter* *package* + ++
- +++ - / // /// 1+ 1- < <= = = > >= and append apply aref
- arrayp assoc atom block boundp butlast caar cadddr caddr
+ +++ - / // /// 1+ 1- < <= = = > >= and append apply aref arrayp
+ assoc atom block boundp butlast cadar caaar caadr cdaar cdadr
+ cddar caaaar caaadr caadar caaddr cadaar cadadr caddar cdaaar
+ cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr caar cadddr caddr
cadr car car case catch cdar cdddr cddr cdr cdr char
char-code char= code-char cond cons consp constantly
- copy-list decf declaim defconstant define-setf-expander
+ copy-list copy-tree decf declaim declare defconstant define-setf-expander
define-symbol-macro defmacro defparameter defun defvar
digit-char digit-char-p disassemble do do* documentation
dolist dotimes ecase eq eql equal error eval every export expt
fdefinition find-package find-symbol first flet format fourth fset
- funcall function functionp gensym get-setf-expansion
- get-universal-time go identity if in-package incf integerp
- intern keywordp labels lambda last length let let* list
+ funcall function functionp gensym get-internal-real-time
+ get-setf-expansion get-universal-time go identity if in-package
+ incf integerp intern keywordp labels lambda last length let let* list
list* list-all-packages listp loop make-array make-package
make-symbol mapcar member minusp mod multiple-value-bind
multiple-value-call multiple-value-list multiple-value-prog1
- nconc nil not nreconc nth nthcdr null numberp or
- package-name package-use-list packagep parse-integer plusp
+ nconc nil not nreconc nth nthcdr null numberp or otherwise
+ package-name package-use-list packagep parse-integer plusp pop
prin1-to-string print proclaim prog1 prog2 progn psetq push
- quote remove remove-if remove-if-not return return-from
- revappend reverse rplaca rplacd second set setf setq some
- string string-upcase string= stringp subseq symbol-function
- symbol-name symbol-package symbol-plist symbol-value symbolp
- t tagbody third throw truncate unless unwind-protect values
- values-list variable warn when write-line write-string zerop))
+ quote read-from-string remove remove-if remove-if-not return
+ return-from revappend reverse rplaca rplacd second set setf
+ setq some string string-upcase string= stringp subseq subst
+ symbol-function symbol-name symbol-package symbol-plist
+ symbol-value symbolp t tagbody third throw truncate unless
+ unwind-protect values values-list variable warn when write-line
+ write-string zerop))
(setq *package* *user-package*)
(ls-compile
`(progn
,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(cdr s))))
- *literal-symbols*)
- (setq *literal-symbols* ',*literal-symbols*)
+ *literal-table*)
+ (setq *literal-table* ',*literal-table*)
(setq *variable-counter* ,*variable-counter*)
- (setq *gensym-counter* ,*gensym-counter*)
- (setq *block-counter* ,*block-counter*)))))
+ (setq *gensym-counter* ,*gensym-counter*)))))
(eval-when-compile
(toplevel-compilation
;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
-;; This program is free software: you can redistribute it and/or
+;; 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.
;;
-;; This program is distributed in the hope that it will be useful, but
+;; 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 this program. If not, see <http://www.gnu.org/licenses/>.
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
(defvar *newline* (string (code-char 10)))
;;; Concatenate a list of strings, with a separator
(defun join (list &optional (separator ""))
- (cond
- ((null list)
- "")
- ((null (cdr list))
- (car list))
- (t
- (concat (car list)
- separator
- (join (cdr list) separator)))))
+ (!reduce (lambda (s o) (concat s separator o))
+ (cdr list)
+ :initial-value (car list)))
(defun join-trailing (list &optional (separator ""))
(if (null list)
--- /dev/null
+(write-line "")
+(write-string "Finished. The execution took ")
+(write-string (prin1-to-string (/ (- (get-internal-real-time) *timestamp*) internal-time-units-per-second 1.0)))
+(write-line " seconds.")
+
+(cond
+ ((= *passed-tests* *total-tests*)
+ (write-line "All the tests (")
+ (write-string (prin1-to-string *total-tests*))
+ (write-line ") passed successfully."))
+ (t
+ (write-string (prin1-to-string *passed-tests*))
+ (write-string "/")
+ (write-string (prin1-to-string *total-tests*))
+ (write-line " test(s) passed successfully.")))
+
+(unless (zerop *expected-failures*)
+ (write-string (prin1-to-string *expected-failures*))
+ (write-line " test(s) failed expectedly."))
+
+(unless (zerop *unexpected-passes*)
+ (write-string (prin1-to-string *unexpected-passes*))
+ (write-line " test(s) passed unexpectedly."))
--- /dev/null
+(defparameter *total-tests* 0)
+(defparameter *passed-tests* 0)
+(defparameter *failed-tests* 0)
+(defparameter *expected-failures* 0)
+(defparameter *unexpected-passes* 0)
+
+(defvar *use-html-output-p* t)
+(defun if-html (string) (if *use-html-output-p* string ""))
+
+(defvar *timestamp* nil)
+
+(defmacro test (condition)
+ `(progn
+ (cond
+ (,condition
+ (write-line ,(concat "Test `" (prin1-to-string condition) "' passed"))
+ (incf *passed-tests*))
+ (t
+ (write-line (concat (if-html "<font color=red>")
+ "Test `"
+ ,(prin1-to-string condition)
+ "' failed."
+ (if-html "</font>")))
+ (incf *failed-tests*)))
+ (incf *total-tests*)))
+
+(defmacro expected-failure (condition)
+ `(progn
+ (cond
+ (,condition
+ (write-line (concat (if-html "<font color=orange>")
+ "Test `"
+ ,(prin1-to-string condition)
+ "' passed unexpectedly!"
+ (if-html "</font>")))
+ (incf *unexpected-passes*))
+ (t
+ (write-line ,(concat "Test `" (prin1-to-string condition) "' failed expectedly."))
+ (incf *expected-failures*)))
+ (incf *total-tests*)))
+
+(write-line "Running tests...")
+(write-line "")
+
+(setq *timestamp* (get-internal-real-time))
--- /dev/null
+; Tests for conditional forms
+; Boolean operators
+(test (eql (and nil 1) nil))
+(test (= (and 1 2) 2))
+
+(test (= (or nil 1) 1))
+(test (= (or 1 2) 1))
+
+; COND
+(test (eql nil (cond)))
+(test (= 1 (cond (1))))
+(test (= 1
+ (let ((x 0))
+ (cond ((incf x))))))
+(test (= 2 (cond (1 2))))
+(test (= 3 (cond (nil 1) (2 3))))
+(test (eql nil (cond (nil 1) (nil 2))))
+
+; CASE
+
+(test (= (case 1 (2 3) (otherwise 42)) 42))
+(test (= (case 1 (2 3) (t 42)) 42))
+(test (= (case 1 (2 3) (1 42)) 42))
+(test (null (case 1 (2 3))))
--- /dev/null
+
+;;; Returning from a "dynamically" nested non local exists
+
+(defun foo (x)
+ (when x (funcall x))
+ (foo (lambda () (return-from foo 1)))
+ (return-from foo 2))
+
+(test (= (foo nil) 1))
+
+(defun foo-2 (x)
+ (let (value)
+ (tagbody
+ (when x (funcall x))
+ (foo-2 (lambda () (go exit-2)))
+ (go end)
+ exit-2
+ (setq value t)
+ end)
+ value))
+
+(test (foo-2 nil))
+
+
+(test (equal (flet ((foo () (return-from foo 42)))
+ (foo))
+ 42))
+
+(test (equal (let ((out (list)))
+ (labels ((zfoo (n rf i)
+ (if (> n 0)
+ (progn
+ (push (lambda () (return-from zfoo n)) rf)
+ (push n out)
+ (zfoo (1- n) rf i)
+ (push (- n) out))
+ (progn
+ (push 999 out)
+ (funcall (nth i (reverse rf)))
+ (push -999 out)))))
+ (let ((rf (list)))
+ (zfoo 5 rf 3)
+ out)))
+ '(-5 -4 -3 999 1 2 3 4 5)))
--- /dev/null
+(test (equal '(1 2) '(1 2)))
+(test (equal 1 1))
+(test (equal "abc" "abc"))
+(test (not (equal "abc" "def")))
+(test (not (equal "Abc" "abc")))
--- /dev/null
+; Tests for macros implementing iteration constructs
+; DOTIMES
+(test (let ((total 0))
+ (dotimes (n 6)
+ (incf total n))
+ (= total 15)))
+
+; DOLIST
+(test (let ((total 0))
+ (dolist (n '(1 2 3 4 5))
+ (incf total n))
+ (= total 15)))
+
+; DO
+(test (do ((a 0 b)
+ (b 1 (+ a b))
+ (n 0 (1+ n)))
+ ((= n 10)
+ (= a 55))))
+
+; DO*
+(test (do* ((a 0 b)
+ (b 1 (+ a b))
+ (n 0 (1+ n)))
+ ((= n 10)
+ (= a 512))))
--- /dev/null
+;; Tests for list functions
+
+;; TODO: EQUAL doesn't compare lists correctly at the moment.
+;; Once it does the lists can be compared directly in many of these tests
+
+; COPY-TREE
+(test (let* ((foo (list '(1 2) '(3 4)))
+ (bar (copy-tree foo)))
+ ;; (SETF (CAR (CAR FOO)) 0) doesn't work in the test for some reason,
+ ;; despite working fine in the REPL
+ (rplaca (car foo) 0)
+ (not (= (car (car foo))
+ (car (car bar))))))
+
+; SUBST
+; Can't really test this until EQUAL works properly on lists
+
+; POP
+(test (let* ((foo '(1 2 3))
+ (bar (pop foo)))
+ (and (= bar 1)
+ (= (car foo) 2))))
--- /dev/null
+;; TODO: Uncomment when either read-from-string supports all these parameters
+;; or when test macro supports error handling, whichever comes first
+;; (test (equal (read-from-string " 1 3 5" t nil :start 2) (values 3 5)))
+(expected-failure
+ (equal (multiple-value-list (read-from-string "(a b c)"))
+ '((A B C) 7)))
+
+(test (equal (symbol-name (read-from-string "js:alert")) "alert"))
+(test (equal (symbol-name (read-from-string "cl:cond")) "COND"))
+(test (equal (symbol-name (read-from-string "co|N|d")) "COND"))
+(test (equal (symbol-name (read-from-string "abc\\def")) "ABCdEF"))
+(test (equal (symbol-name (read-from-string "|.|")) "."))
+(test (equal (read-from-string "(1 .25)") '(1 0.25)))
+(test (equal (read-from-string ".25") 0.25))
+(test (equal (read-from-string "(1 . 25)") '(1 . 25)))
+++ /dev/null
-(write-line "")
-(write-string "Finished. The execution took ")
-(write-string (prin1-to-string (- (get-universal-time) *timestamp*)))
-(write-line " seconds.")
-
-(cond
- ((zerop *failed-tets*)
- (write-string "All tests (")
- (write-string (prin1-to-string *passed-tets*))
- (write-line ") passed successfully"))
- (t
- (write-string (prin1-to-string *failed-tets*))
- (write-string "/")
- (write-string (prin1-to-string (+ *passed-tets* *failed-tets*)))
- (write-line " failed.")))
+++ /dev/null
-(defvar *passed-tets* 0)
-(defvar *failed-tets* 0)
-(defvar *timestamp* (get-universal-time))
-
-(defmacro test (condition)
- `(cond
- (,condition
- (write-line ,(concat "Test `" (prin1-to-string condition) "' passed"))
- (incf *passed-tets*))
- (t
- (write-line ,(concat "Test `" (prin1-to-string condition) "' failed."))
- (incf *failed-tets*))))
-
-(write-line "Running tests...")
-(write-line "")
projects / jscl.git / commitdiff