Menu
▾
▴
clisp-cvs digest, Vol 1 #1132 - 2 msgs
|
From: <cli...@li...> - 2005-06-10 10:40:10
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/tests restarts.tst,NONE,1.1 conditions.tst,1.47,1.48 lists152.tst,1.14,1.15 tests.lisp,1.60,1.61 ChangeLog,1.378,1.379 (Bruno Haible) 2. clisp/tests bin-io.tst,1.5,1.6 clos.tst,1.90,1.91 encoding.tst,1.12,1.13 eval20.tst,1.11,1.12 excepsit.tst,1.39,1.40 iofkts.tst,1.33,1.34 macro8.tst,1.63,1.64 path.tst,1.56,1.57 streams.tst,1.35,1.36 streamslong.tst,1.17,1.18 type.tst,1.48,1.49 weakptr.tst,1.3,1.4 tests.lisp,1.61,1.62 (Bruno Haible) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/tests restarts.tst,NONE,1.1 conditions.tst,1.47,1.48 lists152.tst,1.14,1.15 tests.lisp,1.60,1.61 ChangeLog,1.378,1.379 Date: Fri, 10 Jun 2005 10:29:41 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17272/tests Modified Files: conditions.tst lists152.tst tests.lisp ChangeLog Added Files: restarts.tst Log Message: Move the tests for existing restarts to restarts.tst, since they apply only to CLISP. Index: tests.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/tests/tests.lisp,v retrieving revision 1.60 retrieving revision 1.61 diff -u -d -r1.60 -r1.61 --- tests.lisp 12 May 2005 20:36:09 -0000 1.60 +++ tests.lisp 10 Jun 2005 10:29:39 -0000 1.61 @@ -293,6 +293,9 @@ #+(or CLISP ALLEGRO CMU LISPWORKS) (with-accumulating-errors (error-count total-count) (run-test "conditions" :ignore-errors nil)) + #+CLISP + (with-accumulating-errors (error-count total-count) + (run-test "restarts" :ignore-errors nil)) (with-accumulating-errors (error-count total-count) (run-test "excepsit" :tester #'do-errcheck)) (format t "~&~s: grand total: ~:d error~:p out of ~:d test~:p~%" Index: lists152.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/lists152.tst,v retrieving revision 1.14 retrieving revision 1.15 diff -u -d -r1.14 -r1.15 --- lists152.tst 9 May 2005 10:43:34 -0000 1.14 +++ lists152.tst 10 Jun 2005 10:29:39 -0000 1.15 @@ -785,13 +785,6 @@ (butlast '#1=(1 2 3 . #1#) 3) ERROR -(handler-bind ((error (lambda (c) (princ c) (terpri) (use-value '(9 8 7 6))))) - (list (butlast 123 2) - (butlast '#1=(1 2 3 . #1#) 2) - (last 123 2) - (last '#1# 2))) -((9 8) (9 8) (7 6) (7 6)) - ;; <http://www.lisp.org/HyperSpec/Body/fun_revappendcm_nreconc.html> (let ((list-1 (list 1 2 3)) (list-2 (list 'a 'b 'c))) --- NEW FILE: restarts.tst --- ;; restarts (defmacro check-use-value (fun good bad &key (type 'type-error) (test 'eql)) `(handler-bind ((,type (lambda (c) (princ-error c) (use-value ',good)))) (,test (,fun ',good) (,fun ',bad)))) check-use-value (check-use-value char-code #\1 12 :test =) t (check-use-value symbol-name good "bad" :test string=) t (check-use-value intern "BAR" bar :test eq) t (check-use-value fboundp cons "CONS") t (check-use-value fdefinition cons "CONS") t (check-use-value string "123" 123) t (check-use-value (lambda (a) (aref a 2)) #(a b c d) 1) t (check-use-value (lambda (a) (setf (aref a 2) 'x)) #(a b c d) 1) t (check-use-value (lambda (a) (row-major-aref a 3)) #2A((a b) (c d)) 1) t (check-use-value (lambda (a) (setf (row-major-aref a 3) 'x)) #2A((a b) (c d)) 1) t (check-use-value array-element-type #*1001 1) t (check-use-value array-rank #(a b c d) 1) t (check-use-value (lambda (a) (array-dimension a 1)) #2A((a b) (c d)) 1) t (check-use-value array-dimensions #2A((a b) (c d)) 1 :test equal) t (check-use-value (lambda (a) (array-in-bounds-p a 1 2)) #2A((a b) (c d)) 1) t (check-use-value (lambda (a) (array-row-major-index a 2)) #(a b c d) 1) t (check-use-value (lambda (a) (array-row-major-index a 1 1)) #2A((a b) (c d)) 1) t (check-use-value adjustable-array-p #2A((a b) (c d)) 1) t (check-use-value (lambda (a) (bit a 2)) #*1011 1) t (check-use-value (lambda (a) (sbit a 2)) #*1011 1) t (check-use-value array-has-fill-pointer-p #2A((a b) (c d)) 1) t (let ((bs (make-broadcast-stream))) (handler-bind ((type-error (lambda (c) (princ-error c) (use-value bs)))) (broadcast-stream-streams 10))) NIL (handler-bind ((error (lambda (c) (princ-error c) (use-value #\#)))) (eq (get-dispatch-macro-character #\a #\() (get-dispatch-macro-character #\# #\())) T (with-output-to-string (o) (handler-bind ((type-error (lambda (c) (princ-error c) (use-value o)))) (princ "no error!" 123))) "no error!" (handler-bind ((type-error (lambda (c) (princ-error c) (use-value 16)))) (parse-integer "ABC" :radix 'lambda)) 2748 (with-input-from-string (s "bazonk") (handler-bind ((type-error (lambda (c) (princ-error c) (use-value s)))) (list (read-char 123) (read-char 1) (read-char 'read-char)))) (#\b #\a #\z) (handler-bind ((type-error (lambda (c) (princ-error c) (use-value (case (type-error-datum c) (1 *readtable*) (2 :upcase) (t (error "huh?"))))))) (setf (readtable-case 1) 2)) :UPCASE (handler-bind ((type-error (lambda (c) (princ-error c) (use-value (case (type-error-datum c) (1 #\#) (2 *readtable*) (t (error "huh?"))))))) (nth-value 1 (get-macro-character 1 2))) T (handler-bind ((type-error (lambda (c) (princ-error c) (use-value 7)))) (list (digit-char-p #\3 300) (digit-char-p #\8 'digit-char-p))) (3 NIL) (handler-bind ((type-error (lambda (c) (princ-error c) (use-value (char (type-error-datum c) 0))))) (list (char= "abc" "a") (char-equal "ABC" "a"))) (T T) (handler-bind ((type-error (lambda (c) (princ-error c) (use-value (string (type-error-datum c)))))) (ext:string-concat "foo-" 'bar "-baz")) "foo-BAR-baz" (handler-bind ((undefined-function (lambda (c) (princ-error c) (store-value (lambda (new-car pair) (setf (car pair) new-car)))))) (let ((a '(1 . 2))) (setf (zz a) 12) a)) (12 . 2) (fmakunbound '(setf zz)) (setf zz) (handler-bind ((undefined-function (lambda (c) (princ-error c) (store-value #'car)))) (zz '(1 . 2))) 1 (fmakunbound 'zz) zz (defun use-value-read (c) (princ-error c) (use-value (read-from-string (etypecase c (sys::source-program-error (sys::source-program-error-form c)) (type-error (type-error-datum c)) (cell-error (cell-error-name c)))))) use-value-read (let ((table (copy-readtable nil))) (and (eq :upcase (readtable-case table)) (setf (readtable-case table) :invert) (let ((copy (copy-readtable table))) (and (not (eq table copy)) (eq (readtable-case copy) :invert))))) T (handler-bind ((type-error #'use-value-read)) (setf (readtable-case (copy-readtable nil)) ":UPCASE")) :UPCASE (handler-bind ((error (lambda (c) (princ-error c) (use-value '+)))) (eval '(function "+"))) #.#'+ (handler-bind ((error #'use-value-read)) (funcall "+" 1 2 3)) 6 ;; progv (handler-bind ((type-error #'use-value-read)) (progv '("foo") '(123) foo)) 123 (handler-bind ((program-error (lambda (c) (princ-error c) (use-value 'zz)))) (progv '(:const-var) '(123) zz)) 123 (let ((form '(progv '("foo" :const) '(123 321) (+ foo zz)))) (handler-bind ((type-error #'use-value-read) (program-error (lambda (c) (princ-error c) (use-value 'zz)))) (list (eval form) form))) (444 (progv '("foo" :const) '(123 321) (+ foo zz))) (handler-bind ((type-error #'use-value-read)) (multiple-value-setq (a "foo") (values 123 321)) (list foo a)) (321 123) (handler-bind ((program-error (lambda (c) (princ-error c) (use-value 'zz)))) (setq :const-var 125) zz) 125 (handler-bind ((program-error (lambda (c) (princ-error c) (use-value '(zz 48))))) (let (("foo" 32)) zz)) 48 ;; This test reflects only the current CLISP behaviour: ;; - It can be argued that zz should be bound statically (since zz ;; is not declared special) or should be bound dynamically (since :const-var ;; would be bound dynamically and zz replaces just the symbol). ;; - It can be argued that later zz should be evaluated statically (because ;; that's what normal EVAL in the interpreter would do) or should be ;; evaluated to lookup (symbol-value 'zz) - since that's what the compiler ;; would make from the code. (handler-bind ((program-error (lambda (c) (princ-error c) (use-value 'zz)))) (let ((:const-var 64)) zz)) 64 ;; either TYPE-ERROR or SOURCE-PROGRAM-ERROR is reasonable here ;; (handler-bind ((source-program-error #'use-value-read) ;; (type-error #'use-value-read)) ;; ((lambda (x "y") (+ x y)) 1 3)) ;; 4 ;; (handler-bind ((source-program-error #'use-value-read) ;; (type-error #'use-value-read)) ;; ((lambda (x &optional ("y" 10)) (+ x y)) 1 3)) ;; 4 ;; (handler-bind ((source-program-error #'use-value-read) ;; (type-error #'use-value-read)) ;; ((lambda (x &key ("y" 10)) (+ x y)) 1 :y 3)) ;; 4 ;; (handler-bind ((source-program-error #'use-value-read) ;; (type-error #'use-value-read)) ;; ((lambda (x &aux ("y" 10)) (+ x y)) 1)) ;; 11 ;; (handler-bind ((source-program-error #'use-value-read) ;; (type-error #'use-value-read)) ;; (let ((f (lambda ("a" &optional "b" ("c" 1) &rest "d" ;; &key "e" ("f" 2) ("g" 3 "gp") (("hk" "ha") 4 "hp") ;; ("i" 5 "ip") ;; &aux ("j" 6)) ;; (list a b c '&rest d 'e e 'f f 'g g gp 'h ha hp 'i i ip 'j j)))) ;; (print f) ;; (funcall f 11 22 33 :e 44 :g 55 'hk 66))) ;; (11 22 33 &REST (:E 44 :G 55 HK 66) E 44 F 2 G 55 T H 66 T I 5 NIL J 6) (handler-bind ((type-error #'use-value-read) (source-program-error #'use-value-read)) (funcall "CAR" '(1 . 1))) 1 (handler-bind ((type-error #'use-value-read) (source-program-error #'use-value-read)) (setq "FOO" 1) (symbol-value 'foo)) 1 ;; make-hash-table (flet ((mht (test) (make-hash-table :test test))) (check-use-value mht eql bazonk :test equalp)) t (flet ((mht (w) (make-hash-table :weak w))) (check-use-value mht nil bazonk :test equalp)) t (flet ((mht (s) (make-hash-table :size s))) (check-use-value mht 10 bazonk :test equalp)) t (flet ((mht (rs) (make-hash-table :rehash-size rs))) (check-use-value mht 2d0 bazonk :test equalp)) t (flet ((mht (tr) (make-hash-table :rehash-threshold tr))) (check-use-value mht 5d-1 bazonk :test equalp)) t (handler-bind ((program-error (lambda (c) (princ-error c) (use-value '1+))) (type-error (lambda (c) (princ-error c) (use-value '1-)))) (list (eval '(1 10)) (funcall 1 100) (apply 1 '(1000)))) (11 99 999) (progn (makunbound 'bar) (handler-bind ((unbound-variable (lambda (c) (princ-error c) (store-value 41)))) (1+ bar))) 42 bar 41 (progn (defclass zot () (zot-foo)) (setq bar (make-instance 'zot)) (handler-bind ((unbound-slot (lambda (c) (princ-error c) (store-value 41)))) (1+ (slot-value bar 'zot-foo)))) 42 (slot-value bar 'zot-foo) 41 (progn (define-condition xyzzy () ((f1 :accessor my-f1 :initarg :f1-is)) (:report (lambda (c s) (format s "~1Txyzzy: My f1 is ~A" (my-f1 c))))) (princ-to-string (make-condition 'xyzzy :f1-is "a silly string"))) " xyzzy: My f1 is a silly string" ;; check all invocations of correctable-error in package.d (let* ((p1 (make-package "PACK-1" :use nil)) (p2 (make-package "PACK-2" :use nil)) (p3 (make-package "PACK-3" :use nil)) (p4 (make-package "PACK-4" :use nil)) (p5 (make-package "PACK-5" :use nil)) (bar-name (symbol-name (gensym "BAR-"))) (foo1 (intern "FOO" p1)) (foo2 (intern "FOO" p2)) (bar1 (intern bar-name p1)) (bar2 (intern bar-name p2)) (bar3 (intern bar-name p3)) (bar4 (intern bar-name p4)) (s12 (intern "SYM-1" p2)) (s22 (intern "SYM-2" p2)) (s13 (intern "SYM-1" p3)) (s23 (intern "SYM-2" p3)) (s14 (intern "SYM-1" p4)) (s24 (intern "SYM-2" p4)) (s15 (intern "SYM-1" p5)) (s25 (intern "SYM-2" p5))) (export (list s12 s22) p2) (export (list s13 s23) p3) (export (list s14 s24) p4) (handler-bind ((package-error (lambda (c) (princ-error c) (invoke-restart :pack-3)))) (use-package (list p2 p3 p4) p1)) (assert (null (set-exclusive-or (list p2 p3 p4) (package-use-list p1)))) (assert (eq (find-symbol "SYM-1" p1) s13)) (assert (eq (find-symbol "SYM-2" p1) s23)) (handler-bind ((package-error (lambda (c) (princ-error c) (invoke-restart 'import)))) (export s15 p1)) (assert (eq (find-symbol "SYM-1" p1) s15)) (handler-bind ((package-error (lambda (c) (princ-error c) (invoke-restart :pack-2)))) (export foo2 p2)) (assert (eq (find-symbol "FOO" p1) foo2)) (assert (null (set-exclusive-or (list bar1 bar2 bar3 bar4) (find-all-symbols bar-name)))) (handler-bind ((package-error (lambda (c) (princ-error c) (invoke-restart :pack-1)))) (export bar2 p2)) (assert (eq (find-symbol bar-name p1) bar1)) (export bar3 p3) (export bar4 p4) (handler-bind ((package-error (lambda (c) (princ-error c) (invoke-restart :pack-4)))) (unintern bar1 p1)) (assert (eq (find-symbol bar-name p1) bar4)) (delete-package p5) (handler-bind ((package-error (lambda (c) (princ-error c) (continue c)))) (delete-package p2) (delete-package p3) (delete-package p4)) (delete-package p1)) T (let ((p1 (make-package "PACK" :use nil)) p2 p3 p4 (bar-name (symbol-name (gensym "BAR-")))) (handler-bind ((package-error (lambda (c) (princ-error c) (invoke-restart 'continue)))) (assert (eq p1 (make-package "PACK")))) (handler-bind ((package-error (lambda (c) (princ-error c) (invoke-restart 'read "KCAP")))) (setq p2 (make-package "PACK"))) (assert (string= "KCAP" (package-name p2))) (handler-bind ((package-error (lambda (c) (princ-error c) (invoke-restart 'continue)))) (setq p3 (make-package "FOO" :nicknames (list "CL" bar-name "KCAP")))) (assert (equal (list bar-name) (package-nicknames p3))) (handler-bind ((package-error (lambda (c) (princ-error c) (invoke-restart 'read "ZOT")))) (setq p4 (make-package "QUUX" :nicknames (list "CL" bar-name "KCAP")))) (assert (equal (list "ZOT") (package-nicknames p4))) (delete-package p1) (delete-package p2) (delete-package p3) (delete-package p4)) T (handler-bind ((error (lambda (c) (princ c) (terpri) (use-value '(9 8 7 6))))) (list (butlast 123 2) (butlast '#1=(1 2 3 . #1#) 2) (last 123 2) (last '#1# 2))) ((9 8) (9 8) (7 6) (7 6)) Index: conditions.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/conditions.tst,v retrieving revision 1.47 retrieving revision 1.48 diff -u -d -r1.47 -r1.48 --- conditions.tst 12 May 2005 02:54:23 -0000 1.47 +++ conditions.tst 10 Jun 2005 10:29:39 -0000 1.48 @@ -468,234 +468,6 @@ (foo () 'good)) good -;; restarts -(defmacro check-use-value (fun good bad &key (type 'type-error) (test 'eql)) - `(handler-bind ((,type (lambda (c) (princ-error c) (use-value ',good)))) - (,test (,fun ',good) (,fun ',bad)))) -check-use-value - -(check-use-value char-code #\1 12 :test =) t -(check-use-value symbol-name good "bad" :test string=) t -(check-use-value intern "BAR" bar :test eq) t -(check-use-value fboundp cons "CONS") t -(check-use-value fdefinition cons "CONS") t -(check-use-value string "123" 123) t - -(check-use-value (lambda (a) (aref a 2)) #(a b c d) 1) t -(check-use-value (lambda (a) (setf (aref a 2) 'x)) #(a b c d) 1) t -(check-use-value (lambda (a) (row-major-aref a 3)) #2A((a b) (c d)) 1) t -(check-use-value (lambda (a) (setf (row-major-aref a 3) 'x)) #2A((a b) (c d)) 1) t -(check-use-value array-element-type #*1001 1) t -(check-use-value array-rank #(a b c d) 1) t -(check-use-value (lambda (a) (array-dimension a 1)) #2A((a b) (c d)) 1) t -(check-use-value array-dimensions #2A((a b) (c d)) 1 :test equal) t -(check-use-value (lambda (a) (array-in-bounds-p a 1 2)) #2A((a b) (c d)) 1) t -(check-use-value (lambda (a) (array-row-major-index a 2)) #(a b c d) 1) t -(check-use-value (lambda (a) (array-row-major-index a 1 1)) #2A((a b) (c d)) 1) t -(check-use-value adjustable-array-p #2A((a b) (c d)) 1) t -(check-use-value (lambda (a) (bit a 2)) #*1011 1) t -(check-use-value (lambda (a) (sbit a 2)) #*1011 1) t -(check-use-value array-has-fill-pointer-p #2A((a b) (c d)) 1) t - -(let ((bs (make-broadcast-stream))) - (handler-bind ((type-error (lambda (c) (princ-error c) (use-value bs)))) - (broadcast-stream-streams 10))) -NIL - -(handler-bind ((error (lambda (c) (princ-error c) (use-value #\#)))) - (eq (get-dispatch-macro-character #\a #\() - (get-dispatch-macro-character #\# #\())) -T - -(with-output-to-string (o) - (handler-bind ((type-error (lambda (c) (princ-error c) (use-value o)))) - (princ "no error!" 123))) -"no error!" - -(handler-bind ((type-error (lambda (c) (princ-error c) (use-value 16)))) - (parse-integer "ABC" :radix 'lambda)) -2748 - -(with-input-from-string (s "bazonk") - (handler-bind ((type-error (lambda (c) (princ-error c) (use-value s)))) - (list (read-char 123) (read-char 1) (read-char 'read-char)))) -(#\b #\a #\z) - -(handler-bind - ((type-error - (lambda (c) - (princ-error c) - (use-value - (case (type-error-datum c) - (1 *readtable*) - (2 :upcase) - (t (error "huh?"))))))) - (setf (readtable-case 1) 2)) -:UPCASE - -(handler-bind - ((type-error - (lambda (c) - (princ-error c) - (use-value - (case (type-error-datum c) - (1 #\#) - (2 *readtable*) - (t (error "huh?"))))))) - (nth-value 1 (get-macro-character 1 2))) -T - -(handler-bind ((type-error (lambda (c) (princ-error c) (use-value 7)))) - (list (digit-char-p #\3 300) - (digit-char-p #\8 'digit-char-p))) -(3 NIL) - -(handler-bind ((type-error - (lambda (c) - (princ-error c) - (use-value (char (type-error-datum c) 0))))) - (list (char= "abc" "a") - (char-equal "ABC" "a"))) -(T T) - -(handler-bind ((type-error - (lambda (c) - (princ-error c) - (use-value (string (type-error-datum c)))))) - (ext:string-concat "foo-" 'bar "-baz")) -"foo-BAR-baz" - -(handler-bind ((undefined-function - (lambda (c) (princ-error c) - (store-value - (lambda (new-car pair) - (setf (car pair) new-car)))))) - (let ((a '(1 . 2))) - (setf (zz a) 12) - a)) -(12 . 2) -(fmakunbound '(setf zz)) (setf zz) - -(handler-bind ((undefined-function - (lambda (c) (princ-error c) (store-value #'car)))) - (zz '(1 . 2))) -1 -(fmakunbound 'zz) zz - -(defun use-value-read (c) - (princ-error c) - (use-value (read-from-string - (etypecase c - (sys::source-program-error (sys::source-program-error-form c)) - (type-error (type-error-datum c)) - (cell-error (cell-error-name c)))))) -use-value-read - -(let ((table (copy-readtable nil))) - (and (eq :upcase (readtable-case table)) - (setf (readtable-case table) :invert) - (let ((copy (copy-readtable table))) - (and (not (eq table copy)) - (eq (readtable-case copy) :invert))))) -T - -(handler-bind ((type-error #'use-value-read)) - (setf (readtable-case (copy-readtable nil)) ":UPCASE")) -:UPCASE - -(handler-bind ((error (lambda (c) (princ-error c) (use-value '+)))) - (eval '(function "+"))) -#.#'+ - -(handler-bind ((error #'use-value-read)) - (funcall "+" 1 2 3)) -6 - -;; progv -(handler-bind ((type-error #'use-value-read)) - (progv '("foo") '(123) foo)) -123 - -(handler-bind ((program-error (lambda (c) (princ-error c) (use-value 'zz)))) - (progv '(:const-var) '(123) zz)) -123 - -(let ((form '(progv '("foo" :const) '(123 321) (+ foo zz)))) - (handler-bind ((type-error #'use-value-read) - (program-error (lambda (c) (princ-error c) (use-value 'zz)))) - (list (eval form) form))) -(444 (progv '("foo" :const) '(123 321) (+ foo zz))) - -(handler-bind ((type-error #'use-value-read)) - (multiple-value-setq (a "foo") (values 123 321)) - (list foo a)) -(321 123) - -(handler-bind ((program-error (lambda (c) (princ-error c) (use-value 'zz)))) - (setq :const-var 125) - zz) -125 - -(handler-bind ((program-error - (lambda (c) (princ-error c) (use-value '(zz 48))))) - (let (("foo" 32)) zz)) -48 - -;; This test reflects only the current CLISP behaviour: -;; - It can be argued that zz should be bound statically (since zz -;; is not declared special) or should be bound dynamically (since :const-var -;; would be bound dynamically and zz replaces just the symbol). -;; - It can be argued that later zz should be evaluated statically (because -;; that's what normal EVAL in the interpreter would do) or should be -;; evaluated to lookup (symbol-value 'zz) - since that's what the compiler -;; would make from the code. -(handler-bind ((program-error (lambda (c) (princ-error c) (use-value 'zz)))) - (let ((:const-var 64)) zz)) -64 - -;; either TYPE-ERROR or SOURCE-PROGRAM-ERROR is reasonable here -;; (handler-bind ((source-program-error #'use-value-read) -;; (type-error #'use-value-read)) -;; ((lambda (x "y") (+ x y)) 1 3)) -;; 4 - -;; (handler-bind ((source-program-error #'use-value-read) -;; (type-error #'use-value-read)) -;; ((lambda (x &optional ("y" 10)) (+ x y)) 1 3)) -;; 4 - -;; (handler-bind ((source-program-error #'use-value-read) -;; (type-error #'use-value-read)) -;; ((lambda (x &key ("y" 10)) (+ x y)) 1 :y 3)) -;; 4 - -;; (handler-bind ((source-program-error #'use-value-read) -;; (type-error #'use-value-read)) -;; ((lambda (x &aux ("y" 10)) (+ x y)) 1)) -;; 11 - -;; (handler-bind ((source-program-error #'use-value-read) -;; (type-error #'use-value-read)) -;; (let ((f (lambda ("a" &optional "b" ("c" 1) &rest "d" -;; &key "e" ("f" 2) ("g" 3 "gp") (("hk" "ha") 4 "hp") -;; ("i" 5 "ip") -;; &aux ("j" 6)) -;; (list a b c '&rest d 'e e 'f f 'g g gp 'h ha hp 'i i ip 'j j)))) -;; (print f) -;; (funcall f 11 22 33 :e 44 :g 55 'hk 66))) -;; (11 22 33 &REST (:E 44 :G 55 HK 66) E 44 F 2 G 55 T H 66 T I 5 NIL J 6) - -(handler-bind ((type-error #'use-value-read) - (source-program-error #'use-value-read)) - (funcall "CAR" '(1 . 1))) -1 - -(handler-bind ((type-error #'use-value-read) - (source-program-error #'use-value-read)) - (setq "FOO" 1) - (symbol-value 'foo)) -1 - (block nil (handler-bind ((type-error (lambda (c) (return (list (type-error-expected-type c) @@ -710,49 +482,6 @@ (coerce '(1 2 3) '(integer 1)))) ((INTEGER 1) (1 2 3)) -;; make-hash-table -(flet ((mht (test) (make-hash-table :test test))) - (check-use-value mht eql bazonk :test equalp)) t -(flet ((mht (w) (make-hash-table :weak w))) - (check-use-value mht nil bazonk :test equalp)) t -(flet ((mht (s) (make-hash-table :size s))) - (check-use-value mht 10 bazonk :test equalp)) t -(flet ((mht (rs) (make-hash-table :rehash-size rs))) - (check-use-value mht 2d0 bazonk :test equalp)) t -(flet ((mht (tr) (make-hash-table :rehash-threshold tr))) - (check-use-value mht 5d-1 bazonk :test equalp)) t - -(handler-bind ((program-error (lambda (c) (princ-error c) (use-value '1+))) - (type-error (lambda (c) (princ-error c) (use-value '1-)))) - (list (eval '(1 10)) (funcall 1 100) (apply 1 '(1000)))) -(11 99 999) - -(progn (makunbound 'bar) -(handler-bind ((unbound-variable - (lambda (c) (princ-error c) (store-value 41)))) - (1+ bar))) -42 - -bar 41 - -(progn - (defclass zot () (zot-foo)) - (setq bar (make-instance 'zot)) - (handler-bind ((unbound-slot - (lambda (c) (princ-error c) (store-value 41)))) - (1+ (slot-value bar 'zot-foo)))) -42 - -(slot-value bar 'zot-foo) 41 - -(progn - (define-condition xyzzy () - ((f1 :accessor my-f1 :initarg :f1-is)) - (:report (lambda (c s) - (format s "~1Txyzzy: My f1 is ~A" (my-f1 c))))) - (princ-to-string (make-condition 'xyzzy :f1-is "a silly string"))) -" xyzzy: My f1 is a silly string" - ;; Check that after a Ctrl-D (EOF), assert without places is not retried. (let ((done nil)) (block test @@ -768,76 +497,6 @@ (assert (= 1 2)))))))) nil -;; check all invocations of correctable-error in package.d -(let* ((p1 (make-package "PACK-1" :use nil)) - (p2 (make-package "PACK-2" :use nil)) - (p3 (make-package "PACK-3" :use nil)) - (p4 (make-package "PACK-4" :use nil)) - (p5 (make-package "PACK-5" :use nil)) - (bar-name (symbol-name (gensym "BAR-"))) - (foo1 (intern "FOO" p1)) (foo2 (intern "FOO" p2)) - (bar1 (intern bar-name p1)) (bar2 (intern bar-name p2)) - (bar3 (intern bar-name p3)) (bar4 (intern bar-name p4)) - (s12 (intern "SYM-1" p2)) (s22 (intern "SYM-2" p2)) - (s13 (intern "SYM-1" p3)) (s23 (intern "SYM-2" p3)) - (s14 (intern "SYM-1" p4)) (s24 (intern "SYM-2" p4)) - (s15 (intern "SYM-1" p5)) (s25 (intern "SYM-2" p5))) - (export (list s12 s22) p2) - (export (list s13 s23) p3) - (export (list s14 s24) p4) - (handler-bind ((package-error - (lambda (c) (princ-error c) (invoke-restart :pack-3)))) - (use-package (list p2 p3 p4) p1)) - (assert (null (set-exclusive-or (list p2 p3 p4) (package-use-list p1)))) - (assert (eq (find-symbol "SYM-1" p1) s13)) - (assert (eq (find-symbol "SYM-2" p1) s23)) - (handler-bind ((package-error - (lambda (c) (princ-error c) (invoke-restart 'import)))) - (export s15 p1)) - (assert (eq (find-symbol "SYM-1" p1) s15)) - (handler-bind ((package-error - (lambda (c) (princ-error c) (invoke-restart :pack-2)))) - (export foo2 p2)) - (assert (eq (find-symbol "FOO" p1) foo2)) - (assert (null (set-exclusive-or (list bar1 bar2 bar3 bar4) - (find-all-symbols bar-name)))) - (handler-bind ((package-error - (lambda (c) (princ-error c) (invoke-restart :pack-1)))) - (export bar2 p2)) - (assert (eq (find-symbol bar-name p1) bar1)) - (export bar3 p3) - (export bar4 p4) - (handler-bind ((package-error - (lambda (c) (princ-error c) (invoke-restart :pack-4)))) - (unintern bar1 p1)) - (assert (eq (find-symbol bar-name p1) bar4)) - (delete-package p5) - (handler-bind ((package-error (lambda (c) (princ-error c) (continue c)))) - (delete-package p2) (delete-package p3) (delete-package p4)) - (delete-package p1)) -T - -(let ((p1 (make-package "PACK" :use nil)) p2 p3 p4 - (bar-name (symbol-name (gensym "BAR-")))) - (handler-bind ((package-error - (lambda (c) (princ-error c) (invoke-restart 'continue)))) - (assert (eq p1 (make-package "PACK")))) - (handler-bind ((package-error - (lambda (c) (princ-error c) (invoke-restart 'read "KCAP")))) - (setq p2 (make-package "PACK"))) - (assert (string= "KCAP" (package-name p2))) - (handler-bind ((package-error - (lambda (c) (princ-error c) (invoke-restart 'continue)))) - (setq p3 (make-package "FOO" :nicknames (list "CL" bar-name "KCAP")))) - (assert (equal (list bar-name) (package-nicknames p3))) - (handler-bind ((package-error - (lambda (c) (princ-error c) (invoke-restart 'read "ZOT")))) - (setq p4 (make-package "QUUX" :nicknames (list "CL" bar-name "KCAP")))) - (assert (equal (list "ZOT") (package-nicknames p4))) - (delete-package p1) (delete-package p2) - (delete-package p3) (delete-package p4)) -T - (block nil (handler-bind ((unbound-variable (lambda (c) (princ-error c) (return :good)))) (let ((foo (gensym "UNBOUND-"))) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.378 retrieving revision 1.379 diff -u -d -r1.378 -r1.379 --- ChangeLog 8 Jun 2005 16:18:30 -0000 1.378 +++ ChangeLog 10 Jun 2005 10:29:39 -0000 1.379 @@ -1,3 +1,11 @@ +2005-06-09 Bruno Haible <br...@cl...> + + Move lots of CLISP-only tests to a separate file. + * conditions.tst: Move restart tests out to restarts.tst. + * lists152.tst: Likewise. + * restarts.tst: New file. + + tests.lisp (run-all-tests): Run it after conditions.tst. + 2005-06-08 Sam Steingold <sd...@gn...> * bind.tst: 5 more tests --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/tests bin-io.tst,1.5,1.6 clos.tst,1.90,1.91 encoding.tst,1.12,1.13 eval20.tst,1.11,1.12 excepsit.tst,1.39,1.40 iofkts.tst,1.33,1.34 macro8.tst,1.63,1.64 path.tst,1.56,1.57 streams.tst,1.35,1.36 streamslong.tst,1.17,1.18 type.tst,1.48,1.49 weakptr.tst,1.3,1.4 tests.lisp,1.61,1.62 Date: Fri, 10 Jun 2005 10:36:30 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20511 Modified Files: bin-io.tst clos.tst encoding.tst eval20.tst excepsit.tst iofkts.tst macro8.tst path.tst streams.tst streamslong.tst type.tst weakptr.tst tests.lisp Log Message: Support for cmucl-19b-pre1. Index: tests.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/tests/tests.lisp,v retrieving revision 1.61 retrieving revision 1.62 diff -u -d -r1.61 -r1.62 --- tests.lisp 10 Jun 2005 10:29:39 -0000 1.61 +++ tests.lisp 10 Jun 2005 10:36:28 -0000 1.62 @@ -184,7 +184,7 @@ (with-open-file (s (merge-extension "tst" testname) :direction :input) (format t "~&~s: started ~s~%" 'run-test s) (with-open-file (log logfile :direction :output - #+SBCL :if-exists #+SBCL :supersede + #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede #+ANSI-CL :if-exists #+ANSI-CL :new-version) (let ((*package* *package*) (*print-circle* t) (*print-pretty* nil)) (setf (values total-count error-count) @@ -262,7 +262,7 @@ #+(or CLISP GCL ALLEGRO CMU SBCL OpenMCL LISPWORKS) "loop" "macro8" "map" - #+(or CLISP ALLEGRO CMU OpenMCL LISPWORKS) "mop" + #+(or CLISP ALLEGRO OpenMCL LISPWORKS) "mop" "number" #+CLISP "number2" #-(or AKCL ALLEGRO CMU OpenMCL) "pack11" Index: path.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/path.tst,v retrieving revision 1.56 retrieving revision 1.57 diff -u -d -r1.56 -r1.57 --- path.tst 7 Jun 2005 11:03:41 -0000 1.56 +++ path.tst 10 Jun 2005 10:36:28 -0000 1.57 @@ -33,7 +33,7 @@ #S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY NIL :NAME "test-pathname" :TYPE "abc" :VERSION NIL) -(SETF STREAM (OPEN STRING :DIRECTION :OUTPUT #+SBCL :IF-EXISTS #+SBCL :SUPERSEDE) +(SETF STREAM (OPEN STRING :DIRECTION :OUTPUT #+(or CMU SBCL) :IF-EXISTS #+(or CMU SBCL) :SUPERSEDE) a nil) nil @@ -808,7 +808,7 @@ (let* ((old "foo-bar.old") (new (make-pathname :type "new" :defaults old))) - (with-open-file (s old :direction :output #+SBCL :if-exists #+SBCL :supersede) (write-line "to be renamed" s)) + (with-open-file (s old :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (write-line "to be renamed" s)) (unwind-protect (list (list (not (not (probe-file old))) (probe-file new)) (length (multiple-value-list (rename-file old new))) Index: eval20.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/eval20.tst,v retrieving revision 1.11 retrieving revision 1.12 diff -u -d -r1.11 -r1.12 --- eval20.tst 24 Jan 2005 10:36:15 -0000 1.11 +++ eval20.tst 10 Jun 2005 10:36:28 -0000 1.12 @@ -20,7 +20,7 @@ ;; eval-when (let ((ff "eval-when-test.lisp")) - (with-open-file (foo ff :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (foo ff :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (format foo "~%(eval-when (compile eval) ;; note that LAMBDA is not externalizable (defvar *junk* #.(lambda (x) (+ 15 x))))~%")) @@ -46,7 +46,7 @@ (push `(let () (eval-when (,@c ,@l ,@x) (push '(let ,@c ,@l ,@x) *collector*))) forms)))) - (with-open-file (o ff :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (o ff :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (dolist (f forms) (prin1 f o) (terpri o))) @@ -119,7 +119,7 @@ ;; <http://www.lisp.org/HyperSpec/Issues/iss146-writeup.html> (let ((src "foo.lisp") (zz (cons 1 2))) (defun setf-foo (u v) (setf (car u) v)) - (with-open-file (s src :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (s src :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (format s "(progn~% (defsetf foo setf-foo) (defun bar (u v) (setf (foo u) v)))~%")) (load src #+CLISP :compiling #+CLISP t) Index: streamslong.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/streamslong.tst,v retrieving revision 1.17 retrieving revision 1.18 diff -u -d -r1.17 -r1.18 --- streamslong.tst 9 May 2005 10:43:35 -0000 1.17 +++ streamslong.tst 10 Jun 2005 10:36:28 -0000 1.18 @@ -21,7 +21,7 @@ (ash 1 (1- size)))) (loop :repeat num-bytes :collect (random (ash 1 size)))))) - (with-open-file (foo file-name :direction :output #+SBCL :if-exists #+SBCL :supersede + (with-open-file (foo file-name :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede :element-type (list type size)) (dolist (byte bytes) (write-byte byte foo))) @@ -51,7 +51,7 @@ (unwind-protect (progn (with-open-file (s "test.bin" :element-type '(unsigned-byte 8) - :direction :output #+SBCL :if-exists #+SBCL :supersede + :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede :if-exists :error) (notice (file-position s)) ;1 (write-byte 5 s) Index: bin-io.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/bin-io.tst,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- bin-io.tst 9 May 2005 10:44:44 -0000 1.5 +++ bin-io.tst 10 Jun 2005 10:36:28 -0000 1.6 @@ -22,7 +22,7 @@ (random 1d0)))) (let ((eltype (list type size))) (with-open-file (foo file-name :direction :output - #+SBCL :if-exists #+SBCL :supersede + #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede :element-type 'unsigned-byte) (dolist (num int-list) (write-integer num foo eltype endianness)) @@ -54,7 +54,7 @@ (let ((vec (make-array 8 :element-type '(unsigned-byte 8) :initial-contents '(#x3f #xf0 0 0 0 0 0 0)))) (with-open-file (foo "./foocl" :direction :output - #+SBCL :if-exists #+SBCL :supersede + #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede :element-type '(unsigned-byte 8)) (write-sequence vec foo)) (unwind-protect Index: streams.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/streams.tst,v retrieving revision 1.35 retrieving revision 1.36 diff -u -d -r1.35 -r1.36 --- streams.tst 13 May 2005 15:11:58 -0000 1.35 +++ streams.tst 10 Jun 2005 10:36:28 -0000 1.36 @@ -32,9 +32,9 @@ (close s)) close-1 -(PROGN (SETQ S1 (OPEN "d1.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) -(SETQ S2 (OPEN "d2.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) -(SETQ S3 (OPEN "d3.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) +(PROGN (SETQ S1 (OPEN "d1.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) +(SETQ S2 (OPEN "d2.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) +(SETQ S3 (OPEN "d3.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) (SETQ B1 (MAKE-BROADCAST-STREAM S1 S2 S3 *STANDARD-OUTPUT*)) T) T (PRINT "test broadcast satz 1" B1) "test broadcast satz 1" @@ -79,7 +79,7 @@ (CLOSE-1 S) T -(PROGN (SETQ S (OPEN "t0.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) T) T +(PROGN (SETQ S (OPEN "t0.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) T) T (PRINT (QUOTE READ1) S) READ1 @@ -88,17 +88,17 @@ (CLOSE-1 S) T (PROGN (SETQ INPTW (OPEN "t0.plc")) -(SETQ S1 (OPEN "d1.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) -(SETQ S2 (OPEN "d2.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) +(SETQ S1 (OPEN "d1.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) +(SETQ S2 (OPEN "d2.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) (SETQ SY (MAKE-SYNONYM-STREAM (QUOTE S2))) -(SETQ S3 (OPEN "d3.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) +(SETQ S3 (OPEN "d3.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) (SETQ TW (MAKE-TWO-WAY-STREAM INPTW S3)) -(SETQ S4 (OPEN "d4.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) +(SETQ S4 (OPEN "d4.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) (SETQ EC (MAKE-ECHO-STREAM INPTW S4)) -(SETQ S5 (OPEN "d5.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) -(SETQ S6 (OPEN "d6.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) +(SETQ S5 (OPEN "d5.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) +(SETQ S6 (OPEN "d6.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) (SETQ B1 (MAKE-BROADCAST-STREAM S5 S6)) -(SETQ S7 (OPEN "d7.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) +(SETQ S7 (OPEN "d7.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) (SETQ B2 (MAKE-BROADCAST-STREAM S1 SY TW EC B1 S7)) T) T (PRINT "w to b2 1.satz" B2) "w to b2 1.satz" @@ -301,7 +301,7 @@ (CLOSE-1 S) T -(PROGN (SETQ S (OPEN "t1.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) T) T +(PROGN (SETQ S (OPEN "t1.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) T) T (PRINT "1.satz t1" S) "1.satz t1" @@ -309,7 +309,7 @@ (CLOSE-1 S) T -(PROGN (SETQ S (OPEN "t2.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) T) T +(PROGN (SETQ S (OPEN "t2.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) T) T (PRINT "1.satz t2" S) "1.satz t2" @@ -317,7 +317,7 @@ (CLOSE-1 S) T -(PROGN (SETQ S (OPEN "t3.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) T) T +(PROGN (SETQ S (OPEN "t3.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) T) T (PRINT "1.satz t3" S) "1.satz t3" @@ -325,7 +325,7 @@ (CLOSE-1 S) T -(PROGN (SETQ S (OPEN "t4.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) T) T +(PROGN (SETQ S (OPEN "t4.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) T) T (PRINT "1.satz t4" S) "1.satz t4" @@ -333,7 +333,7 @@ (CLOSE-1 S) T -(PROGN (SETQ S (OPEN "t5.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) T) T +(PROGN (SETQ S (OPEN "t5.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) T) T (PRINT "1.satz t5" S) "1.satz t5" @@ -341,7 +341,7 @@ (CLOSE-1 S) T -(PROGN (SETQ S (OPEN "t6.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) T) T +(PROGN (SETQ S (OPEN "t6.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) T) T (PRINT "1.satz t6" S) "1.satz t6" @@ -349,7 +349,7 @@ (CLOSE-1 S) T -(PROGN (SETQ S (OPEN "t7.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) T) T +(PROGN (SETQ S (OPEN "t7.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) T) T (PRINT "1.satz t7" S) "1.satz t7" @@ -357,7 +357,7 @@ (CLOSE-1 S) T -(PROGN (SETQ S (OPEN "t8.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) T) T +(PROGN (SETQ S (OPEN "t8.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) T) T (PRINT "1.satz t8" S) "1.satz t8" @@ -365,7 +365,7 @@ (CLOSE-1 S) T -(PROGN (SETQ S (OPEN "t9.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) T) T +(PROGN (SETQ S (OPEN "t9.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) T) T (PRINT "1.satz t9" S) "1.satz t9" @@ -373,7 +373,7 @@ (CLOSE-1 S) T -(PROGN (SETQ S (OPEN "t10.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) T) T +(PROGN (SETQ S (OPEN "t10.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) T) T (PRINT "1.satz t10" S) "1.satz t10" @@ -670,9 +670,9 @@ (LENGTH (PRINC (GET-OUTPUT-STREAM-STRING OS))) 496 -(PROGN (SETQ OS (OPEN "d0.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) -(SETQ OS1 (OPEN "d1.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) -(SETQ IS (OPEN "t0.plc" :DIRECTION :OUTPUT #+(or SBCL LISPWORKS) :IF-EXISTS #+(or SBCL LISPWORKS) :SUPERSEDE)) T) T +(PROGN (SETQ OS (OPEN "d0.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) +(SETQ OS1 (OPEN "d1.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) +(SETQ IS (OPEN "t0.plc" :DIRECTION :OUTPUT #+(or CMU SBCL LISPWORKS) :IF-EXISTS #+(or CMU SBCL LISPWORKS) :SUPERSEDE)) T) T (PRINC "'(a b #.(print \"1.zwischenwert\" os1) c d)" IS) "'(a b #.(print \"1.zwischenwert\" os1) c d)" @@ -956,7 +956,7 @@ (let ((f "foo.bar") fwd1 fwd2) (unwind-protect (progn ; FILE-WRITE-DATE should work on :PROBE streams - (with-open-file (s f :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (s f :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (write f :stream s) (setq fwd1 (file-write-date s))) (with-open-file (s f :direction :probe) @@ -1008,7 +1008,7 @@ (file-string-length (make-broadcast-stream) "foo") 1 (stream-element-type (make-broadcast-stream)) T -(let ((o (open "foo.bin" :direction :output #+(or SBCL LISPWORKS) :if-exists #+(or SBCL LISPWORKS) :supersede :element-type '(unsigned-byte 8))) +(let ((o (open "foo.bin" :direction :output #+(or CMU SBCL LISPWORKS) :if-exists #+(or CMU SBCL LISPWORKS) :supersede :element-type '(unsigned-byte 8))) (i (make-string-input-stream "foo"))) (unwind-protect (stream-element-type (make-two-way-stream i o)) (close o) (delete-file o) Index: encoding.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/encoding.tst,v retrieving revision 1.12 retrieving revision 1.13 diff -u -d -r1.12 -r1.13 --- encoding.tst 9 May 2005 10:44:44 -0000 1.12 +++ encoding.tst 10 Jun 2005 10:36:28 -0000 1.13 @@ -1,6 +1,6 @@ ;; -*- Lisp -*- -;;(with-open-file (f "ucs" :direction :output #+SBCL :if-exists #+SBCL :supersede :element-type '(unsigned-byte 8)) +;;(with-open-file (f "ucs" :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede :element-type '(unsigned-byte 8)) ;; (write-byte-sequence #(0 65 0) f)) ;; <http://sourceforge.net/tracker/index.php?func=detail&aid=543072&group_id=1355&atid=101355> Index: weakptr.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/weakptr.tst,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- weakptr.tst 4 Apr 2005 16:28:59 -0000 1.3 +++ weakptr.tst 10 Jun 2005 10:36:28 -0000 1.4 @@ -71,8 +71,10 @@ (let ((*print-circle* t)) (setf (weak-pointer-value wp) wpp) (prin1-to-string wp)) +#+CLISP "#1=#<WEAK-POINTER #<WEAK-POINTER #1#>>" +#+CMU "#1=#<Weak Pointer: #<Weak Pointer: #1#>>" #+LISPWORKS "#1=#(#(#1#))" -#-LISPWORKS "#1=#<WEAK-POINTER #<WEAK-POINTER #1#>>" +#-(or CLISP CMU LISPWORKS) UNKNOWN (progn (makunbound 'co) (makunbound 'wp) (makunbound 'wpp) (gc) (fmakunbound 'weakptr-test)) Index: macro8.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/macro8.tst,v retrieving revision 1.63 retrieving revision 1.64 diff -u -d -r1.63 -r1.64 --- macro8.tst 25 May 2005 17:14:12 -0000 1.63 +++ macro8.tst 10 Jun 2005 10:36:28 -0000 1.64 @@ -246,7 +246,7 @@ ;; the bug was fixed by bruno in compiler.lisp 1.80 (progn (defun stem (&key (obj (error "missing OBJ"))) - (with-open-file (stream obj :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (stream obj :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (truename stream))) (compile 'stem) (delete-file (stem :obj "foo-bar-zot")) @@ -587,7 +587,7 @@ (12 22) (let ((file "tmp.lisp")) - (with-open-file (o file :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (o file :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (write-line "(defun caller (a b) (foo a b))" o) (write-line "(defun foo (a b c) (list a b c))" o)) (unwind-protect @@ -598,10 +598,10 @@ (1 2 3) (let ((file1 "tmp1.lisp") (file2 "tmp2.lisp")) - (with-open-file (o file1 :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (o file1 :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (write-line "(defun foo (a b c) (cons b c a))" o) (format o "(load ~S)~%" file2)) - (with-open-file (o file2 :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (o file2 :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (write-line "(defun bar (a b) (sin (1+ a) (1- b a)))" o)) (unwind-protect (progn @@ -636,7 +636,7 @@ ;; <http://article.gmane.org/gmane.lisp.clisp.devel/10566> (let ((file "tmp.lisp")) - (with-open-file (out file :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (out file :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (write '(eval-when (load compile eval) (+ (funcall (compile nil (lambda () (load-time-value (+ 2 3))))) 120)) @@ -651,7 +651,7 @@ ;; compile-file is allowed to collapse different occurrences of the same ;; LOAD-TIME-VALUE form, and in fact, CLISP does so. (let ((file "tmp.lisp")) - (with-open-file (out file :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (out file :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (write-string "(defun ltv1 () (eq #1=(load-time-value (cons nil nil)) #1#))" out)) (unwind-protect (progn (compile-file file) (load (compile-file-pathname file))) @@ -665,7 +665,7 @@ ;; compile-file is not allowed to collapse different LOAD-TIME-VALUE forms ;; even if the inner form is the same. (let ((file "tmp.lisp")) - (with-open-file (out file :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (out file :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (write-string "(defun ltv2 () (eq (load-time-value #1=(cons nil nil)) (load-time-value #1#)))" out)) (unwind-protect (progn (compile-file file) (load (compile-file-pathname file))) @@ -677,7 +677,7 @@ ;; compile-file is not allowed to collapse different LOAD-TIME-VALUE forms. (let ((file "tmp.lisp")) - (with-open-file (out file :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (out file :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (write-string "(defun ltv3 () (eq (load-time-value (cons nil nil)) (load-time-value (cons nil nil))))" out)) (unwind-protect (progn (compile-file file) (load (compile-file-pathname file))) @@ -879,8 +879,10 @@ ;; <http://article.gmane.org/gmane.lisp.clisp.devel/10566> (let ((fname "donc.lisp") (results '()) compiled) - (with-open-file (out fname :direction :output :if-exists :overwrite - :if-does-not-exist :create) + (with-open-file (out fname :direction :output + #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede + :if-exists :overwrite + :if-does-not-exist :create) (write '(defparameter *donc* nil) :stream out) (terpri out) (write '(eval-when (:load-toplevel :compile-toplevel :execute) @@ -902,8 +904,10 @@ ;; <http://article.gmane.org/gmane.lisp.clisp.devel/13127> (let ((fname "donc.lisp") (results '()) compiled) - (with-open-file (out fname :direction :output :if-exists :overwrite - :if-does-not-exist :create) + (with-open-file (out fname :direction :output + #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede + :if-exists :overwrite + :if-does-not-exist :create) (write '(defmacro m1 (x) (compile x (lambda nil (load-time-value (+ 2 3)))) 4) :stream out) Index: excepsit.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/excepsit.tst,v retrieving revision 1.39 retrieving revision 1.40 diff -u -d -r1.39 -r1.40 --- excepsit.tst 25 May 2005 14:14:15 -0000 1.39 +++ excepsit.tst 10 Jun 2005 10:36:28 -0000 1.40 @@ -405,7 +405,7 @@ ;; into pathname.d. #-BeOS (progn - (with-open-file (s "./foo35.tmp" :direction :output #+SBCL :if-exists #+SBCL :supersede)) + (with-open-file (s "./foo35.tmp" :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede)) (delete-file "./foo35.tmp/bar")) #-BeOS file-error @@ -476,11 +476,11 @@ (file-length *terminal-io*) type-error -(with-open-file (s "./foo35.tmp" :direction :output #+SBCL :if-exists #+SBCL :supersede) +(with-open-file (s "./foo35.tmp" :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (file-position s 0.0)) error -(with-open-file (s "./foo35.tmp" :direction :output #+SBCL :if-exists #+SBCL :supersede) +(with-open-file (s "./foo35.tmp" :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (file-position s -1)) error @@ -943,7 +943,7 @@ error (let ((filename "./foo51.bin")) - (with-open-file (s filename :direction :output #+SBCL :if-exists #+SBCL :supersede + (with-open-file (s filename :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede :if-exists :overwrite :if-does-not-exist :create)) (with-open-file (s filename :direction :input @@ -954,7 +954,7 @@ null (let ((filename "./foo52.txt")) - (with-open-file (s filename :direction :output #+SBCL :if-exists #+SBCL :supersede + (with-open-file (s filename :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede :if-exists :overwrite :if-does-not-exist :create)) (with-open-file (s filename :direction :input) @@ -964,7 +964,7 @@ null (let ((filename "./foo53.txt")) - (with-open-file (s filename :direction :output #+SBCL :if-exists #+SBCL :supersede + (with-open-file (s filename :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede :if-exists :overwrite :if-does-not-exist :create)) (with-open-file (s filename :direction :input) Index: iofkts.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/iofkts.tst,v retrieving revision 1.33 retrieving revision 1.34 diff -u -d -r1.33 -r1.34 --- iofkts.tst 9 May 2005 10:43:34 -0000 1.33 +++ iofkts.tst 10 Jun 2005 10:36:28 -0000 1.34 @@ -549,8 +549,8 @@ #-(or XCL CLISP AKCL ECL ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN J -#+XCL 20 #+(or CLISP AKCL ECL ALLEGRO SBCL OpenMCL LISPWORKS) 7 -#-(or XCL CLISP AKCL ECL ALLEGRO SBCL OpenMCL LISPWORKS) UNKNOWN +#+XCL 20 #+(or CLISP AKCL ECL ALLEGRO SBCL OpenMCL LISPWORKS) 7 #+CMU 16 +#-(or XCL CLISP AKCL ECL ALLEGRO CMU SBCL OpenMCL LISPWORKS) UNKNOWN (SETQ A "Das ist wieder einmal einer der SUUPERTESTstrings.") "Das ist wieder einmal einer der SUUPERTESTstrings." @@ -774,8 +774,14 @@ (pprint-logical-block (out nil :prefix "#[" :suffix "]") (let ((cl (class-of obj))) (write (class-name cl) :stream out) - (loop :for slotdef :in (#+(or GCL OpenMCL) class-slots #-(or GCL OpenMCL) clos:class-slots cl) - :for slot = (#+(or GCL OpenMCL) slot-definition-name #-(or GCL OpenMCL) clos:slot-definition-name slotdef) + (loop :for slotdef :in (#+(or GCL OpenMCL) class-slots + #+SBCL sb-mop:class-slots + #+CMU mop:class-slots + #-(or GCL OpenMCL SBCL CMU) clos:class-slots cl) + :for slot = (#+(or GCL OpenMCL) slot-definition-name + #+SBCL sb-mop:slot-definition-name + #+CMU mop:slot-definition-name + #-(or GCL OpenMCL SBCL CMU) clos:slot-definition-name slotdef) :when (and slot (slot-boundp obj slot)) :do (write-char #\space out) (pprint-newline :fill out) (write slot :stream out) @@ -797,7 +803,8 @@ (let ((*print-readably* t)) (with-output-to-string (out) (pprint-linear out (list 'a 'b 'c)))) #+CLISP "(|COMMON-LISP-USER|::|A| |COMMON-LISP-USER|::|B| |COMMON-LISP-USER|::|C|)" -#-CLISP "(A B C)" +#+CMU "(A . (B C))" +#-(or CLISP CMU) "(A B C)" ;; local variables: ;; eval: (make-local-variable 'write-file-functions) Index: clos.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/clos.tst,v retrieving revision 1.90 retrieving revision 1.91 diff -u -d -r1.90 -r1.91 --- clos.tst 30 May 2005 13:32:17 -0000 1.90 +++ clos.tst 10 Jun 2005 10:36:28 -0000 1.91 @@ -488,7 +488,7 @@ &aux (compiled-file (compile-file-pathname lisp-file))) (unwind-protect (progn - (with-open-file (stream lisp-file :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (stream lisp-file :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (format stream "(in-package ~s)~%(defparameter ~S '#.~S)~%" (package-name (symbol-package symbol)) symbol symbol)) @@ -533,7 +533,7 @@ (defmethod make-load-form ((x foo) &optional env) (make-load-form-saving-slots x :environment env)) (defparameter *tmp-file* "mlf-tmp.lisp") - (with-open-file (s *tmp-file* :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (s *tmp-file* :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (format s "(defparameter *foo* '#S(FOO :A BAR-CONST))~%")) (load (compile-file *tmp-file*)) *foo*) @@ -638,7 +638,7 @@ (unwind-protect (progn (makunbound '*foo*) - (with-open-file (f file :direction :output #+SBCL :if-exists #+SBCL :supersede) + (with-open-file (f file :direction :output #+(or CMU SBCL) :if-exists #+(or CMU SBCL) :supersede) (format f "(eval-when (compile load eval) (defstruct foo slot))~@ (defparameter *foo* #.(make-foo))~%")) (load (setq c (compile-file file))) @@ -3884,7 +3884,9 @@ (UNLESS NEW-ARGUMENTS (SETQ NEW-ARGUMENTS ARGUMENTS)) (IF (NULL NEXT-METHODS-LIST) (ERROR "no next method for arguments ~:S" ARGUMENTS) - (FUNCALL (#+SBCL SB-PCL:METHOD-FUNCTION #-SBCL METHOD-FUNCTION + (FUNCALL (#+SBCL SB-PCL:METHOD-FUNCTION + #+CMU MOP:METHOD-FUNCTION + #-(or SBCL CMU) METHOD-FUNCTION (FIRST NEXT-METHODS-LIST)) NEW-ARGUMENTS (REST NEXT-METHODS-LIST))))) (APPLY #'(LAMBDA ,unspecialized-lambdalist ,@body) ARGUMENTS))))) Index: type.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/type.tst,v retrieving revision 1.48 retrieving revision 1.49 diff -u -d -r1.48 -r1.49 --- type.tst 10 May 2005 20:09:24 -0000 1.48 +++ type.tst 10 Jun 2005 10:36:28 -0000 1.49 @@ -144,7 +144,7 @@ ;; depends on (UPGRADED-COMPLEX-PART-TYPE '(EQL 0)) (TYPEP #C(0 1) '(COMPLEX (EQL 0))) -#+(or CLISP GCL CMU19 OpenMCL) NIL #+(or CMU18 SBCL LISPWORKS) T #-(or CLISP GCL CMU SBCL OpenMCL LISPWORKS) UNKNOWN +#+(or CLISP GCL CMU19A OpenMCL) NIL #+(or CMU18 (and CMU19 (not CMU19A)) SBCL LISPWORKS) T #-(or CLISP GCL CMU SBCL OpenMCL LISPWORKS) UNKNOWN #| ; depends on (upgraded-array-element-type 'SYMBOL) ! (TYPEP '#(A B C D) (QUOTE (VECTOR SYMBOL 4))) @@ -773,7 +773,9 @@ (check-type-error (FBOUNDP #'CAR)) NIL +#+CLISP (typep '#1=(A 1 B 2 #1#) 'SYS::PLIST) +#+CLISP NIL (check-type-error (UNION NIL "A")) --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs ... [truncated message content] |
