(load source)
(full-check)
(delete-file fasl)))
-
+\f
+(defun expt-derive-type-bug (a b)
+ (unless (< a b)
+ (truncate (expt a b))))
+(assert (equal (multiple-value-list (expt-derive-type-bug 1 1))
+ '(1 0)))
+
+;;; Problems with type checking in functions with EXPLICIT-CHECK
+;;; attribute (reported by Peter Graves)
+(loop for (fun . args) in '((= a) (/= a)
+ (< a) (<= a) (> a) (>= a))
+ do (assert (raises-error? (apply fun args) type-error)))
+
+(defclass broken-input-stream (sb-gray:fundamental-input-stream) ())
+(defmethod sb-gray:stream-read-char ((stream broken-input-stream))
+ (throw 'break :broken))
+(assert (eql (block return
+ (handler-case
+ (catch 'break
+ (funcall (eval ''peek-char)
+ 1 (make-instance 'broken-input-stream))
+ :test-broken)
+ (type-error (c)
+ (return-from return :good))))
+ :good))
+\f
+;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual)
+(defvar *compiler-note-count* 0)
+(handler-bind ((sb-ext:compiler-note (lambda (c)
+ (declare (ignore c))
+ (incf *compiler-note-count*))))
+ (let ((fun
+ (compile nil
+ '(lambda (x)
+ (declare (optimize speed) (fixnum x))
+ (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
+ (values (* x 5) ; no compiler note from this
+ (locally
+ (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
+ ;; this one gives a compiler note
+ (* x -5)))))))
+ (assert (= *compiler-note-count* 1))
+ (assert (equal (multiple-value-list (funcall fun 1)) '(5 -5)))))
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself