;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
;;; a while; fixed by CSR 2002-07-18
-(multiple-value-bind (value error)
- (ignore-errors (some-undefined-function))
- (assert (null value))
- (assert (eq (cell-error-name error) 'some-undefined-function)))
+(with-test (:name :undefined-function-error)
+ (multiple-value-bind (value error)
+ (ignore-errors (some-undefined-function))
+ (assert (null value))
+ (assert (eq (cell-error-name error) 'some-undefined-function))))
;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
(error "bad RANDOM event"))))
;;; 0.8.17.28-sma.1 lost derived type information.
-(with-test (:name "0.8.17.28-sma.1" :fails-on :sparc)
+(with-test (:name :0.8.17.28-sma.1 :fails-on :sparc)
(handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c))))
(compile nil
'(lambda (x y v)
(compile nil `(lambda (x)
(declare (character x) (optimize speed))
(,name x))))
- (dolist (name '(char= char/= char< char> char<= char>= char-equal
- char-not-equal char-lessp char-greaterp char-not-greaterp
+ (dolist (name '(char= char/= char< char> char<= char>=
+ char-lessp char-greaterp char-not-greaterp
char-not-lessp))
(setf current name)
(compile nil `(lambda (x y)
(array-in-bounds-p a 5 2))))))
;;; optimizing (EXPT -1 INTEGER)
-(with-test (:name (expt minus-one integer))
+(with-test (:name (expt -1 integer))
(dolist (x '(-1 -1.0 -1.0d0))
(let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x))))))
(assert (not (ctu:find-named-callees fun)))
(setf hash (logand most-positive-word
(ash hash 5)))))))
-(with-test (:name (local-&optional-recursive-inline :bug-1180992))
+(with-test (:name (:local-&optional-recursive-inline :bug-1180992))
(compile nil
`(lambda ()
(labels ((called (&optional a))
;; be reported as mismatches with the value NIL. Make sure we get
;; a warning, but that it doesn't complain about a constant NIL ...
;; of type FIXNUM.
-(with-test (:name (:multiple-use-lvar-interpreted-as-NIL cast))
+(with-test (:name (:multiple-use-lvar-interpreted-as-NIL :cast))
(block nil
(handler-bind ((sb-int:type-warning
(lambda (c)
;; win32 is very specific about the order in which catch blocks
;; must be allocated on the stack
-(with-test (:name :bug-121581169)
+(with-test (:name :bug-1072739)
(let ((f (compile nil
`(lambda ()
(STRING=
G13908)))
"23a%b%")))))
(assert (funcall f))))
+
+(with-test (:name :equal-equalp-transforms)
+ (let* ((s "foo")
+ (bit-vector #*11001100)
+ (values `(nil 1 2 "test"
+ ;; Floats duplicated here to ensure we get newly created instances
+ (read-from-string "1.1") (read-from-string "1.2d0")
+ (read-from-string "1.1") (read-from-string "1.2d0")
+ 1.1 1.2d0 '("foo" "bar" "test")
+ #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file"
+ ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector)
+ ,(make-hash-table) #\a #\b #\A #\C
+ ,(make-random-state) 1/2 2/3)))
+ ;; Test all permutations of different types
+ (assert
+ (loop
+ for x in values
+ always (loop
+ for y in values
+ always
+ (and (eq (funcall (compile nil `(lambda (x y)
+ (equal (the ,(type-of x) x)
+ (the ,(type-of y) y))))
+ x y)
+ (equal x y))
+ (eq (funcall (compile nil `(lambda (x y)
+ (equalp (the ,(type-of x) x)
+ (the ,(type-of y) y))))
+ x y)
+ (equalp x y))))))
+ (assert
+ (funcall (compile
+ nil
+ `(lambda (x y)
+ (equal (the (cons (or simple-bit-vector simple-base-string))
+ x)
+ (the (cons (or (and bit-vector (not simple-array))
+ (simple-array character (*))))
+ y))))
+ (list (string 'list))
+ (list "LIST")))
+ (assert
+ (funcall (compile
+ nil
+ `(lambda (x y)
+ (equalp (the (cons (or simple-bit-vector simple-base-string))
+ x)
+ (the (cons (or (and bit-vector (not simple-array))
+ (simple-array character (*))))
+ y))))
+ (list (string 'list))
+ (list "lisT")))))
+
+(with-test (:name (restart-case optimize speed compiler-note))
+ (handler-bind ((compiler-note #'error))
+ (compile nil '(lambda ()
+ (declare (optimize speed))
+ (restart-case () (c ()))))
+ (compile nil '(lambda ()
+ (declare (optimize speed))
+ (let (x)
+ (restart-case (setf x (car (compute-restarts)))
+ (c ()))
+ x)))))
+