From 58141c0169a45c9f5d9383b41acb0fecea58ef4c Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Sat, 30 Apr 2005 21:32:34 +0000 Subject: [PATCH] Various changes to eliminate warnings. Add a method object to *universe*. Make rt not muffle style-warnings when a :do-not-muffle note is included. --- ansi-tests/ansi-aux.lsp | 35 +------------ ansi-tests/char-aux.lsp | 6 ++- ansi-tests/compile-and-load.lsp | 5 +- ansi-tests/fceiling.lsp | 2 +- ansi-tests/ffloor.lsp | 2 +- ansi-tests/find-symbol.lsp | 2 +- ansi-tests/fround.lsp | 2 +- ansi-tests/gclload1.lsp | 49 ++++++++++-------- ansi-tests/load-packages.lsp | 2 +- ansi-tests/next-method-p.lsp | 2 + ansi-tests/numbers-aux.lsp | 2 +- ansi-tests/printer-aux.lsp | 2 +- ansi-tests/random-aux.lsp | 27 +++++++++- ansi-tests/random-type-prop-tests-04.lsp | 2 +- ansi-tests/remove-duplicates-aux.lsp | 2 +- ansi-tests/rt.lsp | 63 +++++++++++++----------- ansi-tests/string-aux.lsp | 3 +- ansi-tests/structure-00.lsp | 1 + ansi-tests/universe.lsp | 49 +++++++++--------- ansi-tests/with-package-iterator.lsp | 2 +- 20 files changed, 139 insertions(+), 121 deletions(-) diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 3ca2ca84..9e3c54d0 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 af4fafbc..04d78ff4 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 3871970a..469bce57 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 239021c3..e82f1f99 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 c41dd92c..f19035fb 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 3d7eb08c..99f5a44e 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 5209d7ea..ce6a0bb2 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 1827b24c..7e34381a 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 aca9d212..f28b52a0 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 7f1bc429..1cbbda5f 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 a27d715a..a3734cc7 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 0c44fd11..62a334eb 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 7740ff26..02364ced 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 e86d1b34..b12aae40 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 f0e62593..cca014ed 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 4c0e0ffa..708ed40b 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 9b916b4b..ffafc52b 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 96ef8629..f85f0fb9 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 9abb821d..c861ec2f 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 a0b1b425..5096eb50 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 -- GitLab