;;;; Copyright (c) 2020-2021 Alan Dipert <alan@dipert.org>
;;;; Part of the JACL project: https://tailrecursion.com/JACL/
;;;;
;;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;;; of this software and associated documentation files (the "Software"), to deal
;;;; in the Software without restriction, including without limitation the rights
;;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;;; copies of the Software, and to permit persons to whom the Software is
;;;; furnished to do so, subject to the following conditions:
;;;;
;;;; The above copyright notice and this permission notice shall be included in all
;;;; copies or substantial portions of the Software.
;;;;
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
(use-package '#:jacl)
(enable-js-syntax)
(fetch-load "test.lisp")
;; Tests
(in-module "Reader")
(deftest "Fixnums"
(assert= 123 (%js "123"))
(assert= +9912 (%js "9912"))
(assert= 0 (%js "0"))
(assert= -32 (%js "-32"))
(assert= 1. (%js "1")))
(deftest "Symbols"
(with-label "nil and t"
(assert= nil @|null|)
(assert= t @|true|))
(with-label "uninterned"
(let ((sym '#:snoob))
(assert= (\. sym |name|) @"SNOOB")
(assert= (\. sym |packageName|) nil)))
(with-label "single escaped"
(let ((sym 'somesym))
(assert= (\. sym |name|) @"SOMESYM")
(assert= (\. sym |packageName|) @"COMMON-LISP-USER"))
(let ((sym '\alan))
(assert= (\. sym |name|) @"aLAN")))
(with-label "multi escaped"
(let ((sym '|Alan|))
(assert= (\. sym |name|) @"Alan"))))
(deftest "Lists"
(with-label "dotted pair"
(let ((pair '(x . 1)))
(assert= (car pair) 'x)
(assert= (cdr pair) 1))))
(defvar *top-level-special-variable*)
(defun top-level-function-referencing-special-variable ()
*top-level-special-variable*)
(deftest "Dynamic Binding"
(with-label "top-level defvar"
(let ((*top-level-special-variable* 123))
(assert= (top-level-function-referencing-special-variable) 123)))
;; (with-label "inner defvar"
;; (defvar *inner-special-variable*)
;; (let ((doit (lambda () *inner-special-variable*)))
;; (let ((*inner-special-variable* 99))
;; (assert= (funcall doit) 99))))
)
(in-module "Lambda")
(deftest "Lambda Expressions"
(assert= ((lambda (x y) (+ x y)) 1 2) 3)
(assert-throws ((lambda (x y z)) 'only-argument)))
(deftest "Funcall"
(assert= (funcall (lambda (&key x) x) :x 123) 123)
(assert= (funcall (lambda (a b &key c) (+ a b c)) 1 2 :c 3) 6)
(assert= (funcall (lambda (x y &key a b c)
(dolist (x (list a b c) c)
x))
nil nil)
nil)
(assert= (let ((func (lambda () 123))) (funcall func)) 123))
(deftest "Apply"
(assert= (apply (lambda (x y) (+ x y)) '(1 2)) 3)
(assert= (apply #'(lambda (x y) (+ x y)) '(1 2)) 3))
;; (in-module "Macro Lambda List")
;; TODO
(in-module "Internal")
;; (deftest "Designators"
;; (with-label "string"
;; (dolist (obj '("a designator" |a designator|))
;; (assert= t (string= (cl::%designated-string obj)
;; "a designator")))))
(in-module "Numerics")
(deftest "Numeric functions"
(assert= (zerop 1) nil)
(assert= (zerop 0) t)
(assert= (1+ 2) 3)
(assert= (1- 10) 9)
(assert-throws (>))
(assert-throws (> "foo"))
(assert-throws (> "foo" "bar"))
(assert-throws (> "foo" "bar" "baz"))
(assert= (> 3 2 1) t)
(assert= (> 1) t)
(assert= (> 1 3) nil)
(assert-throws (<))
(assert-throws (< "foo"))
(assert-throws (< "foo" "bar"))
(assert-throws (< "foo" "bar" "baz"))
(assert= (< 1) t)
(assert= (< 5 10 421) t)
(assert= (< 41 2) nil)
(assert= (+) 0)
(assert= (+ 1) 1)
(assert= (+ 1 2 3) 6)
(assert-throws (+ "haha"))
(assert-throws (+ 1 2 'haha))
(assert= (- 1) -1)
(assert= (- 3 4) -1)
(assert= (- 100 10 3 1) 86)
(assert-throws (-))
(assert-throws (- 'foo))
(assert-throws (- 1 'bar)))
(in-module "Special Forms")
(deftest "Function accessors"
(assert= (function +) (function +) "FUNCTION")
(assert= (function +) (symbol-function '+) "SYMBOL-FUNCTION"))
(in-module "Assignment")
(deftest "PSETQ"
(let ((a 1)
(b 2)
(c 3))
(psetq a (1+ b) b (1+ a) c (+ a b))
(assert= a 3)
(assert= b 2)
(assert= c 3)))
(in-module "Iteration")
(deftest "DO*"
(do* ((i 0 (1+ i))
(k 5))
((eql i 5)
(assert= i 5)
(assert= k 0))
(setq k (1- k)))
(do* ((x 0 (1+ x))
(y x (1+ x)))
((eql x 5) (assert= y 6)))
(do* ((i 0 (1+ i))
(j 0 i))
((eql i 10)
(assert= i 10)
(assert= j 10))))
(deftest "DO"
(do ((i 0 (1+ i))
(j 0 i))
((eql i 10)
(assert= i 10)
(assert= j 9))))
(deftest "DOLIST"
(let ((x 0))
(assert=
(dolist (i '(1 2 3 4 5) x)
(setq x (+ x i)))
15))
(assert=
(dolist (i '(1 2 3))
(when (eql i 2)
(return i)))
2)
(assert= 6
(let ((i 0))
(dolist (x '(1 2 3) i)
(setq i (+ i x))))))
(deftest "DOTIMES"
(let ((x 0))
(dotimes (i 3 (assert= x 3))
(setq x (1+ x)))))
(start-tests)
;; ;; (in-module "Control operators")
;; ;; (deftest "JACL:%IF and CL:IF"
;; ;; (assert= (jacl:%if t 1) 1)
;; ;; (assert= (jacl:%if nil 1 123) 123)
;; ;; (assert= (jacl:%if nil 1) nil)
;; ;; (assert= (if t 1) 1)
;; ;; (assert= (if nil 1 123) 123)
;; ;; (assert= (if nil 1) nil))
;; ;; (deftest "Local TAGBODY"
;; ;; (let ((x 10)
;; ;; (y 0))
;; ;; (tagbody
;; ;; begin
;; ;; (when (> x 0)
;; ;; (setq x (1- x) y (1+ y))
;; ;; (go begin))
;; ;; end)
;; ;; (assert= x 0)
;; ;; (assert= y 10)))
;; ;; (deftest "GO in TAGBODY prelude"
;; ;; (let ((x 0))
;; ;; (tagbody
;; ;; (go end)
;; ;; start ;skipped
;; ;; (setq x (1+ x)) ;skipped
;; ;; end)
;; ;; (assert= x 0)))
;; ;; (defun countdown (from)
;; ;; (tagbody
;; ;; start
;; ;; (when (> from 0)
;; ;; (setq from (1- from))
;; ;; (go start))))
;; ;; (countdown 3)
;; ;; (in-module "Iteration operators")
;; ;; (deftest "CL:DOLIST"
;; ;; (let ((sum 0)
;; ;; (ones '(1 1 1)))
;; ;; (dolist (x ones)
;; ;; (setq sum (1+ sum)))
;; ;; (assert= sum 3 "without result-form")
;; ;; (setq sum 0)
;; ;; (assert= (dolist (x ones sum)
;; ;; (setq sum (1+ sum)))
;; ;; 3
;; ;; "with result-form")
;; ;; (setq sum 0)
;; ;; (dolist (x ones)
;; ;; start
;; ;; (when (< x 2)
;; ;; (setq x (1+ x))
;; ;; (go start))
;; ;; (setq sum (+ sum x)))
;; ;; (assert= sum 6 "with tags in body")))
;; ;; (\. @|QUnit| (|start|))
;; ;; (in-module "Functions")
;; ;; (deftest "Named JACL:%LAMBDA"
;; ;; (let* ((invocations 0)
;; ;; (f (jacl:%lambda self nil (x y)
;; ;; (let ((self nil))
;; ;; (when (< x y)
;; ;; (setq invocations (1+ invocations))
;; ;; (self (1+ x) y))))))
;; ;; (funcall f 0 10)
;; ;; (assert= invocations 10)))
;; ;; (defun tak (x y z)
;; ;; (if (not (< y x))
;; ;; z
;; ;; (tak
;; ;; (tak (1- x) y z)
;; ;; (tak (1- y) z x)
;; ;; (tak (1- z) x y))))
;; ;; (defun now ()
;; ;; (\. (%js "performance") (|now|)))
;; ;; ;; (defmacro with-profile (memo &rest body)
;; ;; ;; (let ((memo# (gensym)))
;; ;; ;; `(let ((,memo# (\. ,memo (|toString|))))
;; ;; ;; (\. (%js "console") (|profile| ,memo#))
;; ;; ;; (prog1 (progn ,@body)
;; ;; ;; )
;; ;; ;; )))
;; ;; (defmacro time (memo &body body)
;; ;; (let ((start# (gensym))
;; ;; (ret# (gensym)))
;; ;; `(let ((,start# (progn
;; ;; (\. (%js "console") (|profile| ,memo))
;; ;; (now)))
;; ;; (,ret# (progn ,@body)))
;; ;; (\. @|console| (|profileEnd| ,memo))
;; ;; (log ,memo (- (now) ,start#))
;; ;; ,ret#)))
;; ;; (deftest "Recursion"
;; ;; (assert= 7 (time @"tak" (tak 18 12 6))))
;; ;; Local Variables:
;; ;; eval: (put 'with-label 'lisp-indent-function 1)
;; ;; eval: (put 'with-read 'lisp-indent-function 1)
;; ;; End:
;; (defun snoob (&rest rest &aux (x "snoob"))
;; (log x))
;; (snoob)
;; Local Variables:
;; eval: (put 'with-label 'lisp-indent-function 1)
;; eval: (put 'with-read 'lisp-indent-function 1)
;; eval: (put 'deftest 'lisp-indent-function 'defun)
;; End: