Skip to content
Snippets Groups Projects
Commit bccf9469 authored by pfdietz's avatar pfdietz
Browse files

Some tweaks to reduce the number of compiler notes from sbcl.

parent 3ce0d850
No related branches found
No related tags found
No related merge requests found
;-*- 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))
......@@ -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)
......
......@@ -1706,8 +1706,8 @@
dolist
dotimes
formatter
handler-bind
handler-case
cl:handler-bind
cl:handler-case
ignore-errors
in-package
incf
......
......@@ -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))
......
......@@ -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
......
......@@ -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)))))
......
......@@ -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)))
)))
......@@ -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)))
......
......@@ -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")
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment