Commit 58141c01 authored by pfdietz's avatar pfdietz

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.
parent 0b296327
......@@ -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
......@@ -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)))
|#
)))))
......@@ -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*))
......
......@@ -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)
......
......@@ -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)
......
......@@ -5,7 +5,7 @@
(in-package :cl-test)
(load "packages-00.lsp")
(compile-and-load "packages-00.lsp")
;;(declaim (optimize (safety 3)))
......
......@@ -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
......
#+: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)
......@@ -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")
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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)))))
......@@ -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)
......
......@@ -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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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
))
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment