;;; Automatic CLISP tests.
;;; This file tests the CLISP facility through direct calls to DWIMIFY. It does not
;;; attempt to simulate typein. It's probably not very useful to run this compiled.
(do-test-group ("Programmatic CLISP tests."
:before (progn
(dolist (x '(il:a il:b il:c il:d il:x il:y il:foo il:record-1))
(fmakunbound x))
(il:record il:b (il:b1 il:b2) il:b1_10 il:b2_20)
(il:record il:rec (il:a il:b il:c)
il:a_100 il:c_200 (il:subrecord il:b))
(warn "Defining and compiling function ~S." 'eval-with-clisp)
(compile-definer
(defun eval-with-clisp (expr-string)
(eval (il:dwimify
(with-profile "OLD-INTERLISP-T"
(read-from-string expr-string))
t)))
:functions)
(warn "~&Defining and compiling macro ~S." 'special-let)
(compile-definer
(defmacro special-let (bindings &body body)
(let ((vars ()) (vals ()))
(conditions::with-collection-sites (vars vals)
(dolist (binding bindings)
(etypecase binding
((and symbol (not null))
(conditions::collect-into vars binding)
(conditions::collect-into vals nil))
(cons
(conditions::collect-into vars (first binding))
(conditions::collect-into vals
(second binding))))
) ; dolist
) ; with-collection-sites
`(progv ',vars (list ,@vals)
(locally (declare (special ,@vars))
,@body))))
:functions)
))
;; Arithmetic operators.
(do-test "Infix +"
(eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A + B)")) 40))
(do-test "Infix -"
(eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A - B)")) 20))
(do-test "Infix *"
(eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A * B)")) 300))
(do-test "Infix /"
(eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A / B)")) 3))
(do-test "Infix ^"
(eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A ^ B)"))
590490000000000))
(do-test "Infix ="
(special-let ((il:a 30) (il:b 10))
(and (eq (eval-with-clisp "(A = A)") t)
(eq (eval-with-clisp "(A = B)") nil))
)
)
(do-test "Infix GT"
(eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A GT B)")) t))
(do-test "Infix LT"
(eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A LT B)")) nil))
(do-test "Infix GE"
(eql (special-let ((il:a 30) (il:b 10) (il:c 30))
(eval-with-clisp "(AND (A GE B) (A GE C))"))
t))
(do-test "Infix LE"
(eql (special-let ((il:a 30) (il:b 10) (il:c 10))
(eval-with-clisp "(AND (B LE A) (B LE C))"))
t))
;; List extractors
(do-test "Infix : applied to list"
(special-let ((il:foo '(a b c d e (f g) (h j k))))
(and (eq (eval-with-clisp "(FOO:2)") 'b)
(eq (eval-with-clisp "(FOO:-1:-1)") 'k))
)
)
(do-test "Infix :: applied to list"
(special-let ((il:foo '(a b c d e (f g) (h j k))))
(eq (eval-with-clisp "(FOO::3)")
(cdddr il:foo))
)
)
;; Record extractors
(do-test "Infix : with . applied to record"
(eql (special-let ((il:record-1 (il:create il:rec)))
(eval-with-clisp "(RECORD-1:REC.B.B1)"))
10))
;; List construction
(do-test "Simple list construction"
(special-let ((il:a 1) (il:b 2) (il:c 3) (il:d 4))
(and (equal (eval-with-clisp "()") '(1 2 3 4))
(equal (eval-with-clisp "(>)") '(1 2 (3))))
))
(do-test "List construction with !"
(special-let ((il:a 1) (il:b 2) (il:c 3) (il:x '(5 4)) (il:y '(3 2)))
(and (equal (eval-with-clisp "()") '(1 2 . 3))
(equal (eval-with-clisp "()") '(5 4 3 2 1)))
))
(do-test "List construction with !!"
(and
(special-let ((il:a (list 1 2 3)) (il:b (list 4 5 6)))
(let ((result (eval-with-clisp "()")))
(and (equal result '(1 2 3 (4 5 6)))
(eq result il:a)
(tailp result il:a)
(eq (nth 3 result) il:b))
))
(special-let ((il:a (list 1 2)) (il:b (list 3 4)) (il:c (list 5 6)))
(let ((result (eval-with-clisp "()")))
(and (equal result '(1 2 3 4 5 6))
(eq result il:a)
(not (eq (nthcdr 2 result) il:b))
(eq (nthcdr 4 result) il:c))
))
))
;; Structure modifiers
(do-test "Simple _"
(special-let (il:a)
(and (eval-with-clisp "(A_T)") il:a)))
(do-test "_ with : in lists"
(special-let ((il:x (list 1 2 3 4 5)))
(let* ((old-x il:x) (result (eval-with-clisp "(X:2_T)")))
(and (equal result '(t 3 4 5))
(equal il:x '(1 t 3 4 5))
(eq result (cdr old-x))
(eq il:x old-x)
(tailp il:x old-x))
(and (equal (setq result (eval-with-clisp "(X:-2_NIL)")) '(nil 5))
(equal il:x '(1 t 3 nil 5))
(eq result (nthcdr 3 old-x))
(eq il:x old-x)
(tailp il:x old-x))
)
))
(do-test "_ with :: in lists"
(special-let ((il:x (list 1 2 3)))
(let* ((old-x il:x) (result (eval-with-clisp "(X::1_NIL)")))
(and (equal result '(1))
(equal il:x '(1))
(eq old-x il:x)
(tailp old-x il:x)))
))
(do-test "_ with : in records"
(special-let ((il:myrec (il:create il:rec)))
(let ((old-rec il:myrec))
(and (eq (eval-with-clisp "(MYREC:REC.B.B1_T)") t)
(equal il:myrec '(100 (t 20) 200))
(eq old-rec il:myrec)
(tailp old-rec il:myrec)
(tailp (second old-rec) (second il:myrec))))
))
(do-test "Left v. right precedence of _"
(special-let ((il:a 1) (il:b 2) (il:c 3))
(and (eql (eval-with-clisp "(A+B_C)") 4)
(eql il:a 1) (eql il:b 3) (eql il:c 3)))
(special-let ((il:a 1) (il:b 2) (il:c 3))
(and (eql (eval-with-clisp "(A_B+C)") 5)
(eql il:a 5) (eql il:b 2) (eql il:c 3)))
)
;; Quoting
(do-test "Quote operator"
(special-let ((il:a 'il:b) (il:c 'il:don\'t))
(and (eq (eval-with-clisp "(A='B)") t)
(eq (eval-with-clisp "(C='DON'T)") t))))
;; Not
(do-test "NOT operator"
(special-let ((il:a 20) (il:b 10))
(and (eval-with-clisp "(EQ ~NIL T)") (eval-with-clisp "(A ~LE B)"))))
;; Random operator precedence
(do-test "CLISP operator precedence"
(every #'(lambda (pair) (eql (eval-with-clisp (car pair)) (cdr pair)))
'(("(1 + 3 * 2)" . 7)
("(10 - 4 ^ 2)" . -6)
("(1 + 3 ~= 5)" . t)
("(2 * 3 ^ 3)" . 54)
("(2 * 2 = 4)" . t)
("(4 - 1 LT 1 + 2 * 3)" . t)
("(~NIL AND T)" . t))
))
)