(defun bootstrap ()
(setq *environment* (make-lexenv))
- (setq *literal-symbols* nil)
+ (setq *literal-table* nil)
(setq *variable-counter* 0
*gensym-counter* 0
*literal-counter* 0
(defmacro defun (name args &rest body)
`(progn
+
(fset ',name
(named-lambda ,(symbol-name name) ,args
,@(if (and (stringp (car body)) (not (null (cdr body))))
`((,(ecase (car c)
(integer 'integerp)
(cons 'consp)
+ (symbol 'symbolp)
+ (array 'arrayp)
(string 'stringp)
(atom 'atom)
(null 'null))
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))
(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*)))))
(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."))
+(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 "")
;; 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)))