diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 3ca2ca84f6ea340805d7f98675ba18984d6890f9..9e3c54d09711d61418956c37f077dbab99d6e143 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -324,12 +324,6 @@ the condition to go uncaught if it cannot be classified." (or (not (second results)) (not (first results)))))) -;;; (eval-when (load eval compile) -;;; (unless (fboundp 'complement) -;;; (defun complement (fn) -;;; #'(lambda (&rest args) (not (apply fn args)))))) - - (declaim (ftype (function (&rest function) (values function &optional)) compose)) @@ -808,33 +802,6 @@ the condition to go uncaught if it cannot be classified." (* significand (expt radix limit) sign)) (t (rational x)))))) -(defun random-partition* (n p) - "Partition n into p numbers, each >= 0. Return list of numbers." - (assert (<= 1 p)) - (cond - ((= p 1) (list n)) - ((= n 0) (make-list p :initial-element 0)) - (t (let* ((r (random p)) - (n1 (random (1+ n)))) - (cond - ((= r 0) - (cons n1 (random-partition* (- n n1) (1- p)))) - ((= r (1- p)) - (append (random-partition* (- n n1) (1- p)) (list n1))) - (t - (let* ((n2 (random (1+ (- n n1)))) - (n3 (- n n1 n2))) - (append (random-partition* n2 r) - (list n1) - (random-partition* n3 (- p 1 r)))))))))) - -(defun random-partition (n p) - "Partition n into p numbers, each >= 1 (if possible.)" - (cond - ((<= n p) - (make-list p :initial-element 1)) - (t (mapcar #'1+ (random-partition* (- n p) p))))) - (declaim (special *similarity-list*)) (defun is-similar (x y) @@ -1062,7 +1029,9 @@ the condition to go uncaught if it cannot be classified." (error nil))) ;;; Approximate comparison of numbers +#| (defun approx= (x y) (let ((eps 1.0d-4)) (<= (abs (- x y)) (* eps (max (abs x) (abs y)))))) +|# \ No newline at end of file diff --git a/ansi-tests/char-aux.lsp b/ansi-tests/char-aux.lsp index af4fafbc4bee850e15c7fd40b5f5cbb73ea5f1b3..04d78ff42ead12d1a0331a38034878181ac90dfb 100644 --- a/ansi-tests/char-aux.lsp +++ b/ansi-tests/char-aux.lsp @@ -299,7 +299,11 @@ (let ((c (name-char x))) (or (not c) (characterp c) + ;; FIXME The rest of this wasn't reachable + #| (let ((name (char-name c))) (declare (type (or null string) name)) (and name - (string-equal name s)))))))) + (string-equal name s))) + |# + ))))) diff --git a/ansi-tests/compile-and-load.lsp b/ansi-tests/compile-and-load.lsp index 3871970a6ca63dff36c8487dd119e8d9373dfeb5..469bce57cfdeb066e885de1fd17dfc7f0989ff13 100644 --- a/ansi-tests/compile-and-load.lsp +++ b/ansi-tests/compile-and-load.lsp @@ -34,7 +34,10 @@ (>= (cadr former-data) source-write-time)) (when (or (not target-write-time) (<= target-write-time source-write-time)) - (compile-file pathname)) + (handler-bind + #-sbcl () + #+sbcl ((sb-ext:code-deletion-note #'muffle-warning)) + (compile-file pathname))) (if former-data (setf (cadr former-data) source-write-time) (push (list pathname source-write-time) *compiled-and-loaded-files*)) diff --git a/ansi-tests/fceiling.lsp b/ansi-tests/fceiling.lsp index 239021c34ae634c3aaa3ff26140d22d1240682ca..e82f1f9997698d165347ea2a7d3baf4911bd3d25 100644 --- a/ansi-tests/fceiling.lsp +++ b/ansi-tests/fceiling.lsp @@ -6,7 +6,7 @@ (in-package :cl-test) (compile-and-load "numbers-aux.lsp") -(ignore-errors (compile-and-load "fceiling-aux.lsp")) +(compile-and-load "fceiling-aux.lsp") (deftest fceiling.error.1 (signals-error (fceiling) program-error) diff --git a/ansi-tests/ffloor.lsp b/ansi-tests/ffloor.lsp index c41dd92cd08d7fb49ef2a32de40cc27ac4cc5cf6..f19035fb7e88fdff8421e4750a38da3320defae6 100644 --- a/ansi-tests/ffloor.lsp +++ b/ansi-tests/ffloor.lsp @@ -6,7 +6,7 @@ (in-package :cl-test) (compile-and-load "numbers-aux.lsp") -(ignore-errors (compile-and-load "ffloor-aux.lsp")) +(compile-and-load "ffloor-aux.lsp") (deftest ffloor.error.1 (signals-error (ffloor) program-error) diff --git a/ansi-tests/find-symbol.lsp b/ansi-tests/find-symbol.lsp index 3d7eb08c2544d3c3f8dec248ec5571711bffdec6..99f5a44ed092f01381f2668930b7832df66513d7 100644 --- a/ansi-tests/find-symbol.lsp +++ b/ansi-tests/find-symbol.lsp @@ -5,7 +5,7 @@ (in-package :cl-test) -(load "packages-00.lsp") +(compile-and-load "packages-00.lsp") ;;(declaim (optimize (safety 3))) diff --git a/ansi-tests/fround.lsp b/ansi-tests/fround.lsp index 5209d7ea03f2c7a9761aae94b21a8780ec0bb67c..ce6a0bb21a91dcc1132b1ef9f674030bae5176d4 100644 --- a/ansi-tests/fround.lsp +++ b/ansi-tests/fround.lsp @@ -6,7 +6,7 @@ (in-package :cl-test) (compile-and-load "numbers-aux.lsp") -(ignore-errors (compile-and-load "fround-aux.lsp")) +(compile-and-load "fround-aux.lsp") ;;; Error tests diff --git a/ansi-tests/gclload1.lsp b/ansi-tests/gclload1.lsp index 1827b24cc75a989ca6d4715e34454707e209b35e..7e34381a8e9c13bac2d1c5152f2599ea7e1a03e7 100644 --- a/ansi-tests/gclload1.lsp +++ b/ansi-tests/gclload1.lsp @@ -1,27 +1,6 @@ #+:ecl (si::package-lock (find-package "COMMON-LISP") nil) #+:armedbear (require 'pprint) -(load "compile-and-load.lsp") -(load "rt-package.lsp") -(compile-and-load "rt.lsp") -;;; (unless (probe-file "rt.o") (compile-file "rt.lsp")) -;;; (load "rt.o") -(load "cl-test-package.lsp") -(in-package :cl-test) -(compile-and-load "ansi-aux-macros.lsp") -(load "universe.lsp") -(compile-and-load "random-aux.lsp") -(compile-and-load "ansi-aux.lsp") -;;; (unless (probe-file "ansi-aux.o") (compile-file "ansi-aux.lsp")) -;;; (load "ansi-aux.o") - -(load "cl-symbol-names.lsp") -(load "notes.lsp") - -(setq *compile-verbose* nil - *compile-print* nil - *load-verbose* nil) - #+cmu (setq ext:*gc-verbose* nil) #+gcl (setq compiler:*suppress-compiler-notes* t @@ -35,3 +14,31 @@ c:*suppress-compiler-notes* t) #+clisp (setq custom::*warn-on-floating-point-contagion* nil) + +(let (*load-verbose* *load-print* *compile-verbose* *compile-print*) + (load "compile-and-load.lsp")) + +(let (*load-verbose* *load-print* *compile-verbose* *compile-print*) + (load "rt-package.lsp") + (compile-and-load "rt.lsp") + ;; (unless (probe-file "rt.o") (compile-file "rt.lsp")) + ;; (load "rt.o") + (load "cl-test-package.lsp") + (in-package :cl-test) + (compile-and-load "ansi-aux-macros.lsp") + (handler-bind + #-sbcl () + #+sbcl ((sb-ext:code-deletion-note #'muffle-warning)) + (load "universe.lsp")) + (compile-and-load "random-aux.lsp") + (compile-and-load "ansi-aux.lsp") + ;; (unless (probe-file "ansi-aux.o") (compile-file "ansi-aux.lsp")) + ;; (load "ansi-aux.o") + + (load "cl-symbol-names.lsp") + (load "notes.lsp")) + +(setq *compile-verbose* nil + *compile-print* nil + *load-verbose* nil) + diff --git a/ansi-tests/load-packages.lsp b/ansi-tests/load-packages.lsp index aca9d212ed88643ed43f2e45d5d676a7025cdce2..f28b52a0833c56b3db97707521a80062c8fcf01d 100644 --- a/ansi-tests/load-packages.lsp +++ b/ansi-tests/load-packages.lsp @@ -4,7 +4,7 @@ ;;;; Contains: Loader for files containing package tests -(load "packages-00.lsp") +(compile-and-load "packages-00.lsp") (load "find-symbol.lsp") (load "find-all-symbols.lsp") (load "find-package.lsp") diff --git a/ansi-tests/next-method-p.lsp b/ansi-tests/next-method-p.lsp index 7f1bc4294f5496828ff7933a85177555901d2b06..1cbbda5f3edfb1d81681daabfea8df327ca39d5d 100644 --- a/ansi-tests/next-method-p.lsp +++ b/ansi-tests/next-method-p.lsp @@ -46,6 +46,7 @@ (funcall (nmp-gf-03 10 'a)) nil) +(defgeneric nmp-gf-04 (x y)) (defmethod nmp-gf-04 ((x integer) (y symbol)) #'next-method-p) (defmethod nmp-gf-04 ((x t) (y (eql nil))) (constantly 2)) @@ -59,6 +60,7 @@ ;; With AROUND methods +(defgeneric nmp-gf-05 (x)) (defmethod nmp-gf-05 :around ((x number)) (notnot-mv (next-method-p))) (defmethod nmp-gf-05 ((x integer)) 'foo) diff --git a/ansi-tests/numbers-aux.lsp b/ansi-tests/numbers-aux.lsp index a27d715a3a1e931a09848342a4065916f4f04f11..a3734cc7dc62d4168c844e0d02fe37d66a1bab98 100644 --- a/ansi-tests/numbers-aux.lsp +++ b/ansi-tests/numbers-aux.lsp @@ -5,7 +5,7 @@ (in-package :cl-test) -(eval-when (load eval) +(eval-when (:compile-toplevel :load-toplevel :execute) (compile-and-load "random-aux.lsp")) ;;; Binary search on reals diff --git a/ansi-tests/printer-aux.lsp b/ansi-tests/printer-aux.lsp index 0c44fd1108e7146b645dd53f524c2af86c0bbf40..62a334ebf308aded2f4ffecefef3fbedc1a42398 100644 --- a/ansi-tests/printer-aux.lsp +++ b/ansi-tests/printer-aux.lsp @@ -5,7 +5,7 @@ (in-package :cl-test) -(eval-when (load eval compile) (compile-and-load "random-aux.lsp")) +(eval-when (:compile-toplevel :load-toplevel :execute) (compile-and-load "random-aux.lsp")) (defmacro def-print-test (name form result &rest bindings) `(deftest ,name diff --git a/ansi-tests/random-aux.lsp b/ansi-tests/random-aux.lsp index 7740ff263f30ba44f53ebc46996751c6c20ea0ce..02364ced9be055a58cdce21cbdeb0cc0c4059273 100644 --- a/ansi-tests/random-aux.lsp +++ b/ansi-tests/random-aux.lsp @@ -151,5 +151,30 @@ count (+ expected bound)))) - +(defun random-partition* (n p) + "Partition n into p numbers, each >= 0. Return list of numbers." + (assert (<= 1 p)) + (cond + ((= p 1) (list n)) + ((= n 0) (make-list p :initial-element 0)) + (t (let* ((r (random p)) + (n1 (random (1+ n)))) + (cond + ((= r 0) + (cons n1 (random-partition* (- n n1) (1- p)))) + ((= r (1- p)) + (append (random-partition* (- n n1) (1- p)) (list n1))) + (t + (let* ((n2 (random (1+ (- n n1)))) + (n3 (- n n1 n2))) + (append (random-partition* n2 r) + (list n1) + (random-partition* n3 (- p 1 r)))))))))) + +(defun random-partition (n p) + "Partition n into p numbers, each >= 1 (if possible.)" + (cond + ((<= n p) + (make-list p :initial-element 1)) + (t (mapcar #'1+ (random-partition* (- n p) p))))) diff --git a/ansi-tests/random-type-prop-tests-04.lsp b/ansi-tests/random-type-prop-tests-04.lsp index e86d1b3458ad30b7e38c51c8ed77db84c682446f..b12aae407e0e8b6810d371e297df427da2e6060e 100644 --- a/ansi-tests/random-type-prop-tests-04.lsp +++ b/ansi-tests/random-type-prop-tests-04.lsp @@ -9,7 +9,7 @@ (declare (ignore args)) (if (coin) `(eql ,c) 'character)) -(eval-when (load eval) (compile 'char-or-same)) +(eval-when (:load-toplevel :execute) (compile 'char-or-same)) (def-type-prop-test char=.1 'char= nil 2 :rest-type 'base-char :maxargs 5) (def-type-prop-test char=.2 'char= '(character character) 2) diff --git a/ansi-tests/remove-duplicates-aux.lsp b/ansi-tests/remove-duplicates-aux.lsp index f0e625936612e254cbf2062fffc0335c276379d8..cca014ed545c5f44632ab9f759bcfe79f34f322f 100644 --- a/ansi-tests/remove-duplicates-aux.lsp +++ b/ansi-tests/remove-duplicates-aux.lsp @@ -36,7 +36,7 @@ do (push (elt sequence i) result)) (loop for i from start below end for x = (elt sequence i) - for kx = (if key (funcall (the function key) x) x) + for kx = (funcall (the function key) x) unless (position kx sequence :start (1+ i) diff --git a/ansi-tests/rt.lsp b/ansi-tests/rt.lsp index 4c0e0ffa12fcf20ee0da19f051bde9b3200a0b67..708ed40bab8c686c8a174f0f11caff64dd4893b0 100644 --- a/ansi-tests/rt.lsp +++ b/ansi-tests/rt.lsp @@ -91,6 +91,12 @@ (gethash n *notes*)) thereis (and note (note-disabled note))))) +(defun has-note (entry note) + (unless (note-p note) + (let ((new-note (gethash note *notes*))) + (setf note new-note))) + (and note (not (not (member note (entry-notes entry)))))) + (defun pending-tests () (loop for entry in (cdr *entries*) when (and (pend entry) (not (has-disabled-note entry))) @@ -172,9 +178,7 @@ &key ((:catch-errors *catch-errors*) *catch-errors*) ((:compile *compile-tests*) *compile-tests*)) - #-sbcl (do-entry (get-entry name)) - #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning)) - (do-entry (get-entry name)))) + (do-entry (get-entry name))) (defun my-aref (a &rest args) (apply #'aref a args)) @@ -233,26 +237,33 @@ (block aborted (setf r - (flet ((%do - () - (cond - (*compile-tests* - (multiple-value-list - (funcall (compile - nil - `(lambda () - (declare - (optimize ,@*optimization-settings*)) - ,(form entry)))))) - (*expanded-eval* - (multiple-value-list - (expanded-eval (form entry)))) - (t - (multiple-value-list - (eval (form entry))))))) + (flet ((%do () + (handler-bind + #-sbcl nil + #+sbcl ((sb-ext:code-deletion-note #'(lambda (c) + (if (has-note entry :do-not-muffle) + nil + (muffle-warning c))))) + (cond + (*compile-tests* + (multiple-value-list + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry)))))) + (*expanded-eval* + (multiple-value-list + (expanded-eval (form entry)))) + (t + (multiple-value-list + (eval (form entry)))))))) (if *catch-errors* (handler-bind - (#-ecl (style-warning #'muffle-warning) + (#-ecl (style-warning #'(lambda (c) (if (has-note entry :do-not-muffle-warnings) + c + (muffle-warning c)))) (error #'(lambda (c) (setf aborted t) (setf r (list c)) @@ -278,8 +289,7 @@ ~{~S~^~%~15t~}.~%" (length r) r))) (format s "~A" st)) - (error () (format s "Actual value: #<error during printing>~%") - )) + (error () (format s "Actual value: #<error during printing>~%"))) (finish-output s))))) (when (not (pend entry)) *test*)) @@ -337,7 +347,7 @@ (stream out :direction :output) (do-entries stream)))) -(defun do-entries* (s) +(defun do-entries (s) (format s "~&Doing ~A pending test~:P ~ of ~A tests total.~%" (count t (the list (cdr *entries*)) :key #'pend) @@ -383,11 +393,6 @@ (finish-output s) (null pending)))) -(defun do-entries (s) - #-sbcl (do-entries* s) - #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning)) - (do-entries* s))) - ;;; Note handling functions and macros (defmacro defnote (name contents &optional disabled) diff --git a/ansi-tests/string-aux.lsp b/ansi-tests/string-aux.lsp index 9b916b4b211a865cf3182cfcf50abd46b125d1c5..ffafc52b39b3434a9022272b172da54d62ef9839 100644 --- a/ansi-tests/string-aux.lsp +++ b/ansi-tests/string-aux.lsp @@ -5,7 +5,8 @@ (in-package :cl-test) -(eval-when (load eval compile) (compile-and-load "random-aux.lsp")) +(eval-when (:compile-toplevel :load-toplevel :execute) + (compile-and-load "random-aux.lsp")) (defun my-string-compare (string1 string2 comparison &key (start1 0) end1 (start2 0) end2 case diff --git a/ansi-tests/structure-00.lsp b/ansi-tests/structure-00.lsp index 96ef8629293e772999efe0119932e08796646ae0..f85f0fb967a6599ac5b075d5d9af4529c037c188 100644 --- a/ansi-tests/structure-00.lsp +++ b/ansi-tests/structure-00.lsp @@ -262,6 +262,7 @@ do the defstruct." (cons slot-name (create-instance-of-type type)) (cons slot-name (defstruct-maketemp name "SLOTTEMP" i))))) ) + (declare (ignorable initial-offset)) ;; Build the tests in an eval-when form `(eval-when (:load-toplevel :compile-toplevel :execute) diff --git a/ansi-tests/universe.lsp b/ansi-tests/universe.lsp index 9abb821dc2c7453d212a58ce27dd223b92c1010e..c861ec2f4857a0536a2e9aac373d40d29fbf0b3d 100644 --- a/ansi-tests/universe.lsp +++ b/ansi-tests/universe.lsp @@ -376,26 +376,25 @@ (defparameter *pathnames* (locally (declare (optimize safety)) - (append - (ignore-errors (list (make-pathname :name "foo"))) - (ignore-errors (list (make-pathname :name "FOO" :case :common))) - (ignore-errors (list (make-pathname :name "bar"))) - (ignore-errors (list (make-pathname :name "foo" :type "txt"))) - (ignore-errors (list (make-pathname :name "bar" :type "txt"))) - (ignore-errors (list (make-pathname :name "XYZ" :type "TXT" :case :common))) - (ignore-errors (list (make-pathname :name nil))) - (ignore-errors (list (make-pathname :name :wild))) - (ignore-errors (list (make-pathname :name nil :type "txt"))) - (ignore-errors (list (make-pathname :name :wild :type "txt"))) - (ignore-errors (list (make-pathname :name :wild :type "TXT" :case :common))) - (ignore-errors (list (make-pathname :name :wild :type "abc" :case :common))) - (ignore-errors (list (make-pathname :directory :wild))) - (ignore-errors (list (make-pathname :type :wild))) - (ignore-errors (list (make-pathname :version :wild))) - (ignore-errors (list (make-pathname :version :newest))) - ))) - -(eval-when (load eval compile) + (loop for form in '((make-pathname :name "foo") + (make-pathname :name "FOO" :case :common) + (make-pathname :name "bar") + (make-pathname :name "foo" :type "txt") + (make-pathname :name "bar" :type "txt") + (make-pathname :name "XYZ" :type "TXT" :case :common) + (make-pathname :name nil) + (make-pathname :name :wild) + (make-pathname :name nil :type "txt") + (make-pathname :name :wild :type "txt") + (make-pathname :name :wild :type "TXT" :case :common) + (make-pathname :name :wild :type "abc" :case :common) + (make-pathname :directory :wild) + (make-pathname :type :wild) + (make-pathname :version :wild) + (make-pathname :version :newest)) + append (ignore-errors (eval `(list ,form)))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) (locally (declare (optimize safety)) (ignore-errors @@ -453,10 +452,9 @@ (list (+ x 1) (+ y 2) (+ z 3))) (defgeneric meaningless-user-generic-function-for-universe (x y z) - #+(or (not :gcl) :setf) (:method ((x integer) (y integer) (z integer)) (+ x y z)) - ) + #+(or (not :gcl) :ansi-cl) (:method ((x integer) (y integer) (z integer)) (+ x y z))) -(eval-when (:load-toplevel) +(eval-when (:load-toplevel :execute) (compile 'meaningless-user-function-for-universe) (compile 'meaningless-user-generic-function-for-universe) ) @@ -470,7 +468,10 @@ (defparameter *methods* (list - ;; Add methods here + #+(or (not :gcl) :ansi-cl) + (find-method #'meaningless-user-generic-function-for-universe nil + '(integer integer integer)) + ;; Add more methods here )) diff --git a/ansi-tests/with-package-iterator.lsp b/ansi-tests/with-package-iterator.lsp index a0b1b42527c782fae8d13ee9166b9b6dc5aeab63..5096eb50e17594b7a40606e8f022ed1a864ffa5b 100644 --- a/ansi-tests/with-package-iterator.lsp +++ b/ansi-tests/with-package-iterator.lsp @@ -6,7 +6,7 @@ (in-package :cl-test) (declaim (optimize (safety 3))) -(load "package-aux.lsp") +(compile-and-load "package-aux.lsp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; with-package-iterator