diff --git a/ansi-tests/ansi-aux-macros.lsp b/ansi-tests/ansi-aux-macros.lsp new file mode 100644 index 0000000000000000000000000000000000000000..7c7b97e122667753adde91d9fc9e6cf02e134d6c --- /dev/null +++ b/ansi-tests/ansi-aux-macros.lsp @@ -0,0 +1,31 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Jul 2 07:05:41 2003 +;;;; Contains: Macros used in ansi-aux and elsewhere. + +(in-package :cl-test) + +(declaim (optimize (safety 3))) + +;;; Macros to avoid annoying sbcl warning notes + +(defmacro handler-case (form &rest cases) + `(let () (cl:handler-case ,form ,@cases))) + +(defmacro handler-bind (handlers &rest body) + `(let () (cl:handler-bind ,handlers (normally (progn ,@body))))) + +;;; Macros for avoiding dead code warnings + +(defvar *should-always-be-true* t) + +(declaim (notinline should-never-be-called)) + +(defun should-never-be-called () nil) + +(defmacro normally (form &optional (default-form + '(should-never-be-called))) + `(if *should-always-be-true* ,form ,default-form)) + + + diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 2ec44f1a7b762ae6e47b33c5e9cc7f00d34ecdd8..15dcea456b863465389ec0b3406ceb38adeedd18 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -223,12 +223,12 @@ Results: ~A~%" expected-number form n results)))) for x in *universe* count (block failed (let ((p1 (handler-case - (funcall (the function p) x) + (normally (funcall (the function p) x)) (error () (format t "(FUNCALL ~S ~S) failed~%" P x) (return-from failed t)))) (p2 (handler-case - (typep x TYPE) + (normally (typep x TYPE)) (error () (format t "(TYPEP ~S '~S) failed~%" x TYPE) (return-from failed t))))) @@ -273,7 +273,7 @@ Results: ~A~%" expected-number form n results)))) If an error does occur, return type-error on TYPE-ERRORs, or the error condition itself on other errors." `(locally (declare (optimize (safety 3))) - (handler-case ,form + (handler-case (normally ,form) (type-error () 'type-error) (error (c) c)))) @@ -282,7 +282,7 @@ condition itself on other errors." If an error does occur, return a symbol classify the error, or allow the condition to go uncaught if it cannot be classified." `(locally (declare (optimize (safety 3))) - (handler-case ,form + (handler-case (normally ,form) (undefined-function () 'undefined-function) (program-error () 'program-error) (package-error () 'package-error) @@ -386,6 +386,10 @@ the condition to go uncaught if it cannot be classified." ;;; (defun complement (fn) ;;; #'(lambda (&rest args) (not (apply fn args)))))) + +(declaim (ftype (function (&rest function) (values function &optional)) + compose)) + (defun compose (&rest fns) (let ((rfns (reverse fns))) #'(lambda (x) (loop for f @@ -434,11 +438,14 @@ the condition to go uncaught if it cannot be classified." " 'simple-base-string)) (defparameter - +base-chars+ #.(concatenate 'simple-base-string - "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "0123456789" - "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|")) + +base-chars+ #.(coerce + (concatenate 'string + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789" + "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|") + 'simple-base-string)) + (declaim (type simple-base-string +base-chars+)) @@ -1277,7 +1284,7 @@ the condition to go uncaught if it cannot be classified." `(eval-when #+gcl (load eval compile) #-gcl (:load-toplevel :compile-toplevel :execute) (handler-case (eval '(defstruct ,@args)) - (serious-condition () nil)))) + (serious-condition () nil)))) (defun sort-package-list (x) (sort (copy-list x) diff --git a/ansi-tests/cl-symbol-names.lsp b/ansi-tests/cl-symbol-names.lsp index bd54e40fc9c7f28dcf57c8ebc3159861ae4e2d44..1bfa0d64966b67b4f9241480587d4ff83b6a9917 100644 --- a/ansi-tests/cl-symbol-names.lsp +++ b/ansi-tests/cl-symbol-names.lsp @@ -1706,8 +1706,8 @@ dolist dotimes formatter - handler-bind - handler-case + cl:handler-bind + cl:handler-case ignore-errors in-package incf diff --git a/ansi-tests/cl-test-package.lsp b/ansi-tests/cl-test-package.lsp index 042d44c92f88a5e30e4558e5b095879838b5d574..9112d891be79e97fe68b6aa40882d2d6a0a53180 100644 --- a/ansi-tests/cl-test-package.lsp +++ b/ansi-tests/cl-test-package.lsp @@ -7,6 +7,7 @@ (:use :cl :regression-test) ;; #+gcl (:use defpackage) (:nicknames) + (:shadow #:handler-case #:handler-bind) (:import-from "COMMON-LISP-USER" #:compile-and-load "==>") (:export #:random-from-seq #:random-case #:coin #:random-permute)) diff --git a/ansi-tests/coerce.lsp b/ansi-tests/coerce.lsp index a2dec7202f36806ad32b86601185dca234ede84e..2f37faeea0300d86a93a6b160f4def357223840b 100644 --- a/ansi-tests/coerce.lsp +++ b/ansi-tests/coerce.lsp @@ -157,8 +157,9 @@ type-error) (deftest coerce.error.5 - (handler-case (eval '(coerce 'not-a-bound-function 'function)) - (error () :caught)) + (handler-case + (eval '(coerce 'not-a-bound-function 'function)) + (error () :caught)) :caught) (deftest coerce.error.6 diff --git a/ansi-tests/defgeneric.lsp b/ansi-tests/defgeneric.lsp index c2dd0994ddd3d72dbcf8064cd50a519a004f7644..3e5bf42147403e5cb1338c96bbc7bad1509ca019 100644 --- a/ansi-tests/defgeneric.lsp +++ b/ansi-tests/defgeneric.lsp @@ -212,6 +212,7 @@ (deftest defgeneric.1 (let ((fn (eval '(defgeneric defgeneric.fun.1 (x y z) (:method ((x t) (y t) (z t)) (list x y z)))))) + (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) @@ -226,6 +227,7 @@ (let ((fn (eval '(defgeneric defgeneric.fun.2 (x y z) (:documentation "boo!") (:method ((x t) (y t) (z t)) (vector x y z)))))) + (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) @@ -252,6 +254,7 @@ (let ((fn (eval '(defgeneric defgeneric.fun.3 (x y) (:method ((x t) (y symbol)) (list x y)) (:method ((x symbol) (y t)) (list y x)))))) + (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) @@ -268,6 +271,7 @@ (:argument-precedence-order y x) (:method ((x t) (y symbol)) (list x y)) (:method ((x symbol) (y t)) (list y x)))))) + (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) @@ -282,6 +286,7 @@ (deftest defgeneric.5 (let ((fn (eval '(defgeneric defgeneric.fun.5 () (:method () (values)))))) + (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) @@ -293,6 +298,7 @@ (deftest defgeneric.6 (let ((fn (eval '(defgeneric defgeneric.fun.6 () (:method () (values 'a 'b 'c)))))) + (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) @@ -304,6 +310,7 @@ (deftest defgeneric.7 (let ((fn (eval '(defgeneric defgeneric.fun.7 () (:method () (return-from defgeneric.fun.7 'a) 'b))))) + (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) @@ -318,6 +325,7 @@ (list x y z)) (:method ((p symbol) &optional q r) (list r q p)))))) + (declare (type function fn)) (values (typep* fn 'generic-function) (typep* fn 'standard-generic-function) @@ -343,6 +351,7 @@ (list x y z)) (:method ((p symbol) &optional (q 's) (r 't)) (list r q p)))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 2) @@ -360,6 +369,7 @@ (deftest defgeneric.10 (let ((fn (eval '(defgeneric defgeneric.fun.10 (x &rest y) (:method ((x number) &key foo) (list x foo)))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo 'a) @@ -375,6 +385,7 @@ (deftest defgeneric.11 (let ((fn (eval '(defgeneric defgeneric.fun.11 (x &key) (:method ((x number) &key foo) (list x foo)))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo 'a) @@ -390,6 +401,7 @@ (deftest defgeneric.12 (let ((fn (eval '(defgeneric defgeneric.fun.12 (x &key foo bar baz) (:method ((x number) &rest y) (list x y)))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo 'a) @@ -406,6 +418,7 @@ (let ((fn (eval '(defgeneric defgeneric.fun.13 (x &key) (:method ((x number) &key foo) (list x foo)) (:method ((x symbol) &key bar) (list x bar)))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 'a) @@ -430,6 +443,7 @@ (let ((fn (eval '(defgeneric defgeneric.fun.14 (x &key &allow-other-keys) (:method ((x number) &key foo) (list x foo)) (:method ((x symbol) &key bar) (list x bar)))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 'a) @@ -462,6 +476,7 @@ (:method ((x number) &key foo &allow-other-keys) (list x foo)) (:method ((x symbol) &key bar) (list x bar)))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 'a) @@ -496,6 +511,7 @@ (list x foo)) (:method ((x symbol) &key foo) (list x foo)))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo nil) @@ -516,6 +532,7 @@ (list x foo (notnot foo-p))) (:method ((x symbol) &key foo) (list x foo)))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :foo nil) @@ -536,6 +553,7 @@ (list x y)) (:method ((x symbol) &optional (z nil z-p)) (list x z (notnot z-p))))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 nil) @@ -554,6 +572,7 @@ (let ((fn (eval '(defgeneric defgeneric.fun.19 (x &key) (:method ((x number) &key ((:bar foo) 'a foo-p)) (list x foo (notnot foo-p))))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :bar nil) @@ -569,6 +588,7 @@ (z (if y-p (1+ y) (+ x 10)) z-p)) (list x y (notnot y-p) z (notnot z-p))))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 5) @@ -584,6 +604,7 @@ (z (if y-p (1+ y) (+ x 10)) z-p)) (list x y (notnot y-p) z (notnot z-p))))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :y 5) @@ -600,6 +621,7 @@ (let ((fn (eval '(defgeneric defgeneric.fun.22 (x &key) (:method ((x number) &key ((:allow-other-keys y))) (list x y)))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 1 :allow-other-keys nil) @@ -624,6 +646,7 @@ (let ((fn (eval '(defgeneric defgeneric.fun.23 (x) (:method ((x number) &aux (y (1+ x))) (list x y)) (:method ((x symbol) &aux (z (list x))) (list x z)))))) + (declare (type function fn)) (values (funcall fn 1) (funcall fn 'a))) @@ -649,6 +672,7 @@ &aux (z (list x y (notnot y-p) bar (notnot bar-p)))) z))))) + (declare (type function fn)) (values (funcall fn 'a) (funcall fn 'a 'b) @@ -662,6 +686,7 @@ (declare (optimize (safety 3))) (:method ((x symbol)) x) (declare (optimize (debug 3))))))) + (declare (type function fn)) (funcall fn 'a)) a) @@ -675,6 +700,7 @@ (:method ((x number) (y number)) (+ x y)) (:method ((x string) (y string)) (concatenate 'string x y)))))) + (declare (type function fn)) (values (funcall fn 1 2) (funcall fn "1" "2"))) @@ -686,6 +712,7 @@ (:method ((x integer) &key foo) (list x foo)) (:method ((x number) &key bar) (list x bar)) (:method ((x t) &key baz) (list x baz)))))) + (declare (type function fn)) (values (funcall fn 1) @@ -725,6 +752,7 @@ (eval '(defgeneric defgeneric.fun.29 (x &key) (:method ((x defgeneric.29.class.1) &key foo) foo) (:method ((x defgeneric.29.class.2) &key bar) bar))))) + (declare (type function fn)) (let ((x (make-instance 'defgeneric.29.class.3))) (values (funcall fn x) @@ -744,6 +772,7 @@ (:generic-function-class substandard-generic-function) (:method ((x symbol)) 1) (:method ((x integer)) 2))))) + (declare (type function fn)) (values (typep* fn 'substandard-generic-function) (typep* fn 'standard-generic-function) @@ -777,6 +806,7 @@ (assert (null args)) (setf (car y) x)) (:method (x (y array) &rest args) (setf (apply #'aref y args) x)))))) + (declare (type function fn)) (values (let ((z (list 'a 'b))) (list @@ -802,6 +832,7 @@ "FOO" (declare (optimize (safety 3))) x))))) + (declare (type function fn)) (values (funcall fn 'a) (let ((method (first (compute-applicable-methods fn '(a))))) diff --git a/ansi-tests/define-condition-aux.lsp b/ansi-tests/define-condition-aux.lsp index 4e94c7437aa09b8827943b8af675b42ab1680990..7e9ead95446306f3b82ac745d088403677ef5a18 100644 --- a/ansi-tests/define-condition-aux.lsp +++ b/ansi-tests/define-condition-aux.lsp @@ -67,22 +67,19 @@ t)) (deftest ,(make-def-cond-name name "HANDLER-CASE-1") (let ((c (make-condition ',name-symbol))) - (handler-case (signal c) + (handler-case (normally (signal c)) (,name-symbol (c1) (eqt c c1)))) t) (deftest ,(make-def-cond-name name "HANDLER-CASE-2") (let ((c (make-condition ',name-symbol))) - (handler-case (signal c) + (handler-case (normally (signal c)) (condition (c1) (eqt c c1)))) t) ,@(unless (some #'(lambda (ct) (subtypep ct 'error)) parents) `((deftest ,(make-def-cond-name name "HANDLER-CASE-3") (let ((c (make-condition ',name-symbol))) - (handler-case (signal c) + (handler-case (normally (signal c)) (error () nil) (,name-symbol (c2) (eqt c c2)))) t))) ))) - - - diff --git a/ansi-tests/define-condition.lsp b/ansi-tests/define-condition.lsp index dd94c3c1047834e16e7dce68ec715f5fbcb14acc..6c424e7b2961da6d9bfcabccd56eb21afe0e2278 100644 --- a/ansi-tests/define-condition.lsp +++ b/ansi-tests/define-condition.lsp @@ -288,13 +288,13 @@ (with-output-to-string (s) (print-object c s))) "The report for condition-16") +(defun condition-17-report (c s) + (format s "condition-17: ~A" (condition-17/s c))) + (define-condition-with-tests condition-17 nil ((s :initarg :i1 :reader condition-17/s )) (:report condition-17-report)) -(defun condition-17-report (c s) - (format s "condition-17: ~A" (condition-17/s c))) - (deftest condition-17-report.1 (let ((*print-escape* nil) (c (make-condition 'condition-17 :i1 1234))) diff --git a/ansi-tests/gclload1.lsp b/ansi-tests/gclload1.lsp index aa47979044978345cc21b51491fe9f9e3c158cf1..69c2cd65fe1f78c52a8acaf7ba1246701e58d8b3 100644 --- a/ansi-tests/gclload1.lsp +++ b/ansi-tests/gclload1.lsp @@ -6,6 +6,7 @@ ;;; (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")