Merge branch 'master' of https://github.com/davazp/jscl

diff --git a/jscl.lisp b/jscl.lisp
index 2beefa1..86a780e 100644 (file)
--- a/jscl.lisp
+++ b/jscl.lisp
@@ -65,7 +65,7 @@
 
 (defun bootstrap ()
   (setq *environment* (make-lexenv))
-  (setq *literal-symbols* nil)
+  (setq *literal-table* nil)
   (setq *variable-counter* 0
         *gensym-counter* 0
         *literal-counter* 0

diff --git a/src/boot.lisp b/src/boot.lisp
index 45a8809..8ff77d1 100644 (file)
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -82,6 +82,7 @@
 
 (defmacro defun (name args &rest body)
   `(progn
+     
      (fset ',name
            (named-lambda ,(symbol-name name) ,args
              ,@(if (and (stringp (car body)) (not (null (cdr body))))
@@ -679,6 +680,8 @@
                          `((,(ecase (car c)
                                     (integer 'integerp)
                                     (cons 'consp)
+                                    (symbol 'symbolp)
+                                    (array 'arrayp)
                                     (string 'stringp)
                                     (atom 'atom)
                                     (null 'null))

diff --git a/src/compiler.lisp b/src/compiler.lisp
index 27cc37b..a6c451b 100644 (file)
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -527,56 +527,56 @@
     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))
     ((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))

diff --git a/src/toplevel.lisp b/src/toplevel.lisp
index a0b0cdc..97ba95b 100644 (file)
--- a/src/toplevel.lisp
+++ b/src/toplevel.lisp
@@ -100,8 +100,8 @@
    (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*)))))

diff --git a/tests-report.lisp b/tests-report.lisp
index d4a5275..45c7f7c 100644 (file)
--- a/tests-report.lisp
+++ b/tests-report.lisp
@@ -4,12 +4,20 @@
 (write-line " seconds.")
 
 (cond
-  ((zerop *failed-tests*)
-   (write-string "All tests (")
-   (write-string (prin1-to-string *passed-tests*))
-   (write-line ") passed successfully"))
+  ((= *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 *failed-tests*))
+   (write-string (prin1-to-string *passed-tests*))
    (write-string "/")
-   (write-string (prin1-to-string (+ *passed-tests* *failed-tests*)))
-   (write-line " failed.")))
+   (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."))

diff --git a/tests.lisp b/tests.lisp
index d383dc0..8fcd862 100644 (file)
--- a/tests.lisp
+++ b/tests.lisp
@@ -1,15 +1,33 @@
+(defvar *total-tests* 0)
 (defvar *passed-tests* 0)
 (defvar *failed-tests* 0)
+
+(defvar *expected-failures* 0)
+(defvar *unexpected-passes* 0)
+
 (defvar *timestamp* nil)
 
 (defmacro test (condition)
-  `(cond
-     (,condition
-      (write-line ,(concat "Test `" (prin1-to-string condition) "' passed"))
-      (incf *passed-tests*))
-     (t
-      (write-line ,(concat "Test `" (prin1-to-string condition) "' failed."))
-      (incf *failed-tests*))))
+  `(progn
+     (cond
+       (,condition
+        (write-line ,(concat "Test `" (prin1-to-string condition) "' passed"))
+        (incf *passed-tests*))
+       (t
+        (write-line ,(concat "Test `" (prin1-to-string condition) "' failed."))
+        (incf *failed-tests*)))
+     (incf *total-tests*)))
+
+(defmacro expected-failure (condition)
+  `(progn
+     (cond
+       (,condition
+        (write-line ,(concat "Test `" (prin1-to-string condition) "' passed unexpectedly!"))
+        (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 "")

diff --git a/tests/read.lisp b/tests/read.lisp
index 6f10ca2..b8e851c 100644 (file)
--- a/tests/read.lisp
+++ b/tests/read.lisp
@@ -1,4 +1,5 @@
 ;; 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)))
-(test (equal (read-from-string "(a b c)") (values '(A B C) 7)))
+(expected-failure
+ (equal (read-from-string "(a b c)") (values '(A B C) 7)))