1136 lines
41 KiB
Common Lisp
1136 lines
41 KiB
Common Lisp
;-*- Syntax:COMMON-LISP -*-
|
||
|
||
;------------------------------------------------------------------------ ;
|
||
; Copyright (c) Richard C. Waters, 1988 ;
|
||
;------------------------------------------------------------------------ ;
|
||
|
||
; This is a file of test cases to test OSS. Just load it and run the
|
||
;function (DO-TESTS). It prompts you for the name of a scratch file
|
||
;to use when testing. It then prints out identifying numbers of tests
|
||
;as it performs one test after another. When all of the tests have
|
||
;been run a summary line is printed saying how many tests failed.
|
||
|
||
; Whenever a test fails for any reason, an error is signalled. To continue
|
||
;testing call the function (MORE) either within the break, or at top
|
||
;level after aborting the execution of a test. (The latter is useful
|
||
;if a test leads to an infinite loop.) When all of the tests have
|
||
;been completed, the variable TESTS-FAILED contains a list of the
|
||
;numbers of the tests that failed. (You can look at the tests
|
||
;themselves by evaluating (NTH N TEST-LIST) for any test number.)
|
||
|
||
; After running the tests and fixing problems which arise you may wish
|
||
;to run some or all of the tests again. Calling (DO-TESTS) runs all
|
||
;of the tests again. Calling (DO-FAILED-TESTS) runs just the tests
|
||
;which failed the first time. (The variable TESTS-FAILED is updated
|
||
;to reflect the new state of affairs in either case.) Calling
|
||
;(DO-TEST n) runs just the test with the given number. (In some
|
||
;lisps, if you run the tests more than once without rstarting the
|
||
;lisp, you can get some warnings about redefining functions called
|
||
;FOOn. These do not indicate any problem.)
|
||
|
||
;THINGS TO DO BY HAND: Look at what Esymbols does in detail.
|
||
|
||
(use-package "OSS")
|
||
(proclaim '(special form test-list tests-failed))
|
||
(defvar in-tester nil)
|
||
(defvar tests nil)
|
||
(defvar test-file nil)
|
||
|
||
(defun do-tests ()
|
||
(format T "~% Running the suit of ~S test cases~%" (length test-list))
|
||
(setq tests (do ((i (1- (length test-list)) (1- i))
|
||
(r nil (cons i r)))
|
||
((minusp i) r))
|
||
tests-failed nil)
|
||
(do-many-tests))
|
||
|
||
(defun do-failed-tests ()
|
||
(format T "~% Running the ~S failed tests~%" (length tests-failed))
|
||
(setq tests tests-failed tests-failed nil)
|
||
(do-many-tests))
|
||
|
||
(defun do-many-tests ()
|
||
(loop (when (null tests)
|
||
(setq tests-failed (nreverse tests-failed))
|
||
(if (zerop (length tests-failed))
|
||
(format T "~2% OSS passed all tests.")
|
||
(format T "~2% OSS failed ~A tests." (length tests-failed)))
|
||
(return (values)))
|
||
(format T " ~A" (car tests))
|
||
(do-test (pop tests))))
|
||
|
||
(defun more ()
|
||
(if in-tester (throw 'in-tester nil) (do-many-tests)))
|
||
|
||
(defun do-test (n)
|
||
(when (null test-file)
|
||
(format T "~%Type a pathname of a scratch disk file ending in <newline>: ")
|
||
(setq test-file (read-line)))
|
||
(catch 'in-tester
|
||
(let* ((info (nth n test-list))
|
||
(*break-on-warnings* T)
|
||
(tester (if (symbolp (car info)) (pop info) 'test-ordinary))
|
||
(value (cadr info))
|
||
(pop-if-no-failure nil)
|
||
(in-tester T))
|
||
(setq form (car info))
|
||
(when (not (member n tests-failed))
|
||
(push n tests-failed)
|
||
(setq pop-if-no-failure T))
|
||
(let ((result (funcall tester (oss::iterative-copy-tree form))))
|
||
(when (not (equal result value))
|
||
(format t "~%form: ~S~% desired value ~S~% actual value ~S~%"
|
||
form value result)
|
||
(pprint *last-oss-loop*)
|
||
(error "failed test"))
|
||
(when pop-if-no-failure
|
||
(pop tests-failed)))))) ;doesn't happen when abort out of test error
|
||
|
||
;This is useful for special test cases, and rerunning the last test case.
|
||
|
||
(defmacro r (&optional (f nil))
|
||
(if f (setq form f))
|
||
(setq f (oss::iterative-copy-tree form))
|
||
(gensym 1)
|
||
(setq f (macroexpand f))
|
||
(pprint f)
|
||
(cond ((Y-or-N-p "continue") f)))
|
||
|
||
;Helper funtions for tests.
|
||
|
||
(defun test-ordinary (form)
|
||
(funcall (compile nil `(lambda () ,form))))
|
||
|
||
(defun test-def (form)
|
||
(eval (car form))
|
||
(compile (cadar form))
|
||
(test-ordinary (cadr form)))
|
||
|
||
(defun test-warn (form)
|
||
(let (v (*break-on-warnings* nil))
|
||
(setq *last-oss-error* nil)
|
||
(with-output-to-string (*error-output*) (setq v (test-ordinary form)))
|
||
(list v (car *last-oss-error*))))
|
||
|
||
(defun test-tut (form)
|
||
(unwind-protect
|
||
(progn (oss-tutorial-mode T) (test-ordinary form))
|
||
(oss-tutorial-mode nil)))
|
||
|
||
(defmacro dummy-mac (stuff) `(car ,stuff))
|
||
|
||
(defun decls (arg) (declare (ignore arg)) (decls0 *last-oss-loop*))
|
||
(defun decls0 (tree)
|
||
(cond ((not (consp tree)) nil)
|
||
((eq (car tree) 'declare) tree)
|
||
(T (do ((l tree (cdr l))) ((not (consp l)) nil)
|
||
(let ((x (decls0 (car l))))
|
||
(if x (return x)))))))
|
||
|
||
;the first few pages of tests attempt to test each of the different
|
||
;series operations in the series function library.
|
||
|
||
(setq test-list '(
|
||
((Rlist (Eoss 'a 'b 'c)) (a b c))
|
||
((Rlist (Eoss 'a 'b 'c :R)) (a b c))
|
||
((Rlist (list (Eoss 'a0 :R 'a1 'b1) (Elist '(z a b c))))
|
||
((a0 z) (a1 a) (b1 b) (a1 c)))
|
||
((Rlist (list (Eoss :R 'a1 'b1) (Elist '(a b c))))
|
||
((a1 a) (b1 b) (a1 c)))
|
||
((Rlist (list (Eoss :R 'a1) (Elist '(a b c)))) ((a1 a) (a1 b) (a1 c)))
|
||
((Rlist (Eoss)) ())
|
||
|
||
((Rlist (list (Eup) (Elist '(a b c)))) ((0 a) (1 b) (2 c)))
|
||
((Rlist (list (Eup 4 :by 3) (Elist '(a b c)))) ((4 a) (7 b) (10 c)))
|
||
((Rlist (Eup 0 :to 3)) (0 1 2 3))
|
||
((Rlist (Eup 0 :below 3)) (0 1 2))
|
||
((Rlist (Eup 0 :length 3)) (0 1 2))
|
||
((Rlist (Eup 2 :to 3)) (2 3))
|
||
((Rlist (Eup 2 :below 3)) (2))
|
||
((Rlist (Eup 2 :length 3)) (2 3 4))
|
||
((Rlist (Eup 4 :to 3)) ())
|
||
((Rlist (Eup 4 :below 3)) ())
|
||
((Rlist (Eup 4 :length 3)) (4 5 6))
|
||
((Rlist (Eup :to 3 :by 2)) (0 2))
|
||
((Rlist (Eup :to 4 :by 2)) (0 2 4))
|
||
((Rlist (Eup :below 3 :by 2)) (0 2))
|
||
((Rlist (Eup :below 4 :by 2)) (0 2))
|
||
((Rlist (Eup :length 3 :by 2)) (0 2 4))
|
||
((Rlist (round (* 10. (Eup 1.5 :by .2 :below 2.0)))) (15 17 19))
|
||
|
||
((Rlist (list (Edown) (Elist '(a b c)))) ((0 a) (-1 b) (-2 c)))
|
||
((Rlist (list (Edown 4 :by 3) (Elist '(a b c)))) ((4 a) (1 b) (-2 c)))
|
||
((Rlist (Edown 0 :to -3)) (0 -1 -2 -3))
|
||
((Rlist (Edown 0 :above -3)) (0 -1 -2))
|
||
((Rlist (Edown 0 :length 3)) (0 -1 -2))
|
||
((Rlist (Edown 4 :to 3)) (4 3))
|
||
((Rlist (Edown 4 :above 3)) (4))
|
||
((Rlist (Edown 4 :length 3)) (4 3 2))
|
||
((Rlist (Edown :to -3 :by 2)) (0 -2))
|
||
((Rlist (Edown :to -4 :by 2)) (0 -2 -4))
|
||
((Rlist (Edown :above -3 :by 2)) (0 -2))
|
||
((Rlist (Edown :above -4 :by 2)) (0 -2))
|
||
((Rlist (Edown :length 3 :by 2)) (0 -2 -4))
|
||
|
||
((Rlist (Esublists '(a b c))) ((a b c) (b c) (c)))
|
||
((Rlist (Esublists '(a b . c) #'atom)) ((a b . c) (b . c)))
|
||
((Rlist (Esublists ())) ())
|
||
|
||
((Rlist (Elist '(a b c))) (a b c))
|
||
((Rlist (Elist '(a b . c) #'atom)) (a b))
|
||
((Rlist (Elist ())) ())
|
||
((letS ((x '(a b c)))
|
||
(alterS (Elist x) (Eup))
|
||
x) (0 1 2))
|
||
|
||
((Rlist (Ealist '((1 . a) () (2) (1 . c)))) (1 2))
|
||
((Rlist (Ealist ())) ())
|
||
((letS (((key value) (Ealist '((1 . a) () (2) (1 . c)))))
|
||
(Rlist (list key value))) ((1 a) (2 nil)))
|
||
((let ((alist '((a . 1) (b . 2))))
|
||
(letS (((key val) (Ealist alist)))
|
||
(alterS key (list key))
|
||
(alterS val (list val)))
|
||
alist) (((a) . (1)) ((b) . (2))))
|
||
|
||
((Rlist (Eplist '(P1 1 P2 2 P1 3 P3 4))) (P1 P2 P3))
|
||
((Rlist (Eplist ())) ())
|
||
((letS (((key value) (Eplist '(P1 1 P2 2 P1 3))))
|
||
(Rlist (list key value))) ((P1 1) (P2 2)))
|
||
((let ((plist '(a 1 b 2)))
|
||
(letS (((key val) (Eplist plist)))
|
||
(alterS key (list key))
|
||
(alterS val (list val)))
|
||
plist) ((a) (1) (b) (2)))
|
||
|
||
((Rlist (Etree '(1 (2 3) 4))) ((1 (2 3) 4) 1 (2 3) 2 3 4))
|
||
((Rlist (Etree '(1 (2 3) 4) #'atom)) ((1 (2 3) 4) 1 (2 3) 2 3 4))
|
||
((Rlist (Etree '(1 (2 3) 4) #'(lambda (n) (not (and (consp n) (cddr n))))))
|
||
((1 (2 3) 4) 1 (2 3) 4))
|
||
((Rlist (Etree nil)) (nil))
|
||
((let ((tree '((3) 4)))
|
||
(letS ((leaf (Efringe tree)))
|
||
(if (evenp leaf) (alterS leaf (- leaf))))
|
||
tree) ((3) -4))
|
||
|
||
((Rlist (Efringe '((1 2 ((3 . 4) 4) (5) () (((6)))))))
|
||
(1 2 3 4 5 nil 6))
|
||
((Rlist (Efringe '(1 2 ((3 . 4) 4) (5) () (((6))))
|
||
#'(lambda (n) (not (and (consp n) (cdr n))))))
|
||
(1 2 3 4 (5) nil (((6)))))
|
||
((Rlist (Efringe ())) (nil))
|
||
((letS ((z '(a b (3 . e) d)))
|
||
(letS* ((x (Efringe z)))
|
||
(alterS x (list x)))
|
||
z) ((a) (b) ((3) . e) (d)))
|
||
|
||
((Rlist (Evector '#(1 2 3))) (1 2 3))
|
||
((Rlist (Evector '#())) ())
|
||
((Rlist (Evector '#(1 2 3) (Eup 1 :to 2))) (2 3))
|
||
((Rlist (Evector '#(1 2 3) (Eoss 2 0 1 9 0))) (3 1 2))
|
||
((letS ((v "FOOBAR"))
|
||
(alterS (Evector v (Eoss 2 3 4)) #\-)
|
||
v) "FO---R")
|
||
((letS ((v "FOOBAR"))
|
||
(alterS (Evector v) #\-)
|
||
v) "------")
|
||
|
||
((Rlist (Esequence '#(1 2 3))) (1 2 3))
|
||
((Rlist (Esequence '#(1 2 3) (Eup 1 :to 2))) (2 3))
|
||
((Rlist (Esequence '#(1 2 3) (Eoss 2 0 1 9 0))) (3 1 2))
|
||
((letS ((v "FOOBAR"))
|
||
(alterS (Esequence v (Eoss 2 3 4)) #\-)
|
||
v) "FO---R")
|
||
((Rlist (Esequence '(1 2 3))) (1 2 3))
|
||
((Rlist (Esequence '(1 2 3) (Eup 1 :to 2))) (2 3))
|
||
((Rlist (Esequence '(1 2 3) (Eoss 2 0 1 9 0))) (3 1 2))
|
||
((letS ((y '(F O O B A R)))
|
||
(alterS (Esequence y (Eoss 2 3 4)) '-)
|
||
y) (F O - - - R))
|
||
|
||
((letS (((key val) (Ehash (let ((x (make-hash-table)))
|
||
(setf (gethash 'color x) 'brown)
|
||
(setf (gethash 'name x) 'fred)
|
||
x))))
|
||
(sort (Rlist (cons key val))
|
||
#'(lambda (x y)
|
||
(string-lessp (string (car x)) (string (car y))))))
|
||
((color . brown) (name . fred)))
|
||
|
||
((progn (Rfirst (Esymbols)) nil) nil) ;grotesquely weak tests
|
||
((progn (Rfirst (Esymbols (find-package "OSS"))) nil) nil)
|
||
|
||
((Rlist (car (EnumerateF '(a b c) #'cdr #'null))) (a b c))
|
||
((Rlist (list (Elist '(a b c)) (car (EnumerateF '(1 2) #'cdr))))
|
||
((a 1) (b 2) (c nil)))
|
||
((Rlist (car (Enumerate-inclusiveF '(a b c) #'cdr #'null)))
|
||
(a b c nil))
|
||
((Rlist (car (Enumerate-inclusiveF () #'cdr #'null))) (nil))
|
||
|
||
((Rlist (Tprevious (Elist '(a b c)))) (nil a b))
|
||
((Rlist (Tprevious (Elist '(a b c)) 'fill 2)) (fill fill a))
|
||
((Rlist (Tprevious (Elist '(a b c)) 0)) (0 a b))
|
||
|
||
((Rlist (Tlatch (Elist '(nil 3 nil 4 5)))) (nil 3 nil nil nil))
|
||
((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :after 2)) (nil 3 nil 4 nil))
|
||
((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :after 0)) (nil nil nil nil nil))
|
||
((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :after 2 :pre 'a)) (A A A A 5))
|
||
((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :after 2 :pre 'a :post 'b))
|
||
(A A A A B))
|
||
((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :after 2 :post 'b)) (nil 3 nil 4 B))
|
||
((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :before 2)) (nil 3 nil nil nil))
|
||
((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :before 0)) (nil nil nil nil nil))
|
||
((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :before 2 :pre 'a)) (A A A 4 5))
|
||
((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :before 2 :pre 'a :post 'b))
|
||
(A A A B B))
|
||
((Rlist (Tlatch (Elist '(nil 3 nil 4 5)) :before 2 :post 'b)) (nil 3 nil B B))
|
||
|
||
((Rlist (Tuntil (Eoss nil nil T nil T) (Eoss 1 2 3))) (1 2))
|
||
((Rlist (Tuntil (Eoss) (Eoss 1 2 3))) ())
|
||
((letS ((x (Eoss 1 2 3 nil nil)))
|
||
(Rlist (Tuntil (Tprevious (null x)) x)))
|
||
(1 2 3 nil))
|
||
|
||
((Rlist (TuntilF #'null (Eoss 1 2 3 nil nil))) (1 2 3))
|
||
((letS ((fn #'null))
|
||
(Rlist (TuntilF fn (Eoss 1 2 3 nil nil)))) (1 2 3))
|
||
((let ((v '(1 -2 3)))
|
||
(letS ((x (TuntilF #'minusp (Elist v))))
|
||
(alterS x (- x)))
|
||
v) (-1 -2 3))
|
||
|
||
((let ((c 1))
|
||
(Rlist (cons (Elist '(a b c)) (TmapF #'(lambda () (incf c))))))
|
||
((a . 2) (b . 3) (c . 4)))
|
||
((letS* ((tt '((1 2) (3 4)))
|
||
(e (Elist tt)))
|
||
(Rlist (TmapF #'(lambda (e f) (list (Rbag (Elist e)) e)) e e)))
|
||
(((2 1) (1 2)) ((4 3) (3 4))))
|
||
((lets ((e (Elist '((1 2) (3 4)))))
|
||
(Rlist (TmapF #'(lambda (e) (Rsum (Elist e))) e))) (3 7))
|
||
((Rlist (TmapF #'dummy-mac (Elist '((1) (2))))) (1 2))
|
||
|
||
((Rlist (TscanF 0 #'+ (Elist '(1 2 3)))) (1 3 6))
|
||
((Rlist (TscanF 0 #'- (Elist '(1 2 3)))) (-1 -3 -6))
|
||
((Rlist (TscanF #'+ (Elist '(1 2 3)))) (1 3 6))
|
||
((Rlist (TscanF #'- (Elist '(1 2 3)))) (1 -1 -4))
|
||
|
||
((letS (((x y) (Tcotruncate (Eoss 1 2 3) (Eoss 4 5))))
|
||
(list (Rsum x) (Rsum y))) (3 9))
|
||
((letS (((x y) (Tcotruncate (Eoss) (Eoss 4 5))))
|
||
(list (Rsum x) (Rsum y))) (0 0))
|
||
((letS (((x) (Tcotruncate (Eoss 4 5))))
|
||
(list (Rsum x))) (9))
|
||
((letS (((x y) (Tcotruncate (Eoss 1 2 3) (Eoss 4 5))))
|
||
(list (Rsum (+ x y)) (Rsum y))) (12 9))
|
||
|
||
((Rlist (Tremove-duplicates (Eoss 1 2 1 2 3))) (1 2 3))
|
||
((Rlist (Tremove-duplicates (Elist '((1 a) (1 b) (2 c) (1 d) (3 e) (2 f)))
|
||
#'(lambda (x y) (eql (car x) (car y)))))
|
||
((1 a) (2 c) (3 e)))
|
||
|
||
((Rlist (Tchunk 0 (Elist '(a b c)))) ((a) (b) (c)))
|
||
((Rlist (Tchunk 1 (Elist '(a b c)))) ((a) (b) (c)))
|
||
((Rlist (Tchunk 2 (Elist '(a b c)))) ((a b)))
|
||
((Rlist (Tchunk 3 (Elist '(a b c)))) ((a b c)))
|
||
((Rlist (Tchunk 4 (Elist '(a b c)))) ())
|
||
|
||
((Rlist (Twindow 1 (Elist '(a b c)))) ((a) (b) (c)))
|
||
((Rlist (Twindow 2 (Elist '(a b c)))) ((a b) (b c)))
|
||
((Rlist (Twindow 4 (Elist '(a b c)))) ())
|
||
|
||
((Rlist (Tconcatenate (Elist '(a b c)) (Elist '(1 2 3))))
|
||
(a b c 1 2 3))
|
||
((Rlist (Tconcatenate (Eoss) (Elist '(a b c)) (Eoss) (Elist '(a b c))))
|
||
(a b c a b c))
|
||
((LetS ((x (Eoss 1 2)) (y (Eoss 3 4)))
|
||
(Rlist (Tconcatenate x y))) (1 2 3 4))
|
||
|
||
((Rlist (TconcatenateF #'Elist (Elist '((1 2) (3) () (4 5)))))
|
||
(1 2 3 4 5))
|
||
((Rlist (TconcatenateF #'Elist (Elist ()))) ())
|
||
((lets (((p v) (TconcatenateF #'Eplist (Elist '((a 1) (b 2 c 3))))))
|
||
(Rlist (list p v))) ((a 1) (b 2) (c 3)))
|
||
|
||
((Rlist (Tsubseries (Elist '(a b c)) 1 2)) (b))
|
||
((Rlist (Tsubseries (Elist '(a b c)) 1)) (b c))
|
||
((let ((v '(1 -2 3)))
|
||
(letS ((x (Tsubseries (Elist v) 1)))
|
||
(alterS x (- x)))
|
||
v) (1 2 -3))
|
||
|
||
((Rlist (Tpositions (Elist '(a nil 3 nil T nil)))) (0 2 4))
|
||
((Rlist (Tpositions (Elist '(nil 3 T nil)))) (1 2))
|
||
((Rlist (Tpositions (Elist '(nil nil)))) ())
|
||
|
||
((Rlist (Tsubseries (Tmask (Elist '())) 0 6)) (nil nil nil nil nil nil))
|
||
((Rlist (Tsubseries (Tmask (Elist '(0 2 4))) 0 6)) (T nil T nil T nil))
|
||
|
||
((Rlist (Tmerge (Eoss 1 3 7 9) (Eoss 4 5 8) #'<)) (1 3 4 5 7 8 9))
|
||
((Rlist (Tmerge (Eoss 4 5 8) (Eoss 1 3 7 9) #'<)) (1 3 4 5 7 8 9))
|
||
|
||
((letS (((lp a) (Tlastp (Elist '(a b c d)))))
|
||
(list (Rlist lp) (Rlist a))) ((nil nil nil T) (a b c d)))
|
||
((letS (((lp a) (Tlastp (Elist '(a)))))
|
||
(list (Rlist lp) (Rlist a))) ((T) (a)))
|
||
((letS (((lp a) (Tlastp (Elist nil))))
|
||
(list (Rlist lp) (Rlist a))) (nil nil))
|
||
|
||
((Rlist (Tselect (Eoss t t nil nil t) (Elist '(1 2 nil nil -4))))
|
||
(1 2 -4))
|
||
((Rlist (Tselect (Elist '(1 2 nil nil -4)))) (1 2 -4))
|
||
((letS ((x (Elist '(1 -1 2 -2))))
|
||
(Rlist (Tselect (plusp x) x))) (1 2))
|
||
((letS ((x (Elist '(1 -1 2 -2))))
|
||
(Rlist (if (plusp x) x))) (1 nil 2 nil))
|
||
((letS ((x (Elist '(1 -1 2 -2))))
|
||
(Rlist (if (plusp x) x (- x)))) (1 1 2 2))
|
||
((letS ((x (Elist '(0 1 -1 2 -2))))
|
||
(Rlist (list (Tselect (plusp x) x) (Eup)))) ((1 0) (2 1)))
|
||
((letS ((x (Elist '(0 1 -1 2 -2)))
|
||
(tag (Eup)))
|
||
(Rlist (list (Tselect (plusp x) x) tag))) ((1 0) (2 1)))
|
||
|
||
((Rlist (TselectF #'minusp (Elist '(1 2 -2 3 -4)))) (-2 -4))
|
||
((letS ((fn #'minusp))
|
||
(Rlist (TselectF fn (Elist '(1 2 -2 3 -4))))) (-2 -4))
|
||
((let ((v '(1 -2 3)))
|
||
(letS ((x (TselectF #'minusp (Elist v))))
|
||
(alterS x (- x)))
|
||
v) (1 2 3))
|
||
|
||
((Rlist (Texpand (Eoss nil T nil T nil) (Elist '(a b c))))
|
||
(nil a nil b nil))
|
||
((Rlist (Texpand (Eoss nil T nil T) (Elist '(a b c)) T)) (T a T b))
|
||
|
||
((letS* ((x (Elist '(1 -1 2 -2)))
|
||
((y+ y-) (Tsplit x (Eoss :R t nil t nil))))
|
||
(list (Rlist x) (Rlist y+) (Rlist y-)))
|
||
((1 -1 2 -2) (1 2) (-1 -2)))
|
||
((letS* ((x (Elist '(1 0 -1 2 0 -2)))
|
||
((y+ y- y0) (Tsplit x (Eoss :R t nil nil t nil nil)
|
||
(Eoss :R nil nil t nil nil t))))
|
||
(list (Rlist y+) (Rlist y-) (Rlist y0) (Rlist x)))
|
||
((1 2) (-1 -2) (0 0) (1 0 -1 2 0 -2)))
|
||
|
||
((letS* ((x (Elist '(1 -1 2 -2)))
|
||
((y+ y-) (TsplitF x #'plusp)))
|
||
(list (Rlist x) (Rlist y+) (Rlist y-)))
|
||
((1 -1 2 -2) (1 2) (-1 -2)))
|
||
((letS* ((x (Elist '(1 -1 2 -2)))
|
||
(y+ (TsplitF x #'plusp)))
|
||
(Rlist (+ y+ y+)))
|
||
(2 4))
|
||
((letS* ((x (Elist '(1 -1 2 -2)))
|
||
(y+ (TsplitF x #'plusp)))
|
||
(list (Rlist y+) (Rsum y+)))
|
||
((1 2) 3))
|
||
((letS* ((x (Elist '(1 -1 2 -2)))
|
||
(y+ (TsplitF x #'plusp)))
|
||
(Rlist (Tconcatenate y+ (Eoss 5 6))))
|
||
(1 2 5 6))
|
||
((letS* ((x (Elist '(1 0 -1 2 0 -2)))
|
||
((y+ y- y0) (TsplitF x #'plusp #'minusp)))
|
||
(list (Rlist y+) (Rlist y-) (Rlist y0) (Rlist x)))
|
||
((1 2) (-1 -2) (0 0) (1 0 -1 2 0 -2)))
|
||
((letS* ((x (Elist '(1 (nil) (3))))
|
||
((y+ y- y0) (TsplitF x #'numberp #'car)))
|
||
(list (Rlist y+) (Rlist y-) (Rlist y0)))
|
||
((1) ((3)) ((nil))))
|
||
|
||
((Rlist (Elist '(a b c))) (a b c))
|
||
|
||
((Rbag (Elist '(a b c))) (c b a))
|
||
((Rbag (Tremove-duplicates (Elist '(a (a) a (a) b a)) #'equal)) (b (a) a))
|
||
|
||
((list (Rappend (Eoss '(a b c) '(a b c))) '(a b c))
|
||
((a b c a b c) (a b c)))
|
||
((Rappend (Eoss)) ())
|
||
((letS ((a (list 1 2)) (b '(3 4)))
|
||
(Rappend (Eoss a b))
|
||
a) (1 2))
|
||
|
||
((Rnconc (Elist '(() (a b) () (c d) (e) ()))) (a b c d e))
|
||
((Rnconc (Eoss)) ())
|
||
((letS ((a (list 1 2)) (b '(3 4)))
|
||
(Rnconc (Eoss a b))
|
||
a) (1 2 3 4))
|
||
|
||
((Ralist (Elist '(d e d)) (Elist '(a b c))) ((d . a) (e . b) (d . c)))
|
||
((Ralist (Elist '(d e d)) (Elist '())) ())
|
||
|
||
((Rplist (Elist '(d e d)) (Elist '(a b c))) (d a e b d c))
|
||
((Rplist (Elist '(d e d)) (Elist '())) ())
|
||
|
||
((let ((h (Rhash (Elist '(color name)) (Elist '(brown fred)))))
|
||
(letS (((key val) (Ehash h)))
|
||
(sort (Rlist (cons key val))
|
||
#'(lambda (x y)
|
||
(string-lessp (string (car x)) (string (car y)))))))
|
||
((color . brown) (name . fred)))
|
||
|
||
#-:GCLISP((concatenate 'list (Rvector (Elist '(a b c)))) (a b c))
|
||
#-:GCLISP((concatenate 'list (Rvector (Eoss))) ())
|
||
#-:GCLISP((Rvector (Eoss #\B #\A #\R) :element-type 'string-char) "BAR")
|
||
((concatenate 'list (Rvector (Elist '(a b c)) :size 3)) (a b c))
|
||
((concatenate 'list
|
||
(Rvector (Elist '(a b c)) :size 4 :initial-element 0)) (a b c 0))
|
||
|
||
((progn (if (probe-file test-file) (delete-file test-file))
|
||
(Rfile test-file (Elist '(a b c)))
|
||
(Rlist (Efile test-file))) (a b c))
|
||
|
||
((Rfirst-late (Elist '(a b c))) a)
|
||
((Rfirst-late (Eoss)) nil)
|
||
((Rfirst-late (Eoss) 'fill) fill)
|
||
|
||
((Rlast (Elist '(a b c))) c)
|
||
((Rlast (Eoss)) nil)
|
||
((Rlast (Eoss) 'fill) fill)
|
||
|
||
((Rnth-late 1 (Elist '(a b c))) b)
|
||
((Rnth-late 1 (Eoss)) nil)
|
||
((Rnth-late 1 (Eoss) 'fill) fill)
|
||
|
||
((Rlength (Elist '(a b c))) 3)
|
||
((Rlength (Eoss)) 0)
|
||
((Rlength (Tselect (plusp (Eoss 1 -1 2 -2)))) 2)
|
||
|
||
((Rsum (Elist '(1 2 3))) 6)
|
||
((Rsum (Elist nil)) 0)
|
||
|
||
((Rmin (Elist '(1 2 3))) 1)
|
||
((Rmin (Elist nil)) nil)
|
||
|
||
((Rmax (Elist '(1 2 3))) 3)
|
||
((Rmax (Elist nil)) nil)
|
||
|
||
((Rand-late (Eoss 1 2)) 2)
|
||
((Rand-late (Eoss)) T)
|
||
|
||
((Ror-late (Eoss 1 2)) 1)
|
||
((Ror-late (Eoss nil)) nil)
|
||
((Ror-late (Eoss)) nil)
|
||
|
||
((ReduceF 0 #'+ (Elist '(1 2 3))) 6)
|
||
((ReduceF 0 #'- (Eoss 1 2 3)) -6)
|
||
((ReduceF 0 #'+ (Elist nil)) 0)
|
||
((ReduceF T #'+ (Elist nil)) T)
|
||
|
||
((Rfirst (Elist '(a b c))) a)
|
||
((Rfirst (Eoss)) nil)
|
||
((Rfirst (Eoss) 'T) T)
|
||
((Rfirst (car (Elist '((T) (nil) 4)))) T)
|
||
((Rfirst (Tpositions (plusp (Eoss -3 1 -1 3 -2)))) 1)
|
||
((Rfirst (Tselect (Eoss nil t nil) (Eoss 0 1 -1 3 -2))) 1)
|
||
|
||
((Rnth 1 (Elist '(a b c))) b)
|
||
((Rnth 1 (Eoss)) nil)
|
||
((Rnth 1 (Eoss) 'T) T)
|
||
((Rnth 1 (car (Elist '((T) (nil) 4)))) nil)
|
||
|
||
((Rand (Eoss 1 2)) 2)
|
||
((Rand (car (Elist '((T) (nil) 4)))) nil)
|
||
((Rand (Eoss)) T)
|
||
|
||
((Ror (Eoss nil)) nil)
|
||
((Ror (car (Elist '((T) (nil) 4)))) T)
|
||
((Ror (Eoss)) nil)
|
||
|
||
;this contains tests of the various special forms supported.
|
||
|
||
((lets* ((x (Elist '(a b c)))
|
||
(xx (list x)))
|
||
(Rlist (list x xx))) ((a (a)) (b (b)) (c (c))))
|
||
((lets* ((x (Elist '(a b c)))
|
||
(x (list x)))
|
||
(Rlist x)) ((a) (b) (c)))
|
||
((let ((x 9))
|
||
(lets ((x (Elist '(a b c)))
|
||
(xx (list x)))
|
||
(Rlist (list x xx)))) ((a (9)) (b (9)) (c (9))))
|
||
((lets () (Rlist (Elist '(a b c)))) (a b c))
|
||
((lets* ((e 3)
|
||
(f (Elist '(a b c)))
|
||
(g (Rlist f))
|
||
(h (Rlist (Elist '(a b c)))))
|
||
(list e g h)) (3 (a b c) (a b c)))
|
||
((letS ((x (Rlist (Elist '(1 2 3)))))
|
||
(list x)
|
||
x) (1 2 3))
|
||
((not (null (member '(type integer x)
|
||
(decls (letS ((x (Elist '(1 2 3))))
|
||
(declare (type integer x))
|
||
(Rsum x))) :test #'equal))) T)
|
||
((letS ()) nil)
|
||
((letS (((key value) (Ealist '((a . 1) (b . 2)))))
|
||
(Rlist (list key value))) ((a 1) (b 2)))
|
||
((letS ((key (Ealist '((a . 1) (b . 2)))))
|
||
(Rlist key)) (a b))
|
||
((let ((x 4))
|
||
(letS ((x (Elist '(1 2 3))))
|
||
(Rlist (TmapF #'(lambda (y) (+ x y)) x)))) (5 6 7))
|
||
|
||
((prognS) nil)
|
||
((prognS (Elist '(a b c)) (prognS)) nil)
|
||
((prognS (Elist '(a b c)) (funcallS #'(lambdaS ()))) nil)
|
||
((multiple-value-list (prognS (TmapF #'sqrt (Elist '(1 2))))) nil)
|
||
|
||
((Ralist (Elist '(a b)) (* 2 3)) ((a . 6) (b . 6)))
|
||
((let ((x 1))
|
||
(Ralist (Elist '(a b)) (setq x (1+ x)))) ((a . 2) (b . 2)))
|
||
|
||
((Rsum (car (Elist '((1) (2))))) 3)
|
||
((Rsum (* 2 (Elist '(1 2)))) 6)
|
||
((let ((x 1))
|
||
(Rlist (list (Elist '(a b)) (setq x (1+ x))))) ((a 2) (b 3)))
|
||
((let ((x 1))
|
||
(Rlist (list (Elist '(a b)) (Eoss :R (setq x (1+ x)))))) ((a 2) (b 2)))
|
||
((Rlist (if (plusp (Elist '(10 -11 12))) (Eup))) (0 nil 2))
|
||
((Rlist (Tselect (plusp (Elist '(10 -11 12))) (Eup))) (0 2))
|
||
|
||
((letS ((z (Elist '(1 2))))
|
||
(Rlist (list z (mapS 2)))) ((1 2) (2 2)))
|
||
((letS ((z (Elist '(1 2))))
|
||
(Rlist (list z (mapS)))) ((1 nil) (2 nil)))
|
||
((letS ((z (Elist '(1 2))))
|
||
(Rlist (mapS (1+ z)))) (2 3))
|
||
((letS ((z (Elist '(1 2))))
|
||
(Rlist (mapS (do ((x 1 (1+ x)) (sum 0 (+ sum x))) ((> x z) sum)))))
|
||
(1 3))
|
||
((letS ((z (Elist '((1 2) (3 4)))))
|
||
(Rlist (mapS (Rlist (Elist z))))) ((1 2) (3 4)))
|
||
|
||
((funcalls #'Rlist (Elist '(a b c))) (a b c))
|
||
((Rlist (funcalls #'list (Elist '(a b c)))) ((a) (b) (c)))
|
||
((letS ((fn #'list))
|
||
(Rlist (funcalls fn (Elist '(a b c))))) ((a) (b) (c)))
|
||
((funcalls #'(lambdaS (x) (declare (type oss x)) (Rlist x))
|
||
(Elist '(a b c)))
|
||
(a b c))
|
||
|
||
(test-def ((defunS foo (list) "doc" (car (Elist list)))
|
||
(list #+lispm(documentation 'foo 'function)
|
||
(Rlist (foo '((a) (b) (c))))))
|
||
(#+lispm"doc" (a b c)))
|
||
|
||
(test-def ((defunS foo1 (list &optional (plus 1))
|
||
(+ (Elist list) plus))
|
||
(list (Rlist (foo1 '(1 2 3) 3))
|
||
(Rlist (foo1 '(1 2 3)))))
|
||
((4 5 6) (2 3 4)))
|
||
|
||
(test-def ((defunS foo2 (list &optional (plus 1 p?))
|
||
(list (Elist list) p?))
|
||
(list (Rlist (foo2 '(1 2 3) 3))
|
||
(Rlist (foo2 '(1 2 3)))))
|
||
(((1 T) (2 T) (3 T)) ((1 nil) (2 nil) (3 nil))))
|
||
|
||
(test-def ((defunS foo3 (list &key (plus 1))
|
||
(+ (Elist list) plus))
|
||
(list (Rlist (foo3 '(1 2 3) :plus 3))
|
||
(Rlist (foo3 '(1 2 3)))))
|
||
((4 5 6) (2 3 4)))
|
||
|
||
(test-def ((defunS foo4 (list &key (plus #'1+))
|
||
(funcall plus (Elist list)))
|
||
(list (Rlist (foo4 '(1 2 3) :plus #'1-))
|
||
(Rlist (foo4 '(1 2 3)))))
|
||
((0 1 2) (2 3 4)))
|
||
|
||
(test-def ((defunS foo5 (list &key (k 'list))
|
||
(list (Elist list) k))
|
||
(list (Rlist (foo5 '(1 2 3) :k 'a))
|
||
(Rlist (foo5 '(1 2 3)))))
|
||
(((1 a) (2 a) (3 a)) ((1 list) (2 list) (3 list))))
|
||
|
||
((multiple-value-list
|
||
(lets ((x (Elist '(a b)))) (valS (Rlist x) (Rbag x))))
|
||
((a b) (b a)))
|
||
((Rlist (funcallS #'(lambdaS (pairs)
|
||
(letS ((p (Elist pairs)))
|
||
(valS (car p) (cdr p))))
|
||
'((a . 1)(b . 2)))) (a b))
|
||
((letS (((x y) (funcallS #'(lambdaS (pairs)
|
||
(letS ((p (Elist pairs)))
|
||
(valS (car p) (cdr p))))
|
||
'((a . 1)(b . 2)))))
|
||
(list (Rlist x) (Rlist y))) ((a b) (1 2)))
|
||
((letS (((nil y) (funcallS #'(lambdaS (pairs)
|
||
(letS ((p (Elist pairs)))
|
||
(valS (car p) (cdr p))))
|
||
'((a . 1)(b . 2))))) (Rlist y)) (1 2))
|
||
((letS (((a b) (pass-valS 2 (intern (string (Elist '(x y)))))))
|
||
(Rlist (list a b))) ((x :internal) (y :internal)))
|
||
((letS (((a b) (intern (string (Elist '(x y))))))
|
||
(Rlist (list a b))) ((x :internal) (y :internal)))
|
||
|
||
((let ((v '(1 -2 3)))
|
||
(letS ((x (TselectF #'minusp (Elist v))))
|
||
(alterS x (- x)))
|
||
v) (1 2 3))
|
||
((letS ((x '(a b c)))
|
||
(alterS (Elist x) (Eup))
|
||
x) (0 1 2))
|
||
((letS ((x '((a) (b) (c))))
|
||
(setf (car (Elist x)) (Eup))
|
||
x) ((0) (1) (2)))
|
||
((lets ((e (Elist (list 1 2)))) (alters e (1+ e)) (rlist e)) (1 2))
|
||
|
||
((let ((*print-case* :upcase))
|
||
(with-output-to-string (f)
|
||
(Rbag (Elist (showS '(a b c) " ~S" f)))
|
||
f)) " (A B C)")
|
||
((let ((*print-case* :upcase))
|
||
(with-output-to-string (f)
|
||
(Rbag (showS (Elist '(a b c)) " ~S" f))
|
||
f)) " A B C")
|
||
((let ((*print-case* :upcase))
|
||
(with-output-to-string (f)
|
||
(showS (Rbag (Elist '(a b c))) " ~S" f)
|
||
f)) " (C B A)")
|
||
|
||
((Rlist (funcallS #'(lambda-primitiveS (x) (y) (y)
|
||
(declare (type oss x y) (type integer y))
|
||
(setq y (car x)))
|
||
(Elist '((1) (2))))) (1 2))
|
||
((funcallS #'(lambda-primitiveS (numbers) (number) (number)
|
||
(declare (type oss numbers))
|
||
(prologS (setq number 0))
|
||
(setq number (+ number numbers)))
|
||
(Elist '(1 2))) 3)
|
||
((funcallS #'(lambda-primitiveS (items) (list) (list)
|
||
(declare (type oss items))
|
||
(prologS (setq list nil))
|
||
(setq list (cons items list))
|
||
(epilogS (setq list (nreverse list))))
|
||
(Elist '(1 2))) (1 2))
|
||
((Rlist (funcallS #'(lambda-primitiveS (list) (items) (state items)
|
||
(declare (type oss items))
|
||
(prologS (setq state list))
|
||
(if (null state) (terminateS))
|
||
(setq items (car state))
|
||
(setq state (cdr state)))
|
||
'(1 2))) (1 2))
|
||
((Rlist (funcallS #'(lambda-primitiveS (Nitems1 Nitems2) (items) (items done)
|
||
(declare (type oss Nitems1 Nitems2 items))
|
||
(prologS (setq done nil))
|
||
(if done (go D))
|
||
(next-inS Nitems1 (setq done T) (go D))
|
||
(setq items Nitems1)
|
||
(go F)
|
||
D (next-inS Nitems2)
|
||
(setq items Nitems2)
|
||
F)
|
||
(Elist '(1 2)) (Elist '(3 4)))) (1 2 3 4))
|
||
|
||
((letS (((x+ x-) (funcallS #'(lambda-primitiveS (items pred)
|
||
(Nitems1 Nitems2) (Nitems1 Nitems2)
|
||
(declare (type oss items Nitems1 Nitems2))
|
||
(if (not (funcall pred items)) (go D))
|
||
(setq Nitems1 items)
|
||
(next-outS Nitems1)
|
||
(go F)
|
||
D (setq Nitems2 items)
|
||
(next-outS Nitems2)
|
||
F)
|
||
(Elist '(1 -2 3 -4))
|
||
#'plusp)))
|
||
(list (Rsum x+) (Rsum x-))) (4 -6))
|
||
|
||
(test-def ((defmacro Rcount (items)
|
||
(let ((counter (gensym)))
|
||
`(funcallS #'(lambda-primitiveS (items)
|
||
(result) (result)
|
||
(declare (type oss items))
|
||
(wrapS #'(lambda (body)
|
||
(list 'let '((,counter 0))
|
||
body)))
|
||
(incf ,counter)
|
||
(epilogS (setq result ,counter)))
|
||
,items)))
|
||
(Rcount (Elist '(1 2 3)))) 3)
|
||
|
||
((let ((l (list 1 2)))
|
||
(letS ((e (funcallS #'(lambda-primitiveS (list) (items) (state parent items)
|
||
(declare (type oss items))
|
||
(prologS (setq state list))
|
||
(if (null state) (terminateS))
|
||
(setq parent state)
|
||
(setq items (car state))
|
||
(setq state (cdr state))
|
||
(alterableS items (car parent)))
|
||
l)))
|
||
(alterS e (1+ e))
|
||
l)) (2 3))
|
||
((lets ((e (Elist '(1 -2 3))))
|
||
(Rlist (funcallS #'(lambda-primitiveS (Nitems) (Nitems) ()
|
||
(declare (type oss Nitems) (type number Nitems))
|
||
L (next-inS Nitems)
|
||
(if (not (plusp Nitems)) (go L)))
|
||
e))) (1 3))
|
||
((not
|
||
(null
|
||
(member '(type number e)
|
||
(decls
|
||
(lets ((e (Elist '(1 -2 3))))
|
||
(Rlist (funcallS #'(lambda-primitiveS (Nitems) (Nitems) ()
|
||
(declare (type oss Nitems)
|
||
(type number Nitems))
|
||
L (next-inS Nitems)
|
||
(if (not (plusp Nitems)) (go L)))
|
||
e))))
|
||
:test #'equal))) T)
|
||
|
||
((letS ((x (Eoss 1 2 3))
|
||
(y (Eoss 4 5)))
|
||
(list (Rsum x) (Rsum y))) (6 9))
|
||
((list (Rsum (Eoss 1 2 3)) (Rsum (Eoss 4 5))) (6 9))
|
||
|
||
;the following uses lambdaS to test all kinds of wierd combinations
|
||
;mg1
|
||
((funcalls #'(lambdaS (x) (lets ((z (list x))) (list z))) 4) ((4)))
|
||
((funcalls #'(lambdaS (x) (declare (type oss x)) (nreverse (Rbag x)))
|
||
(Elist '(a b c)))
|
||
(a b c))
|
||
((funcalls #'(lambdaS (x) (declare (type oss x)) (Rlist (list x)))
|
||
(Elist '(a b c)))
|
||
((a) (b) (c)))
|
||
;mg2
|
||
((funcalls #'(lambdaS (x y) (declare (type oss x y))
|
||
(list (Rlist x) (Rlist (Tselect (plusp y) y))))
|
||
(Elist '(a b c)) (Elist '(1 -2 3)))
|
||
((a b c) (1 3)))
|
||
((funcalls #'(lambdaS (x y) (declare (type oss x y))
|
||
(list (Rlist (Tselect (plusp y) y)) (Rlist x)))
|
||
(Elist '(a b c)) (Elist '(1 -2 3)))
|
||
((1 3) (a b c)))
|
||
|
||
;mg3
|
||
((Rlist (funcallS #'(lambdaS (x y z) (declare (type oss x y z))
|
||
(Tconcatenate (Tmerge x y #'<) z))
|
||
(Eoss 1 2 4) (Eoss 1 3 3) (Eoss 0)))
|
||
(1 1 2 3 3 4 0))
|
||
((letS (((a b) (Eplist '(k1 2 k2 4))))
|
||
(list (Rlist b)
|
||
(Rlist (Texpand (Eoss :R nil nil T nil T nil nil nil T)
|
||
a nil))))
|
||
((2 4) (nil nil k1 nil k2 nil nil nil)))
|
||
((Rlist (funcallS #'(lambdaS (x)
|
||
(letS (((a b) (Eplist x)))
|
||
(Texpand (Eoss nil nil T nil T nil nil nil T)
|
||
a nil)
|
||
b))
|
||
'(k1 2 k2 4)))
|
||
(2 4))
|
||
((Rlist (funcallS #'(lambdaS (x) (declare (type oss x))
|
||
(Tconcatenate (list x) (Eoss 5 6)))
|
||
(Elist '(1 2 3))))
|
||
((1) (2) (3) 5 6))
|
||
((Rlist (funcallS #'(lambdaS (x) (declare (type oss x))
|
||
(Tconcatenate (Tselect (plusp x) x)
|
||
(Eoss 5 6)))
|
||
(Elist '(1 -2 3))))
|
||
(1 3 5 6))
|
||
((Rlist (funcalls #'(lambdaS (x) (declare (type oss x))
|
||
(TselectF #'evenp (TsplitF x #'plusp)))
|
||
(Elist '(1 2 -2 3 4))))
|
||
(2 4))
|
||
((Rlist (funcalls #'(lambdaS (x) (declare (type oss x))
|
||
(List (TsplitF x #'plusp)))
|
||
(Elist '(1 2 -2 3 4))))
|
||
((1) (2) (3) (4)))
|
||
;mg4
|
||
((letS (((a b) (Eplist '(k1 1 k2 -2))))
|
||
(list (Rlist a) (Rlist (Tselectf #'plusp b))))
|
||
((k1 k2) (1)))
|
||
((Rlist (funcallS #'(lambdaS (x)
|
||
(letS (((a b) (Eplist x)))
|
||
(Rlist (Tselectf #'plusp b)) a))
|
||
'(k1 1 k2 -2)))
|
||
(k1 k2))
|
||
((let (z)
|
||
(list (Rlist (funcallS #'(lambdaS (x)
|
||
(letS (((a b) (Eplist x)))
|
||
(setq z (Rbag (Tselectf #'plusp b))) (list a)))
|
||
'(k1 1 k2 -2)))
|
||
z))
|
||
(((k1) (k2)) (1)))
|
||
|
||
;mg5
|
||
((LetS (((A B)
|
||
(funcalls #'(lambdaS (x y) (declare (type oss x))
|
||
(valS (Tselect (plusp x) x) (Elist y)))
|
||
(Elist '(1 -2 3)) '(a b c))))
|
||
(list (Rlist a) (Rlist b)))
|
||
((1 3) (a b)))
|
||
|
||
|
||
;these are weird tests checking for particular bugs in old versions
|
||
((let ((x (list 1 2 3)))
|
||
(prognS (list (setf (car (Esublists x)) (Elist '(a b c d))))) x)
|
||
(a b c)) ;don't want to have any complaints from setf here.
|
||
((let ((x (list 1 2 3)))
|
||
(prognS (setf (car (Esublists x)) (Elist '(a b c d)))) x)
|
||
(a b c)) ;don't want to have any complaints from setf here.
|
||
((Rfirst (TselectF #'(lambda (x) (and (car x) (cdr x)))
|
||
(Elist '((a) (nil . b) (a . b) (c))))) (a . b))
|
||
((letS ((l (car '((1 2 3 4)))))
|
||
(Rlist (list (Elist l) (Elist l)))) ((1 1) (2 2) (3 3) (4 4)))
|
||
((let ((x nil))
|
||
(TmapF #'(lambda (e) (push e x)) (Elist '(1 2))) x) (2 1))
|
||
|
||
((let ((oss::*renames* '((x . 2) (y . 3))) oss::*env*)
|
||
(oss::m-&-r '(prog (x) (list x y)))) (prog (x) (list x 3)))
|
||
((let ((oss::*renames* '((x . 2) (y . 3))) oss::*env*)
|
||
(oss::m-&-r '(prog a (x) (list x y)))) (prog a (x) (list x 3)))
|
||
((let ((oss::*renames* '((x . 2) (y . 3))) oss::*env*)
|
||
(oss::m-&-r '(prog* (x) (list x y)))) (prog* (x) (list x 3)))
|
||
((let ((oss::*renames* '((x . 2) (y . 3))) oss::*env*)
|
||
(oss::m-&-r '(prog* a (x) (list x y)))) (prog* a (x) (list x 3)))
|
||
((let ((oss::*renames* '((x . 2) (y . 3))) oss::*env*)
|
||
(oss::m-&-r '(multiple-value-bind (x) (list x y) (list x y))))
|
||
(multiple-value-bind (x) (list 2 3) (list x 3)))
|
||
|
||
((letS ((x (Elist '(2 -1 0 1 -2))))
|
||
(list (Rsum (Tselectf #'plusp x)) (Rsum (Tselectf #'minusp x)))) (3 -3))
|
||
((letS ((x (Elist '(2 -1 0 1 -2))))
|
||
(list (Rsum (Tselectf #'plusp x)) (Rsum (Tselect (minusp x) x)))) (3 -3))
|
||
((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp)))
|
||
(list (Rsum x) (Rsum (Tselectf #'minusp x)))) (0 -3))
|
||
((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp)))
|
||
(list (Rsum x) (Rbag (Tselectf #'plusp x)))) (0 (1 2)))
|
||
((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp)))
|
||
(list (Rsum x) (Rbag (Tselectf #'plusp x)) (Rmax (Tselectf #'plusp x))))
|
||
(0 (1 2) 2))
|
||
((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp)))
|
||
(list (Rsum (Tselectf #'plusp x)) (Rsum (Tselectf #'minusp x)))) (3 -3))
|
||
((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp)))
|
||
(list (Rsum (Tselectf #'plusp x)) (Rsum (Tselect (minusp x) x)))) (3 -3))
|
||
((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp)))
|
||
(list (Rsum (Tselectf #'plusp x)) (Rbag (Tselectf #'plusp x)))) (3 (1 2)))
|
||
((letS ((x (TsplitF (Elist '(2 -1 a 0 b 1 -2)) #'numberp)))
|
||
(list (Rsum (Tselectf #'plusp x)) (Rbag (Tselectf #'plusp x))
|
||
(Rmax (Tselectf #'plusp x))))
|
||
(3 (1 2) 2))
|
||
((lets* ((e1 (Elist '(1 -2 -4 3))) (e2 (Elist '(1 -2 -4 3))) (e3 (Elist '(1 -2 -4 3)))
|
||
(w1 (TsplitF e2 #'plusp)) ((nil x2) (TsplitF e3 #'plusp)))
|
||
(list (Rlist (list e1 w1)) (Rlist (list w1 x2))))
|
||
(((1 1) (-2 3)) ((1 -2) (3 -4))))
|
||
|
||
((let ((v '(1 -2 3)))
|
||
(letS* ((e (Elist v))
|
||
(x (TuntilF #'minusp e)))
|
||
(alterS x (- x)))
|
||
v) (-1 -2 3))
|
||
((Rlist (Tsubseries (Tmask (Tpositions (Eoss t nil t nil))) 0 5))
|
||
(t nil t nil nil))
|
||
((oss::nsubst-inline nil 1 '(3 1 2)) (3 2))
|
||
((Let ((X '(1 2 3)))
|
||
(macrolet ((bab (z) `(list ,z)))
|
||
(rlist (bab (elist x))))) ((1) (2) (3)))
|
||
|
||
;the following test error checking.
|
||
|
||
(test-warn (Rlist (Eup 0 :to 5 :below 6)) (1.1 1.1))
|
||
(test-warn (Rlist (Edown 0 :to 5 :length 6)) (1.2 1.2))
|
||
(test-warn (Rlist (Tlatch (Elist '(1 2)) :after 2 :before 3))
|
||
(1.3 1.3))
|
||
|
||
(test-warn (TconcatenateF #'car (Elist x)) (2 2))
|
||
(test-warn (TconcatenateF #'Efile (Elist x)) (2 2))
|
||
(test-warn (TconcatenateF #'Tpositions (Elist x)) (2 2))
|
||
|
||
(test-warn (defunS ff (a &rest b) (car a)) (3 3))
|
||
(test-warn (defunS ff (a &allow-other-keys b) (car a)) (3 3))
|
||
|
||
(test-warn (alterS (Eup :to 4) 5) (4 4))
|
||
(test-warn (alterS (car (Elist x)) 5) (4 4))
|
||
(test-warn (alterS (Tpositions (Elist x)) 5) (4 4))
|
||
|
||
(test-warn (funcalls #'(lambdaS ((A)) nil) 2) (5 5))
|
||
(test-warn (funcalls #'(lambdaS (T) nil) 2) (5 5))
|
||
(test-warn (funcalls #'(lambdaS (nil) nil) 2) (5 5))
|
||
(test-warn (funcalls #'(lambdaS (3) nil) 2) (5 5))
|
||
(test-warn (funcalls #'(lambdaS (&aux a) nil) 2) (5 5))
|
||
|
||
(test-warn (lambdaS (arg) arg) (6 6))
|
||
(test-warn (funcallS (lambdaS (arg) arg) (Elist x)) (6 6))
|
||
|
||
(test-warn (funcallS #'(lambdaS (a) (car a))) (7 7))
|
||
(test-warn (funcallS #'(lambdaS (a) (car a)) x y) (7 7))
|
||
|
||
(test-warn (letS (((a b) (Elist x))) x) (8 8))
|
||
|
||
(test-warn (letS (a) a) (9 9))
|
||
(test-warn (letS ((a)) a) (9 9))
|
||
(test-warn (letS (((a b))) a) (9 9))
|
||
(test-warn (letS ((t 3)) a) (9 9))
|
||
(test-warn (letS ((((a)) 3)) a) (9 9))
|
||
(test-warn (letS (((t b) 3)) a) (9 9))
|
||
(test-warn (letS ((2 nil)) nil) (9 9))
|
||
(test-warn (letS ((a nil nil)) nil) (9 9))
|
||
|
||
(test-warn (letS ((a (Elist '(1 2)))) (declare (type oss a)) (Rlist a))
|
||
((1 2) 10))
|
||
|
||
(test-warn (letS ((e (Elist '(1 2 3)))) (Rlist (Elist '(1 2))))
|
||
((1 2) 11))
|
||
|
||
(test-warn
|
||
(lets ((a nil) (z (Elist x)) (b (Rlist (elist x)))) (setq a nil))
|
||
(12 12))
|
||
(test-warn
|
||
(lets ((a nil) (z (Elist x)) (b (Rlist (elist x)))) (setq z nil))
|
||
(12 12))
|
||
(test-warn
|
||
(lets ((a nil) (z (Elist x)) (b (Rlist (elist x)))) (setq b nil))
|
||
(12 12))
|
||
|
||
(test-warn (prognS (let ((z 2)) (Rlist (Elist '(a b z))))) ((a b z) 13))
|
||
|
||
(test-warn (Elist (Elist x)) (14 14))
|
||
(test-warn (letS ((e (Elist x)))
|
||
(Elist e)) (14 14))
|
||
|
||
(test-warn (block bar
|
||
(letS ((x (Eoss :R -1 2 3)))
|
||
(if (plusp x) (return-from bar x)))) (2 15))
|
||
(test-warn (compiler-let ((*permit-non-terminating-oss-expressions* T))
|
||
(block bar
|
||
(letS ((x (Eoss :R -1 2 3)))
|
||
(if (plusp x) (return-from bar x))))) (2 nil))
|
||
|
||
(test-warn (letS* ((e (Elist '(1 2)))
|
||
(w (Rlist e)))
|
||
(Rlist (cons e w))) (((1 1 2) (2 1 2)) 16))
|
||
(test-warn (letS* ((e (Elist '((1) (2))))
|
||
(w (Rlist e)))
|
||
(Rlist (cons (car e) w))) (((1 (1) (2)) (2 (1) (2))) 16))
|
||
(test-warn (letS* ((e (Elist '(1 2)))
|
||
(w (Rlist e))
|
||
(x (Rsum e)))
|
||
(list (Rlist (list e x))
|
||
(Rlist (list* e w))))
|
||
((((1 3) (2 3)) ((1 1 2) (2 1 2))) 16))
|
||
|
||
(test-warn (lets* ((e (Elist '(1 -2 -4 3)))
|
||
(w (TselectF #'plusp e)))
|
||
(Rlist (list e w))) (((1 1) (-2 3)) 17.1))
|
||
(test-warn (lets* ((e (Elist '(1 -2 -4 3)))
|
||
(w (TselectF #'plusp e)))
|
||
(Rlist (list e e w))) (((1 1 1) (-2 -2 3)) 17.1))
|
||
(test-warn (lets* ((e (Elist '(1 2))))
|
||
(Rlist (Tconcatenate e e))) ((1 2 1 2) 17.1))
|
||
(test-warn (lets* ((e (Elist '(1 2))))
|
||
(Rlist (list e (Tconcatenate e e)))) (((1 1) (2 2)) 17.1))
|
||
(test-warn (lets* ((e (Elist '(1 -2 -3 4))))
|
||
(Rlist (list e (Tconcatenate (TselectF #'plusp e)
|
||
(TselectF #'minusp e)))))
|
||
(((1 1) (-2 4) (-3 -2) (4 -3)) 17.1))
|
||
(test-warn (lets* ((e (Elist '(1 -2 -3 4)))
|
||
((w x) (TsplitF e #'plusp)))
|
||
(Rlist (list e (Tconcatenate w x))))
|
||
(((1 1) (-2 4) (-3 -2) (4 -3)) 17.1))
|
||
|
||
(test-warn (lets* ((e (Elist '(1 -2 3)))
|
||
(w (TsplitF e #'plusp)))
|
||
(Rlist (list e w))) (((1 1) (-2 3)) 17.2))
|
||
(test-warn (lets* ((e (Elist '(1 -2 3)))
|
||
(w (TsplitF e #'plusp)))
|
||
(Rlist (list e e w))) (((1 1 1) (-2 -2 3)) 17.2))
|
||
(test-warn (lets* ((e (Elist '(1 -2 -4 3)))
|
||
((w x) (TsplitF e #'plusp)))
|
||
(Rlist (list w x))) (((1 -2) (3 -4)) 17.2))
|
||
|
||
(test-warn (letS ((x (Elist '(1 2 3)))
|
||
(y (Elist '(4 5))))
|
||
(list (Rsum (+ x y)) (Rsum y)))
|
||
((12 9) 18))
|
||
(test-warn (letS ((x (Elist '(1 2 3)))
|
||
(y (Elist '(4 5))))
|
||
(list (Rsum (+ x y)) (Rsum y) (Rsum y)))
|
||
((12 9 9) 18))
|
||
(test-warn (lets* ((e (Elist '(1 -2 -4 3)))
|
||
((w x) (TsplitF e #'plusp)))
|
||
(list (Rlist (list e w))
|
||
(Rlist (list w x))))
|
||
((((1 1) (-2 3)) ((1 -2) (3 -4))) 18))
|
||
|
||
(test-warn (defunS gack (e)
|
||
(declare (type oss e))
|
||
(Elist (Rlist e))) (19 19))
|
||
|
||
(test-warn (prognS (flet ((a (b) (car b))) (a (elist x)))) (20 20))
|
||
|
||
(test-warn (lambda-primitiveS (arg) () () arg) (21 21))
|
||
(test-warn (funcallS (lambda-primitiveS (arg) () () arg) (Elist x))
|
||
(21 21))
|
||
|
||
(test-warn (prologS) (22.1 22.1))
|
||
(test-warn (progns (prologS (setq f 1)) (Rlist (Elist x))) (22.1 22.1))
|
||
(test-warn (epilogS) (22.2 22.2))
|
||
(test-warn (next-inS x) (22.3 22.3))
|
||
(test-warn (next-outS x) (22.4 22.4))
|
||
(test-warn (wrapS #'foo) (22.5 22.5))
|
||
(test-warn (alterableS x (car y)) (22.6 22.6))
|
||
|
||
(test-warn (funcallS #'(lambda-primitiveS ((a)) (b) (b) nil) 2)
|
||
(23.1 23.1))
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (c) (b) nil) 2)
|
||
(23.2 23.2))
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (3) (b) nil) 2)
|
||
(23.2 23.2))
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (b) (t) nil) 2)
|
||
(23.3 23.3))
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (b) (a) nil) 2)
|
||
(23.3 23.3))
|
||
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (a) ()
|
||
(next-inS b)) 2) (24 24))
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (a) ()
|
||
(next-inS a)) 2) (24 24))
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (a) ()
|
||
(declare (type oss a))
|
||
(next-inS a) (next-inS a)) 2) (24 24))
|
||
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (a) ()
|
||
(next-outS b)) 2) (25 25))
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (a) ()
|
||
(next-outS a)) 2) (25 25))
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (a) ()
|
||
(declare (type oss a))
|
||
(next-outS a) (next-outS a)) 2) (25 25))
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (a) ()
|
||
(declare (type oss a))
|
||
(next-outS a (go f))) 2) (25 25))
|
||
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (a) ()
|
||
(wrapS foo)) 2) (26 26))
|
||
|
||
(test-warn (funcallS #'(lambda-primitiveS (a) (a) ()
|
||
(alterableS b (car b))) 2) (27 27))
|
||
(test-warn (funcallS #'(lambda-primitiveS (c) (a) (a)
|
||
(alterableS a (car c))) 2) (27 27))
|
||
(test-warn (funcallS #'(lambda-primitiveS (c) (a) (a)
|
||
(alterableS a (car a) 3)) 2) (27 27))
|
||
|
||
;the following test tutorial mode
|
||
|
||
(test-tut (eval (read-from-string "(Rsum [1 2 3])")) 6)
|
||
(test-tut (not (null (string-equal (let ((*print-case* :downcase))
|
||
(with-output-to-string (f)
|
||
(prin1 (Elist '(a b c)) f)))
|
||
"[a b c]"))) T)
|
||
(test-tut (not (null (string-equal (let ((*print-case* :downcase))
|
||
(with-output-to-string (f)
|
||
(prin1 (Eup) f)))
|
||
"[0 1 2 3 4 5 6 7 8 9 10 ...]")))
|
||
T)
|
||
|
||
) test-failed nil)
|
||
|
||
;------------------------------------------------------------------------ ;
|
||
; Copyright (c) Richard C. Waters, 1988 ;
|
||
;------------------------------------------------------------------------ ;
|