;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
-;;;;
+;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
-(cl:in-package :cl-user)
+(when (eq sb-ext:*evaluator-mode* :interpret)
+ (sb-ext:quit :unix-status 104))
+(load "test-util.lisp")
(load "assertoid.lisp")
+(use-package "TEST-UTIL")
+(use-package "ASSERTOID")
;;; Old CMU CL code assumed that the names of "keyword" arguments are
;;; necessarily self-evaluating symbols, but ANSI Common Lisp allows
(let (num x)
(flet ((digs ()
(setq num index))
- (z ()
- (let ()
- (setq x nil))))
+ (z ()
+ (let ()
+ (setq x nil))))
(when (and (digs) (digs)) x))))
;;; Bug 132: The compiler used to fail to compile INTEGER-valued CATCH
(flet ((wufn () (glorp table1 4.9)))
(gleep *uustk* #'wufn "#1" (list)))
(if (eql (lo foomax 3.2))
- (values)
- (error "not ~S" '(eql (lo foomax 3.2))))
+ (values)
+ (error "not ~S" '(eql (lo foomax 3.2))))
(values)))
;;; A simpler test case for bug 150: The compiler died with the
;;; same type error when trying to compile this.
(defun bug147 (string ind)
(flet ((digs ()
(let (old-index)
- (if (and (< ind ind)
- (typep (char string ind) '(member #\1)))
- nil))))))
+ (if (and (< ind ind)
+ (typep (char string ind) '(member #\1)))
+ nil))))))
;;; bug reported and fixed by Matthias Hoelzl sbcl-devel 2002-05-13
(defmacro foo-2002-05-13 () ''x)
(defstruct something-known-to-be-a-struct x y)
(multiple-value-bind (fun warnings-p failure-p)
(compile nil
- '(lambda ()
- (labels ((a1 (a2 a3)
- (cond (t (a4 a2 a3))))
- (a4 (a2 a3 a5 a6)
- (declare (type (or simple-vector null) a5 a6))
- (something-known-to-be-a-struct-x a5))
- (a8 (a2 a3)
- (a9 #'a1 a10 a2 a3))
- (a11 (a2 a3)
- (cond ((and (funcall a12 a2)
- (funcall a12 a3))
- (funcall a13 a2 a3))
- (t
- (when a14
- (let ((a15 (a1 a2 a3)))
- ))
- a16))))
- (values #'a17 #'a11))))
+ '(lambda ()
+ (labels ((a1 (a2 a3)
+ (cond (t (a4 a2 a3))))
+ (a4 (a2 a3 a5 a6)
+ (declare (type (or simple-vector null) a5 a6))
+ (something-known-to-be-a-struct-x a5))
+ (a8 (a2 a3)
+ (a9 #'a1 a10 a2 a3))
+ (a11 (a2 a3)
+ (cond ((and (funcall a12 a2)
+ (funcall a12 a3))
+ (funcall a13 a2 a3))
+ (t
+ (when a14
+ (let ((a15 (a1 a2 a3)))
+ ))
+ a16))))
+ (values #'a17 #'a11))))
;; Python sees the structure accessor on the known-not-to-be-a-struct
;; A5 value and is very, very disappointed in you. (But it doesn't
;; signal BUG any more.)
;;; spotted and fixed by Raymond Toy for CMUCL)
(defun logand-sparc-bogons (a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
(declare (type (unsigned-byte 32) a0)
- (type (signed-byte 32) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
- ;; to ensure that the call is a candidate for
- ;; transformation
- (optimize (speed 3) (safety 0) (compilation-speed 0) (debug 0)))
+ (type (signed-byte 32) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
+ ;; to ensure that the call is a candidate for
+ ;; transformation
+ (optimize (speed 3) (safety 0) (compilation-speed 0) (debug 0)))
(values
;; the call that fails compilation
(logand a0 a10)
;;; except that there was no non-VOP definition of DATA-VECTOR-REF, so
;;; it would fail.
(defun bug192 ()
- (funcall
+ (funcall
(LAMBDA (TEXT I L )
(LABELS ((G908 (I)
(LET ((INDEX
(labels
((alpha-equal-bound-term-lists (listx listy)
(or (and (null listx) (null listy))
- (and listx listy
- (let ((bindings-x (bindings-of-bound-term (car listx)))
- (bindings-y (bindings-of-bound-term (car listy))))
- (if (and (null bindings-x) (null bindings-y))
- (alpha-equal-terms (term-of-bound-term (car listx))
- (term-of-bound-term (car listy)))
- (and (= (length bindings-x) (length bindings-y))
- (prog2
- (enter-binding-pairs (bindings-of-bound-term (car listx))
- (bindings-of-bound-term (car listy)))
- (alpha-equal-terms (term-of-bound-term (car listx))
- (term-of-bound-term (car listy)))
- (exit-binding-pairs (bindings-of-bound-term (car listx))
- (bindings-of-bound-term (car listy)))))))
- (alpha-equal-bound-term-lists (cdr listx) (cdr listy)))))
+ (and listx listy
+ (let ((bindings-x (bindings-of-bound-term (car listx)))
+ (bindings-y (bindings-of-bound-term (car listy))))
+ (if (and (null bindings-x) (null bindings-y))
+ (alpha-equal-terms (term-of-bound-term (car listx))
+ (term-of-bound-term (car listy)))
+ (and (= (length bindings-x) (length bindings-y))
+ (prog2
+ (enter-binding-pairs (bindings-of-bound-term (car listx))
+ (bindings-of-bound-term (car listy)))
+ (alpha-equal-terms (term-of-bound-term (car listx))
+ (term-of-bound-term (car listy)))
+ (exit-binding-pairs (bindings-of-bound-term (car listx))
+ (bindings-of-bound-term (car listy)))))))
+ (alpha-equal-bound-term-lists (cdr listx) (cdr listy)))))
(alpha-equal-terms (termx termy)
(if (and (variable-p termx)
- (variable-p termy))
- (equal-bindings (id-of-variable-term termx)
- (id-of-variable-term termy))
- (and (equal-operators-p (operator-of-term termx) (operator-of-term termy))
- (alpha-equal-bound-term-lists (bound-terms-of-term termx)
- (bound-terms-of-term termy))))))
+ (variable-p termy))
+ (equal-bindings (id-of-variable-term termx)
+ (id-of-variable-term termy))
+ (and (equal-operators-p (operator-of-term termx) (operator-of-term termy))
+ (alpha-equal-bound-term-lists (bound-terms-of-term termx)
+ (bound-terms-of-term termy))))))
(or (eq termx termy)
- (and termx termy
- (with-variable-invocation (alpha-equal-terms termx termy))))))
+ (and termx termy
+ (with-variable-invocation (alpha-equal-terms termx termy))))))
(defun bug65-2 () ; from Bob Rogers cmucl-imp 1999-07-28
;; Given an FSSP alignment file named by the argument . . .
(labels ((get-fssp-char ()
- (get-fssp-char))
- (read-fssp-char ()
- (get-fssp-char)))
+ (get-fssp-char))
+ (read-fssp-char ()
+ (get-fssp-char)))
;; Stub body, enough to tickle the bug.
(list (read-fssp-char)
- (read-fssp-char))))
+ (read-fssp-char))))
(defun bug70 ; from David Young cmucl-help 30 Nov 2000
(item sequence &key (test #'eql))
(labels ((find-item (obj seq test &optional (val nil))
- (let ((item (first seq)))
- (cond ((null seq)
- (values nil nil))
- ((funcall test obj item)
- (values val seq))
- (t
- (find-item obj
- (rest seq)
- test
- (nconc val `(,item))))))))
+ (let ((item (first seq)))
+ (cond ((null seq)
+ (values nil nil))
+ ((funcall test obj item)
+ (values val seq))
+ (t
+ (find-item obj
+ (rest seq)
+ test
+ (nconc val `(,item))))))))
(find-item item sequence test)))
(defun bug109 () ; originally from CMU CL bugs collection, reported as
; SBCL bug by MNA 2001-06-25
- (labels
+ (labels
((eff (&key trouble)
- (eff)
- ;; nil
- ;; Uncomment and it works
- ))
+ (eff)
+ ;; nil
+ ;; Uncomment and it works
+ ))
(eff)))
;;; bug 192a, fixed by APD "more strict type checking" patch
;;; bug 194, fixed in part by APD "more strict type checking" patch
;;; (sbcl-devel 2002-08-07)
(progn
- #+nil ; FIXME: still broken in 0.7.7.19 (after patch)
(multiple-value-bind (result error)
(ignore-errors (multiple-value-prog1 (progn (the real '(1 2 3)))))
(assert (null result))
(assert (typep error 'type-error)))
- #+nil ; FIXME: still broken in 0.7.7.19 (after patch)
(multiple-value-bind (result error)
(ignore-errors (the real '(1 2 3)))
(assert (null result))
(assert (typep error 'type-error))))
+
+(defun bug194d ()
+ (null (ignore-errors
+ (let ((arg1 1)
+ (arg2 (identity (the real #(1 2 3)))))
+ (if (< arg1 arg2) arg1 arg2)))))
+(assert (eq (bug194d) t))
+
\f
;;; BUG 48a. and b. (symbol-macrolet handling), fixed by Eric Marsden
;;; and Raymond Toy for CMUCL, fix ported for sbcl-0.7.6.18.
(multiple-value-bind (function warnings-p failure-p)
- (compile nil '(lambda () (symbol-macrolet ((t nil)) t)))
+ (compile nil '(lambda ()
+ ;; not interested in the package lock violation here
+ (declare (sb-ext:disable-package-locks t))
+ (symbol-macrolet ((t nil)) t)))
(assert failure-p)
(assert (raises-error? (funcall function) program-error)))
(multiple-value-bind (function warnings-p failure-p)
(compile nil
- '(lambda ()
- (symbol-macrolet ((*standard-input* nil))
- *standard-input*)))
+ '(lambda ()
+ ;; not interested in the package lock violation here
+ (declare (sb-ext:disable-package-locks *standard-input*))
+ (symbol-macrolet ((*standard-input* nil))
+ *standard-input*)))
(assert failure-p)
(assert (raises-error? (funcall function) program-error)))
-#||
-BUG 48c, not yet fixed:
(multiple-value-bind (function warnings-p failure-p)
(compile nil '(lambda () (symbol-macrolet ((s nil)) (declare (special s)) s)))
(assert failure-p)
(assert (raises-error? (funcall function) program-error)))
-||#
\f
;;; bug 120a: Turned out to be constraining code looking like (if foo
;;; <X> <X>) where <X> was optimized by the compiler to be the exact
(declare (optimize (speed 3) (safety 1) (debug 1)))
(if x t (if y t (dont-constrain-if-too-much x y))))
-(assert (null (dont-constrain-if-too-much-aux nil nil)))
+(assert (null (dont-constrain-if-too-much-aux nil nil)))
;;; TYPE-ERROR confusion ca. sbcl-0.7.7.24, reported and fixed by
;;; APD sbcl-devel 2002-09-14
(declare (ignore result))
(assert (typep condition 'type-error)))
-;;; bug 110: the compiler flushed the argument type test and the default
-;;; case in the cond.
+;;;; bug 110: the compiler flushed the argument type test and the default
+;;;; case in the cond.
+;
+;(locally (declare (optimize (safety 3) (speed 2)))
+; (defun bug110 (x)
+; (declare (optimize (safety 2) (speed 3)))
+; (declare (type (or string stream) x))
+; (cond ((typep x 'string) 'string)
+; ((typep x 'stream) 'stream)
+; (t
+; 'none))))
+;
+;(multiple-value-bind (result condition)
+; (ignore-errors (bug110 0))
+; (declare (ignore result))
+; (assert (typep condition 'type-error)))
-(defun bug110 (x)
- (declare (optimize (safety 2) (speed 3)))
- (declare (type (or string stream) x))
- (cond ((typep x 'string) 'string)
- ((typep x 'stream) 'stream)
- (t
- 'none)))
+;;; bug 202: the compiler failed to compile a function, which derived
+;;; type contradicted declared.
+(declaim (ftype (function () null) bug202))
+(defun bug202 ()
+ t)
-(multiple-value-bind (result condition)
- (ignore-errors (bug110 0))
- (declare (ignore result))
- (assert (typep condition 'type-error)))
+;;; bugs 178, 199: compiler failed to compile a call of a function
+;;; with a hairy type
+(defun bug178 (x)
+ (funcall (the function (the standard-object x))))
+
+(defun bug199-aux (f)
+ (eq nil (funcall f)))
+
+(defun bug199 (f x)
+ (declare (type (and function (satisfies bug199-aux)) f))
+ (funcall f x))
+
+;;; check non-toplevel DEFMACRO
+(defvar *defmacro-test-status* nil)
+
+(defun defmacro-test ()
+ (fmakunbound 'defmacro-test-aux)
+ (let* ((src "defmacro-test.lisp")
+ (obj (compile-file-pathname src)))
+ (unwind-protect
+ (progn
+ (compile-file src)
+ (assert (equal *defmacro-test-status* '(function a)))
+ (setq *defmacro-test-status* nil)
+ (load obj)
+ (assert (equal *defmacro-test-status* nil))
+ (macroexpand '(defmacro-test-aux 'a))
+ (assert (equal *defmacro-test-status* '(macro 'a z-value)))
+ (eval '(defmacro-test-aux 'a))
+ (assert (equal *defmacro-test-status* '(expanded 'a z-value))))
+ (ignore-errors (delete-file obj)))))
+
+(defmacro-test)
+
+;;; bug 204: EVAL-WHEN inside a local environment
+(defvar *bug204-test-status*)
+
+(defun bug204-test ()
+ (let* ((src "bug204-test.lisp")
+ (obj (compile-file-pathname src)))
+ (unwind-protect
+ (progn
+ (setq *bug204-test-status* nil)
+ (compile-file src)
+ (assert (equal *bug204-test-status* '((:expanded :load-toplevel)
+ (:called :compile-toplevel)
+ (:expanded :compile-toplevel))))
+ (setq *bug204-test-status* nil)
+ (load obj)
+ (assert (equal *bug204-test-status* '((:called :load-toplevel)))))
+ (ignore-errors (delete-file obj)))))
+
+(bug204-test)
+
+;;; toplevel SYMBOL-MACROLET
+(defvar *symbol-macrolet-test-status*)
+
+(defun symbol-macrolet-test ()
+ (let* ((src "symbol-macrolet-test.lisp")
+ (obj (compile-file-pathname src)))
+ (unwind-protect
+ (progn
+ (setq *symbol-macrolet-test-status* nil)
+ (compile-file src)
+ (assert (equal *symbol-macrolet-test-status*
+ '(2 1)))
+ (setq *symbol-macrolet-test-status* nil)
+ (load obj)
+ (assert (equal *symbol-macrolet-test-status* '(2))))
+ (ignore-errors (delete-file obj)))))
+
+(symbol-macrolet-test)
+
+;;; On the x86, this code failed to compile until sbcl-0.7.8.37:
+(defun x86-assembler-failure (x)
+ (declare (optimize (speed 3) (safety 0)))
+ (eq (setf (car x) 'a) nil))
+
+;;; bug 211: :ALLOW-OTHER-KEYS
+(defun bug211d (&key (x :x x-p) ((:allow-other-keys y) :y y-p))
+ (list x x-p y y-p))
+
+(assert (equal (bug211d) '(:x nil :y nil)))
+(assert (equal (bug211d :x 1) '(1 t :y nil)))
+(assert (raises-error? (bug211d :y 2) program-error))
+(assert (equal (bug211d :y 2 :allow-other-keys t :allow-other-keys nil)
+ '(:x nil t t)))
+(assert (raises-error? (bug211d :y 2 :allow-other-keys nil) program-error))
+
+(let ((failure-p
+ (nth-value
+ 3
+ (compile 'bug211b
+ '(lambda ()
+ (flet ((test (&key (x :x x-p) ((:allow-other-keys y) :y y-p))
+ (list x x-p y y-p)))
+ (assert (equal (test) '(:x nil :y nil)))
+ (assert (equal (test :x 1) '(1 t :y nil)))
+ (assert (equal (test :y 2 :allow-other-keys 11 :allow-other-keys nil)
+ '(:x nil 11 t)))))))))
+ (assert (not failure-p))
+ (bug211b))
+
+(let ((failure-p
+ (nth-value
+ 3
+ (compile 'bug211c
+ '(lambda ()
+ (flet ((test (&key (x :x x-p))
+ (list x x-p)))
+ (assert (equal (test) '(:x nil)))
+ (assert (equal (test :x 1) '(1 t)))
+ (assert (equal (test :y 2 :allow-other-keys 11 :allow-other-keys nil)
+ '(:x nil)))))))))
+ (assert (not failure-p))
+ (bug211c))
+
+(dolist (form '((test :y 2)
+ (test :y 2 :allow-other-keys nil)
+ (test :y 2 :allow-other-keys nil :allow-other-keys t)))
+ (multiple-value-bind (result warnings-p failure-p)
+ (compile nil `(lambda ()
+ (flet ((test (&key (x :x x-p) ((:allow-other-keys y) :y y-p))
+ (list x x-p y y-p)))
+ ,form)))
+ (assert failure-p)
+ (assert (raises-error? (funcall result) program-error))))
+
+;;; bug 217: wrong type inference
+(defun bug217-1 (x s)
+ (let ((f (etypecase x
+ (character #'write-char)
+ (integer #'write-byte))))
+ (funcall f x s)
+ (etypecase x
+ (character (write-char x s))
+ (integer (write-byte x s)))))
+(bug217-1 #\1 *standard-output*)
+
+
+;;; bug 221: tried and died on CSUBTYPEP (not VALUES-SUBTYPEP) of the
+;;; function return types when inferring the type of the IF expression
+(declaim (ftype (function (fixnum) (values package boolean)) bug221f1))
+(declaim (ftype (function (t) (values package boolean)) bug221f2))
+(defun bug221 (b x)
+ (funcall (if b #'bug221f1 #'bug221f2) x))
+\f
+;;; bug 172: macro lambda lists were too permissive until 0.7.9.28
+;;; (fix provided by Matthew Danish) on sbcl-devel
+(assert (null (ignore-errors
+ (defmacro bug172 (&rest rest foo) `(list ,rest ,foo)))))
+
+;;; embedded THEs
+(defun check-embedded-thes (policy1 policy2 x y)
+ (handler-case
+ (funcall (compile nil
+ `(lambda (f)
+ (declare (optimize (speed 2) (safety ,policy1)))
+ (multiple-value-list
+ (the (values (integer 2 3) t &optional)
+ (locally (declare (optimize (safety ,policy2)))
+ (the (values t (single-float 2f0 3f0) &optional)
+ (funcall f)))))))
+ (lambda () (values x y)))
+ (type-error (error)
+ error)))
+
+(assert (equal (check-embedded-thes 0 0 :a :b) '(:a :b)))
+
+(assert (equal (check-embedded-thes 0 3 :a 2.5f0) '(:a 2.5f0)))
+(assert (typep (check-embedded-thes 0 3 2 3.5f0) 'type-error))
+
+(assert (equal (check-embedded-thes 0 1 :a 3.5f0) '(:a 3.5f0)))
+(assert (typep (check-embedded-thes 0 1 2 2.5d0) 'type-error))
+
+(assert (equal (check-embedded-thes 3 0 2 :a) '(2 :a)))
+(assert (typep (check-embedded-thes 3 0 4 2.5f0) 'type-error))
+
+(assert (equal (check-embedded-thes 1 0 4 :b) '(4 :b)))
+(assert (typep (check-embedded-thes 1 0 1.0 2.5f0) 'type-error))
+
+
+(assert (equal (check-embedded-thes 3 3 2 2.5f0) '(2 2.5f0)))
+(assert (typep (check-embedded-thes 3 3 0 2.5f0) 'type-error))
+(assert (typep (check-embedded-thes 3 3 2 3.5f0) 'type-error))
+\f
+;;; INLINE inside MACROLET
+(declaim (inline to-be-inlined))
+(macrolet ((def (x) `(defun ,x (y) (+ y 1))))
+ (def to-be-inlined))
+(defun call-inlined (z)
+ (to-be-inlined z))
+(assert (= (call-inlined 3) 4))
+(macrolet ((frob (x) `(+ ,x 3)))
+ (defun to-be-inlined (y)
+ (frob y)))
+(assert (= (call-inlined 3)
+ ;; we should have inlined the previous definition, so the
+ ;; new one won't show up yet.
+ 4))
+(defun call-inlined (z)
+ (to-be-inlined z))
+(assert (= (call-inlined 3) 6))
+(defun to-be-inlined (y)
+ (+ y 5))
+(assert (= (call-inlined 3) 6))
+\f
+;;; DEFINE-COMPILER-MACRO to work as expected, not via weird magical
+;;; IR1 pseudo-:COMPILE-TOPLEVEL handling
+(defvar *bug219-a-expanded-p* nil)
+(defun bug219-a (x)
+ (+ x 1))
+(define-compiler-macro bug219-a (&whole form y)
+ (setf *bug219-a-expanded-p* t)
+ (if (constantp y)
+ (+ (eval y) 2)
+ form))
+(defun bug219-a-aux ()
+ (bug219-a 2))
+(assert (= (bug219-a-aux)
+ (if *bug219-a-expanded-p* 4 3)))
+(defvar *bug219-a-temp* 3)
+(assert (= (bug219-a *bug219-a-temp*) 4))
+
+(defvar *bug219-b-expanded-p* nil)
+(defun bug219-b-aux1 (x)
+ (when x
+ (define-compiler-macro bug219-b (y)
+ (setf *bug219-b-expanded-p* t)
+ `(+ ,y 2))))
+(defun bug219-b-aux2 (z)
+ (bug219-b z))
+(assert (not *bug219-b-expanded-p*))
+(assert (raises-error? (bug219-b-aux2 1) undefined-function))
+(bug219-b-aux1 t)
+(defun bug219-b-aux2 (z)
+ (bug219-b z))
+(defun bug219-b (x)
+ x)
+(assert (= (bug219-b-aux2 1)
+ (if *bug219-b-expanded-p* 3 1)))
+
+;;; bug 224: failure in unreachable code deletion
+(defmacro do-optimizations (&body body)
+ `(dotimes (.speed. 4)
+ (dotimes (.space. 4)
+ (dotimes (.debug. 4)
+ (dotimes (.compilation-speed. 4)
+ (proclaim `(optimize (speed , .speed.) (space , .space.)
+ (debug , .debug.)
+ (compilation-speed , .compilation-speed.)))
+ ,@body)))))
+
+(do-optimizations
+ (compile nil
+ (read-from-string
+ "(lambda () (#:localy (declare (optimize (safety 3)))
+ (ignore-errors (progn (values-list (car (list '(1 . 2)))) t))))")))
+
+(do-optimizations
+ (compile nil '(lambda ()
+ (labels ((ext ()
+ (tagbody
+ (labels ((i1 () (list (i2) (i2)))
+ (i2 () (list (int) (i1)))
+ (int () (go :exit)))
+ (list (i1) (i1) (i1)))
+ :exit (return-from ext)
+ )))
+ (list (error "nih") (ext) (ext))))))
+
+(do-optimizations
+ (compile nil '(lambda (x) (let ((y (error ""))) (list x y)))))
+
+;;; bug 223: invalid moving of global function name referencing
+(defun bug223-int (n)
+ `(int ,n))
+
+(defun bug223-wrap ()
+ (let ((old #'bug223-int))
+ (setf (fdefinition 'bug223-int)
+ (lambda (n)
+ (assert (> n 0))
+ `(ext ,@(funcall old (1- n)))))))
+(compile 'bug223-wrap)
+
+(assert (equal (bug223-int 4) '(int 4)))
+(bug223-wrap)
+(assert (equal (bug223-int 4) '(ext int 3)))
+(bug223-wrap)
+(assert (equal (bug223-int 4) '(ext ext int 2)))
+\f
+;;; COERCE got its own DEFOPTIMIZER which has to reimplement most of
+;;; SPECIFIER-TYPE-NTH-ARG. For a while, an illegal type would throw
+;;; you into the debugger on compilation.
+(defun coerce-defopt1 (x)
+ ;; illegal, but should be compilable.
+ (coerce x '(values t)))
+(defun coerce-defopt2 (x)
+ ;; illegal, but should be compilable.
+ (coerce x '(values t &optional)))
+(assert (null (ignore-errors (coerce-defopt1 3))))
+(assert (null (ignore-errors (coerce-defopt2 3))))
+\f
+;;; Oops. In part of the (CATCH ..) implementation of DEBUG-RETURN,
+;;; it was possible to confuse the type deriver of the compiler
+;;; sufficiently that compiler invariants were broken (explained by
+;;; APD sbcl-devel 2003-01-11).
+
+;;; WHN's original report
+(defun debug-return-catch-break1 ()
+ (with-open-file (s "/tmp/foo"
+ :direction :output
+ :element-type (list
+ 'signed-byte
+ (1+
+ (integer-length most-positive-fixnum))))
+ (read-byte s)
+ (read-byte s)
+ (read-byte s)
+ (read-byte s)))
+
+;;; APD's simplified test case
+(defun debug-return-catch-break2 (x)
+ (declare (type (vector (unsigned-byte 8)) x))
+ (setq *y* (the (unsigned-byte 8) (aref x 4))))
+\f
+;;; FUNCTION-LAMBDA-EXPRESSION should return something that's COMPILE
+;;; can understand. Here's a simple test for that on a function
+;;; that's likely to return a hairier list than just a lambda:
+(macrolet ((def (fn) `(progn
+ (declaim (inline ,fn))
+ (defun ,fn (x) (1+ x)))))
+ (def bug228))
+(let ((x (function-lambda-expression #'bug228)))
+ (when x
+ (assert (= (funcall (compile nil x) 1) 2))))
+
+;;;
+(defun bug192b (i)
+ (dotimes (j i)
+ (declare (type (mod 4) i))
+ (unless (< i 5)
+ (print j))))
+(assert (raises-error? (bug192b 6) type-error))
+
+(defun bug192c (x y)
+ (locally (declare (type fixnum x y))
+ (+ x (* 2 y))))
+(assert (raises-error? (bug192c 1.1 2) type-error))
+
+(assert (raises-error? (progn (the real (list 1)) t) type-error))
+
+(defun bug236 (a f)
+ (declare (optimize (speed 2) (safety 0)))
+ (+ 1d0
+ (the double-float
+ (multiple-value-prog1
+ (svref a 0)
+ (unless f (return-from bug236 0))))))
+(assert (eql (bug236 #(4) nil) 0))
+
+;;; Bug reported by reported by rif on c.l.l 2003-03-05
+(defun test-type-of-special-1 (x)
+ (declare (special x)
+ (fixnum x)
+ (optimize (safety 3)))
+ (list x))
+(defun test-type-of-special-2 (x)
+ (declare (special x)
+ (fixnum x)
+ (optimize (safety 3)))
+ (list x (setq x (/ x 2)) x))
+(assert (raises-error? (test-type-of-special-1 3/2) type-error))
+(assert (raises-error? (test-type-of-special-2 3) type-error))
+(assert (equal (test-type-of-special-2 8) '(8 4 4)))
+
+;;; bug which existed in 0.8alpha.0.4 for several milliseconds before
+;;; APD fixed it in 0.8alpha.0.5
+(defun frob8alpha04 (x y)
+ (+ x y))
+(defun baz8alpha04 (this kids)
+ (flet ((n-i (&rest rest)
+ ;; Removing the #+NIL here makes the bug go away.
+ #+nil (format t "~&in N-I REST=~S~%" rest)
+ (apply #'frob8alpha04 this rest)))
+ (n-i kids)))
+;;; failed in 0.8alpha.0.4 with "The value 13 is not of type LIST."
+(assert (= (baz8alpha04 12 13) 25))
+
+;;; evaluation order in structure slot writers
+(defstruct sswo
+ a b)
+(let* ((i 0)
+ (s (make-sswo :a (incf i) :b (incf i)))
+ (l (list s :v)))
+ (assert (= (sswo-a s) 1))
+ (assert (= (sswo-b s) 2))
+ (setf (sswo-a (pop l)) (pop l))
+ (assert (eq l nil))
+ (assert (eq (sswo-a s) :v)))
+
+(defun bug249 (x)
+ (flet ((bar (y)
+ (declare (fixnum y))
+ (incf x)))
+ (list (bar x) (bar x) (bar x))))
+
+(assert (raises-error? (bug249 1.0) type-error))
+
+;;; bug reported by ohler on #lisp 2003-07-10
+(defun bug-ohler-2003-07-10 (a b)
+ (declare (optimize (speed 0) (safety 3) (space 0)
+ (debug 1) (compilation-speed 0)))
+ (adjoin a b))
+
+;;; bug reported by Doug McNaught on sbcl-devel 2003-09-14:
+;;; COMPILE-FILE did not bind *READTABLE*
+(let* ((source "bug-doug-mcnaught-20030914.lisp")
+ (fasl (compile-file-pathname source)))
+ (labels ((check ()
+ (assert (null (get-macro-character #\]))))
+ (full-check ()
+ (check)
+ (assert (typep *bug-doug-mcnaught-20030914*
+ '(simple-array (unsigned-byte 4) (*))))
+ (assert (equalp *bug-doug-mcnaught-20030914* #(1 2 3)))
+ (makunbound '*bug-doug-mcnaught-20030914*)))
+ (compile-file source)
+ (check)
+ (load fasl)
+ (full-check)
+ (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)
+#-(or alpha x86-64) ; FIXME: make a better test!
+(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
+(handler-case
+ (eval '(flet ((%f (&key) nil)) (%f nil nil)))
+ (error (c) :good)
+ (:no-error (val) (error "no error: ~S" val)))
+(handler-case
+ (eval '(labels ((%f (&key x) x)) (%f nil nil)))
+ (error (c) :good)
+ (:no-error (val) (error "no error: ~S" val)))
+
+;;; PROGV must not bind constants, or violate declared types -- ditto for SET.
+(assert (raises-error? (set pi 3)))
+(assert (raises-error? (progv '(pi s) '(3 pi) (symbol-value x))))
+(declaim (cons *special-cons*))
+(assert (raises-error? (set '*special-cons* "nope") type-error))
+(assert (raises-error? (progv '(*special-cons*) '("no hope") (car *special-cons*)) type-error))
+
+;;; No bogus warnings for calls to functions with complex lambda-lists.
+(defun complex-function-signature (&optional x &rest y &key z1 z2)
+ (cons x y))
+(with-test (:name :complex-call-doesnt-warn)
+ (handler-bind ((warning #'error))
+ (compile nil '(lambda (x) (complex-function-signature x :z1 1 :z2 2)))))
+
+(with-test (:name :non-required-args-update-info)
+ (let ((name (gensym "NON-REQUIRE-ARGS-TEST"))
+ (*evaluator-mode* :compile))
+ (eval `(defun ,name (x) x))
+ (assert (equal '(function (t) (values t &optional))
+ (sb-kernel:type-specifier (sb-int:info :function :type name))))
+ (eval `(defun ,name (x &optional y) (or x y)))
+ (assert (equal '(function (t &optional t) (values t &optional))
+ (sb-kernel:type-specifier (sb-int:info :function :type name))))))
+
+;;;; inline & maybe inline nested calls
+
+(defun quux-marker (x) x)
+(declaim (inline foo-inline))
+(defun foo-inline (x) (quux-marker x))
+(declaim (maybe-inline foo-maybe-inline))
+(defun foo-maybe-inline (x) (quux-marker x))
+;; Pretty horrible, but does the job
+(defun count-full-calls (name function)
+ (let ((code (with-output-to-string (s)
+ (disassemble function :stream s)))
+ (n 0))
+ (with-input-from-string (s code)
+ (loop for line = (read-line s nil nil)
+ while line
+ when (search name line)
+ do (incf n)))
+ n))
+
+(with-test (:name :nested-inline-calls)
+ (let ((fun (compile nil `(lambda (x)
+ (foo-inline (foo-inline (foo-inline x)))))))
+ (assert (= 0 (count-full-calls "FOO-INLINE" fun)))
+ (assert (= 3 (count-full-calls "QUUX-MARKER" fun)))))
+
+(with-test (:name :nested-maybe-inline-calls)
+ (let ((fun (compile nil `(lambda (x)
+ (declare (optimize (space 0)))
+ (foo-maybe-inline (foo-maybe-inline (foo-maybe-inline x)))))))
+ (assert (= 0 (count-full-calls "FOO-MAYBE-INLINE" fun)))
+ (assert (= 1 (count-full-calls "QUUX-MARKER" fun)))))
+
+(with-test (:name :inline-calls)
+ (let ((fun (compile nil `(lambda (x)
+ (list (foo-inline x)
+ (foo-inline x)
+ (foo-inline x))))))
+ (assert (= 0 (count-full-calls "FOO-INLINE" fun)))
+ (assert (= 3 (count-full-calls "QUUX-MARKER" fun)))))
+
+(with-test (:name :maybe-inline-calls)
+ (let ((fun (compile nil `(lambda (x)
+ (declare (optimize (space 0)))
+ (list (foo-maybe-inline x)
+ (foo-maybe-inline x)
+ (foo-maybe-inline x))))))
+ (assert (= 0 (count-full-calls "FOO-MAYBE-INLINE" fun)))
+ (assert (= 1 (count-full-calls "QUUX-MARKER" fun)))))
+
+(defun file-compile (toplevel-forms &key load)
+ (let* ((lisp "compile-impure-tmp.lisp")
+ (fasl (compile-file-pathname lisp)))
+ (unwind-protect
+ (progn
+ (with-open-file (f lisp :direction :output)
+ (dolist (form toplevel-forms)
+ (prin1 form f)))
+ (multiple-value-bind (fasl warn fail) (compile-file lisp)
+ (when load
+ (load fasl))
+ (values warn fail)))
+ (ignore-errors (delete-file lisp))
+ (ignore-errors (delete-file fasl)))))
+
+(with-test (:name :bug-405)
+ ;; These used to break with a TYPE-ERROR
+ ;; The value NIL is not of type SB-C::PHYSENV.
+ ;; in MERGE-LETS.
+ (file-compile
+ '((LET (outer-let-var)
+ (lambda ()
+ (print outer-let-var)
+ (MULTIPLE-VALUE-CALL 'some-function
+ (MULTIPLE-VALUE-CALL (LAMBDA (a) 'foo)
+ 1))))))
+ (file-compile
+ '((declaim (optimize (debug 3)))
+ (defstruct bug-405-foo bar)
+ (let ()
+ (flet ((i (x) (frob x (bug-405-foo-bar foo))))
+ (i :five))))))
+
+;;; bug 235a
+(declaim (ftype (function (cons) number) bug-235a-aux))
+(declaim (inline bug-235a-aux))
+(defun bug-235a-aux (c)
+ (the number (car c)))
+(with-test (:name :bug-235a)
+ (let ((fun (compile nil
+ `(lambda (x y)
+ (values (locally (declare (optimize (safety 0)))
+ (bug-235a-aux x))
+ (locally (declare (optimize (safety 3)))
+ (bug-235a-aux y)))))))
+ (assert
+ (eq :error
+ (handler-case
+ (funcall fun '(:one) '(:two))
+ (type-error (e)
+ (assert (eq :two (type-error-datum e)))
+ (assert (eq 'number (type-error-expected-type e)))
+ :error))))))
+
+(with-test (:name :compiled-debug-funs-leak)
+ (sb-ext:gc :full t)
+ (let ((usage-before (sb-kernel::dynamic-usage)))
+ (dotimes (x 10000)
+ (let ((f (compile nil '(lambda ()
+ (error "X")))))
+ (handler-case
+ (funcall f)
+ (error () nil))))
+ (sb-ext:gc :full t)
+ (let ((usage-after (sb-kernel::dynamic-usage)))
+ (when (< (+ usage-before 2000000) usage-after)
+ (error "Leak")))))
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
(dolist (template (fun-info-templates (info :function :info function)))
(when (template-more-results-type template)
(format t "~&Template ~A has :MORE results, and translates ~A.~%"
- (template-name template)
- function)
+ (template-name template)
+ function)
(return nil))
(when (eq (template-result-types template) :conditional)
;; dunno.
(return t))
(let ((types (template-result-types template))
- (result-type (fun-type-returns (info :function :type function))))
+ (result-type (fun-type-returns (info :function :type function))))
(cond
- ((values-type-p result-type)
- (do ((ltypes (append (args-type-required result-type)
- (args-type-optional result-type))
- (rest ltypes))
- (types types (rest types)))
- ((null ltypes)
- (unless (null types)
- (format t "~&More types than ltypes in ~A, translating ~A.~%"
- (template-name template)
- function)
- (return nil)))
- (when (null types)
- (unless (null ltypes)
- (format t "~&More ltypes than types in ~A, translating ~A.~%"
- (template-name template)
- function)
- (return nil)))))
- ((eq result-type (specifier-type nil))
- (unless (null types)
- (format t "~&Template ~A returns values for function ~A with RESULT-TYPE NIL.~%"
- (template-name template)
- function)
- (return nil)))
- ((/= (length types) 1)
- (format t "~&Template ~A isn't returning 1 value for ~A.~%"
- (template-name template)
- function)
- (return nil))
- (t t)))))
+ ((values-type-p result-type)
+ (do ((ltypes (append (args-type-required result-type)
+ (args-type-optional result-type))
+ (rest ltypes))
+ (types types (rest types)))
+ ((null ltypes)
+ (unless (null types)
+ (format t "~&More types than ltypes in ~A, translating ~A.~%"
+ (template-name template)
+ function)
+ (return nil)))
+ (when (null types)
+ (unless (null ltypes)
+ (format t "~&More ltypes than types in ~A, translating ~A.~%"
+ (template-name template)
+ function)
+ (return nil)))))
+ ((eq result-type (specifier-type nil))
+ (unless (null types)
+ (format t "~&Template ~A returns values for function ~A with RESULT-TYPE NIL.~%"
+ (template-name template)
+ function)
+ (return nil)))
+ ((/= (length types) 1)
+ (format t "~&Template ~A isn't returning 1 value for ~A.~%"
+ (template-name template)
+ function)
+ (return nil))
+ (t t)))))
(defun identify-suspect-vops (&optional (env (first
- (last *info-environment*))))
+ (last *info-environment*))))
(do-info (env :class class :type type :name name :value value)
(when (and (eq class :function) (eq type :type))
;; OK, so we have an entry in the INFO database. Now, if ...
(let* ((info (info :function :info name))
- (templates (and info (fun-info-templates info))))
- (when templates
- ;; ... it has translators
- (grovel-results name))))))
+ (templates (and info (fun-info-templates info))))
+ (when templates
+ ;; ... it has translators
+ (grovel-results name))))))
(identify-suspect-vops)
\f
+;;;; tests for compiler output
+(let* ((*error-output* (make-broadcast-stream))
+ (output (with-output-to-string (*standard-output*)
+ (compile-file "compiler-output-test.lisp"
+ :print nil :verbose nil))))
+ (print output)
+ (assert (zerop (length output))))
+
+;;;; bug 305: INLINE/NOTINLINE causing local ftype to be lost
+
+(define-condition optimization-error (error) ())
+
+(labels ((compile-lambda (type sense)
+ (handler-bind ((compiler-note (lambda (_)
+ (declare (ignore _))
+ (error 'optimization-error))))
+ (values
+ (compile
+ nil
+ `(lambda ()
+ (declare
+ ,@(when type '((ftype (function () (integer 0 10)) bug-305)))
+ (,sense bug-305)
+ (optimize speed))
+ (1+ (bug-305))))
+ nil)))
+ (expect-error (sense)
+ (multiple-value-bind (f e) (ignore-errors (compile-lambda nil sense))
+ (assert (not f))
+ (assert (typep e 'optimization-error))))
+ (expect-pass (sense)
+ (multiple-value-bind (f e) (ignore-errors (compile-lambda t sense))
+ (assert f)
+ (assert (not e)))))
+ (expect-error 'inline)
+ (expect-error 'notinline)
+ (expect-pass 'inline)
+ (expect-pass 'notinline))
+
+;;; bug 211e: bogus style warning from duplicated keyword argument to
+;;; a local function.
+(handler-bind ((style-warning #'error))
+ (let ((f (compile nil '(lambda ()
+ (flet ((foo (&key y) (list y)))
+ (list (foo :y 1 :y 2)))))))
+ (assert (equal '((1)) (funcall f)))))
+
+;;; check that EQL is optimized when other argument is (OR SYMBOL FIXNUM).
+(handler-bind ((compiler-note #'error))
+ (let ((f1 (compile nil '(lambda (x1 y1)
+ (declare (type (or symbol fixnum) x1)
+ (optimize speed))
+ (eql x1 y1))))
+ (f2 (compile nil '(lambda (x2 y2)
+ (declare (type (or symbol fixnum) y2)
+ (optimize speed))
+ (eql x2 y2)))))
+ (let ((fix (random most-positive-fixnum))
+ (sym (gensym))
+ (e-count 0))
+ (assert (funcall f1 fix fix))
+ (assert (funcall f2 fix fix))
+ (assert (funcall f1 sym sym))
+ (assert (funcall f2 sym sym))
+ (handler-bind ((type-error (lambda (c)
+ (incf e-count)
+ (continue c))))
+ (flet ((test (f x y)
+ (with-simple-restart (continue "continue with next test")
+ (funcall f x y)
+ (error "fell through with (~S ~S ~S)" f x y))))
+ (test f1 "oops" 42)
+ (test f1 (1+ most-positive-fixnum) 42)
+ (test f2 42 "oops")
+ (test f2 42 (1+ most-positive-fixnum))))
+ (assert (= e-count 4)))))
+
+;;; bug #389 (Rick Taube sbcl-devel)
+(defun bes-jn (unn ux)
+ (let ((nn unn) (x ux))
+ (let* ((n (floor (abs nn)))
+ (besn
+ (if (= n 0)
+ (bes-j0 x)
+ (if (= n 1)
+ (bes-j1 x)
+ (if (zerop x)
+ 0.0
+ (let ((iacc 40)
+ (ans 0.0)
+ (bigno 1.0e+10)
+ (bigni 1.0e-10))
+ (if (> (abs x) n)
+ (do ((tox (/ 2.0 (abs x)))
+ (bjm (bes-j0 (abs x)))
+ (bj (bes-j1 (abs x)))
+ (j 1 (+ j 1))
+ (bjp 0.0))
+ ((= j n) (setf ans bj))
+ (setf bjp (- (* j tox bj) bjm))
+ (setf bjm bj)
+ (setf bj bjp))
+ (let ((tox (/ 2.0 (abs x)))
+ (m
+ (* 2
+ (floor
+ (/ (+ n (sqrt (* iacc n)))
+ 2))))
+ (jsum 0.0)
+ (bjm 0.0)
+ (sum 0.0)
+ (bjp 0.0)
+ (bj 1.0))
+ (do ((j m (- j 1)))
+ ((= j 0))
+ (setf bjm (- (* j tox bj) bjp))
+ (setf bjp bj)
+ (setf bj bjm)
+ (when (> (abs bj) bigno)
+ (setf bj (* bj bigni))
+ (setf bjp (* bjp bigni))
+ (setf ans (* ans bigni))
+ (setf sum (* sum bigni)))
+ (if (not (= 0 jsum)) (incf sum bj))
+ (setf jsum (- 1 jsum))
+ (if (= j n) (setf ans bjp)))
+ (setf sum (- (* 2.0 sum) bj))
+ (setf ans (/ ans sum))))
+ (if (and (minusp x) (oddp n))
+ (- ans)
+ ans)))))))
+ (if (and (minusp nn) (oddp nn)) (- besn) besn))))
+
+
+;;; bug 233b: lvar lambda-var equality in constraint propagation
+
+;; Put this in a separate function.
+(defun test-constraint-propagation/ref ()
+ (let ((x nil))
+ (if (multiple-value-prog1 x (setq x t))
+ 1
+ x)))
+
+(test-util:with-test (:name (:compiler :constraint-propagation :ref))
+ (assert (eq t (test-constraint-propagation/ref))))
+
+;; Put this in a separate function.
+(defun test-constraint-propagation/typep (x y)
+ (if (typep (multiple-value-prog1 x (setq x y))
+ 'double-float)
+ (+ x 1d0)
+ (+ x 2)))
+
+(test-util:with-test (:name (:compiler :constraint-propagation :typep))
+ (assert (= 6.0d0 (test-constraint-propagation/typep 1d0 5))))
+
+(test-util:with-test (:name (:compiler :constraint-propagation :eq/eql))
+ (assert (eq :right (let ((c :wrong))
+ (if (eq (let ((x c))
+ (setq c :right)
+ x)
+ :wrong)
+ c
+ 0)))))
+
+;;; Put this in a separate function.
+(defun test-constraint-propagation/cast (x)
+ (when (the double-float (multiple-value-prog1
+ x
+ (setq x (1+ x))))
+ x))
+
+(test-util:with-test (:name (:compiler :constraint-propagation :cast))
+ (assert (assertoid:raises-error?
+ (test-constraint-propagation/cast 1) type-error)))
+
+;;; bug #399
+(let ((result (make-array 50000 :fill-pointer 0 :adjustable t)))
+ (defun string->html (string &optional (max-length nil))
+ (when (and (numberp max-length)
+ (> max-length (array-dimension result 0)))
+ (setf result (make-array max-length :fill-pointer 0 :adjustable t)))
+ (let ((index 0)
+ (left-quote? t))
+ (labels ((add-char (it)
+ (setf (aref result index) it)
+ (incf index))
+ (add-string (it)
+ (loop for ch across it do
+ (add-char ch))))
+ (loop for char across string do
+ (cond ((char= char #\<)
+ (add-string "<"))
+ ((char= char #\>)
+ (add-string ">"))
+ ((char= char #\&)
+ (add-string "&"))
+ ((char= char #\')
+ (add-string "'"))
+ ((char= char #\newline)
+ (add-string "<br>"))
+ ((char= char #\")
+ (if left-quote? (add-string "“") (add-string "”"))
+ (setf left-quote? (not left-quote?)))
+ (t
+ (add-char char))))
+ (setf (fill-pointer result) index)
+ (coerce result 'string)))))
+
+;;; Callign thru constant symbols
+(require :sb-introspect)
+
+(declaim (inline target-fun))
+(defun target-fun (arg0 arg1)
+ (+ arg0 arg1))
+(declaim (notinline target-fun))
+
+(defun test-target-fun-called (fun res)
+ (assert (member #'target-fun
+ (sb-introspect:find-function-callees #'caller-fun-1)))
+ (assert (equal (funcall fun) res)))
+
+(defun caller-fun-1 ()
+ (funcall 'target-fun 1 2))
+(test-target-fun-called #'caller-fun-1 3)
+
+(defun caller-fun-2 ()
+ (declare (inline target-fun))
+ (apply 'target-fun 1 '(3)))
+(test-target-fun-called #'caller-fun-2 4)
+
+(defun caller-fun-3 ()
+ (flet ((target-fun (a b)
+ (- a b)))
+ (list (funcall #'target-fun 1 4) (funcall 'target-fun 1 4))))
+(test-target-fun-called #'caller-fun-3 (list -3 5))
+
+;;; Reported by NIIMI Satoshi
+;;; Subject: [Sbcl-devel] compilation error with optimization
+;;; Date: Sun, 09 Apr 2006 17:36:05 +0900
+(defun test-minimal-debug-info-for-unstored-but-used-parameter (n a)
+ (declare (optimize (speed 3)
+ (debug 1)))
+ (if (= n 0)
+ 0
+ (test-minimal-debug-info-for-unstored-but-used-parameter (1- n) a)))
+
+;;; &KEY arguments with non-constant defaults.
+(declaim (notinline opaque-identity))
+(defun opaque-identity (x) x)
+(defstruct tricky-defaults
+ (fun #'identity :type function)
+ (num (opaque-identity 3) :type fixnum))
+(macrolet ((frob (form expected-expected-type)
+ `(handler-case ,form
+ (type-error (c) (assert (eq (type-error-expected-type c)
+ ',expected-expected-type)))
+ (:no-error (&rest vals) (error "~S returned values: ~S" ',form vals)))))
+ (frob (make-tricky-defaults :fun 3) function)
+ (frob (make-tricky-defaults :num #'identity) fixnum))
+
+(let ((fun (compile nil '(lambda (&key (key (opaque-identity 3)))
+ (declare (optimize safety) (type integer key))
+ key))))
+ (assert (= (funcall fun) 3))
+ (assert (= (funcall fun :key 17) 17))
+ (handler-case (funcall fun :key t)
+ (type-error (c) (assert (eq (type-error-expected-type c) 'integer)))
+ (:no-error (&rest vals) (error "no error"))))
+
+;;; Basic compiler-macro expansion
+(define-compiler-macro test-cmacro-0 () ''expanded)
+
+(assert (eq 'expanded (funcall (lambda () (test-cmacro-0)))))
+
+;;; FUNCALL forms in compiler macros, lambda-list parsing
+(define-compiler-macro test-cmacro-1
+ (&whole whole a (a2) &optional b &rest c &key d)
+ (list whole a a2 b c d))
+
+(macrolet ((test (form a a2 b c d)
+ `(let ((form ',form))
+ (destructuring-bind (whole a a2 b c d)
+ (funcall (compiler-macro-function 'test-cmacro-1) form nil)
+ (assert (equal whole form))
+ (assert (eql a ,a))
+ (assert (eql a2 ,a2))
+ (assert (eql b ,b))
+ (assert (equal c ,c))
+ (assert (eql d ,d))))) )
+ (test (funcall 'test-cmacro-1 1 (x) 2 :d 3) 1 'x 2 '(:d 3) 3)
+ (test (test-cmacro-1 11 (y) 12 :d 13) 11 'y 12 '(:d 13) 13))
+
+;;; FUNCALL forms in compiler macros, expansions
+(define-compiler-macro test-cmacro-2 () ''ok)
+
+(assert (eq 'ok (funcall (lambda () (funcall 'test-cmacro-2)))))
+(assert (eq 'ok (funcall (lambda () (funcall #'test-cmacro-2)))))
+
+;;; Shadowing of compiler-macros by local functions
+(define-compiler-macro test-cmacro-3 () ''global)
+
+(defmacro find-cmacro-3 (&environment env)
+ (compiler-macro-function 'test-cmacro-3 env))
+
+(assert (funcall (lambda () (find-cmacro-3))))
+(assert (not (funcall (lambda () (flet ((test-cmacro-3 ()))
+ (find-cmacro-3))))))
+(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local))
+ (test-cmacro-3))))))
+(assert (eq 'local (funcall (lambda () (flet ((test-cmacro-3 () 'local))
+ (funcall #'test-cmacro-3))))))
+(assert (eq 'global (funcall (lambda () (flet ((test-cmacro-3 () 'local))
+ (funcall 'test-cmacro-3))))))
+
+;;; Local NOTINLINE & INLINE
+(defun test-cmacro-4 () 'fun)
+(define-compiler-macro test-cmacro-4 () ''macro)
+
+(assert (eq 'fun (funcall (lambda ()
+ (declare (notinline test-cmacro-4))
+ (test-cmacro-4)))))
+
+(assert (eq 'macro (funcall (lambda ()
+ (declare (inline test-cmacro-4))
+ (test-cmacro-4)))))
+
+;;; SETF function compiler macros
+(define-compiler-macro (setf test-cmacro-4) (&whole form value) ''ok)
+
+(assert (eq 'ok (funcall (lambda () (setf (test-cmacro-4) 'zot)))))
+(assert (eq 'ok (funcall (lambda () (funcall #'(setf test-cmacro-4) 'zot)))))
+
+;;; Step instrumentation breaking type-inference
+(handler-bind ((warning #'error))
+ (assert (= 42 (funcall (compile nil '(lambda (v x)
+ (declare (optimize sb-c:insert-step-conditions))
+ (if (typep (the function x) 'fixnum)
+ (svref v (the function x))
+ (funcall x))))
+ nil (constantly 42)))))
+
+;;; bug 368: array type intersections in the compiler
+(defstruct e368)
+(defstruct i368)
+(defstruct g368
+ (i368s (make-array 0 :fill-pointer t) :type (or (vector i368) null)))
+(defstruct s368
+ (g368 (error "missing :G368") :type g368 :read-only t))
+(declaim (ftype (function (fixnum (vector i368) e368) t) r368))
+(declaim (ftype (function (fixnum (vector e368)) t) h368))
+(defparameter *h368-was-called-p* nil)
+(defun nsu (vertices e368)
+ (let ((i368s (g368-i368s (make-g368))))
+ (let ((fuis (r368 0 i368s e368)))
+ (format t "~&FUIS=~S~%" fuis)
+ (or fuis (h368 0 i368s)))))
+(defun r368 (w x y)
+ (declare (ignore w x y))
+ nil)
+(defun h368 (w x)
+ (declare (ignore w x))
+ (setf *h368-was-called-p* t)
+ (make-s368 :g368 (make-g368)))
+(let ((nsu (nsu #() (make-e368))))
+ (format t "~&NSU returned ~S~%" nsu)
+ (format t "~&*H368-WAS-CALLED-P*=~S~%" *h368-was-called-p*)
+ (assert (s368-p nsu))
+ (assert *h368-was-called-p*))
+
+;;; bug 367: array type intersections in the compiler
+(defstruct e367)
+(defstruct i367)
+(defstruct g367
+ (i367s (make-array 0 :fill-pointer t) :type (or (vector i367) null)))
+(defstruct s367
+ (g367 (error "missing :G367") :type g367 :read-only t))
+(declaim (ftype (function ((vector i367) e367) (or s367 null)) r367))
+(declaim (ftype (function ((vector e367)) (values)) h367))
+(defun frob-367 (v w)
+ (let ((x (g367-i367s (make-g367))))
+ (let* ((y (or (r367 x w)
+ (h367 x)))
+ (z (s367-g367 y)))
+ (format t "~&Y=~S Z=~S~%" y z)
+ (g367-i367s z))))
+(defun r367 (x y) (declare (ignore x y)) nil)
+(defun h367 (x) (declare (ignore x)) (values))
+(multiple-value-bind (res err) (ignore-errors (frob-367 0 (make-e367)))
+ (assert (not res))
+ (assert (typep err 'type-error)))
+
+(handler-case
+ (delete-file (compile-file "circ-tree-test.lisp"))
+ (storage-condition (e)
+ (error e)))
+
+;;; warnings due to step-insturmentation
+(defclass debug-test-class () ())
+(handler-case
+ (compile nil '(lambda ()
+ (declare (optimize (debug 3)))
+ (defmethod print-object ((x debug-test-class) s)
+ (call-next-method))))
+ ((and (not style-warning) warning) (e)
+ (error e)))
+
+;;; program-error from bad lambda-list keyword
+(assert (eq :ok
+ (handler-case
+ (funcall (lambda (&whole x)
+ (list &whole x)))
+ (program-error ()
+ :ok))))
+(assert (eq :ok
+ (handler-case
+ (let ((*evaluator-mode* :interpret))
+ (funcall (eval '(lambda (&whole x)
+ (list &whole x)))))
+ (program-error ()
+ :ok))))
+
+;;; ignore &environment
+(handler-bind ((style-warning #'error))
+ (compile nil '(lambda ()
+ (defmacro macro-ignore-env (&environment env)
+ (declare (ignore env))
+ :foo)))
+ (compile nil '(lambda ()
+ (defmacro macro-no-env ()
+ :foo))))
+
+(dolist (*evaluator-mode* '(:interpret :compile))
+ (disassemble (eval '(defun disassemble-source-form-bug (x y z)
+ (declare (optimize debug))
+ (list x y z)))))
+
+;;; long-standing bug in defaulting unknown values on the x86-64,
+;;; since changing the calling convention (test case by Christopher
+;;; Laux sbcl-help 30-06-2007)
+
+(defun default-values-bug-demo-sub ()
+ (format t "test")
+ nil)
+(compile 'default-values-bug-demo-sub)
+
+(defun default-values-bug-demo-main ()
+ (multiple-value-bind (a b c d e f g h)
+ (default-values-bug-demo-sub)
+ (if a (+ a b c d e f g h) t)))
+(compile 'default-values-bug-demo-main)
+
+(assert (default-values-bug-demo-main))
+
+;;; copy propagation bug reported by Paul Khuong
+
+(defun local-copy-prop-bug-with-move-arg (x)
+ (labels ((inner ()
+ (values 1 0)))
+ (if x
+ (inner)
+ (multiple-value-bind (a b)
+ (inner)
+ (values b a)))))
+
+(assert (equal '(0 1) (multiple-value-list (local-copy-prop-bug-with-move-arg nil))))
+(assert (equal '(1 0) (multiple-value-list (local-copy-prop-bug-with-move-arg t))))
+
+;;;; with-pinned-objects & unwind-protect, using all non-tail conventions
+
+(defun wpo-quux () (list 1 2 3))
+(defvar *wpo-quux* #'wpo-quux)
+
+(defun wpo-call ()
+ (unwind-protect
+ (sb-sys:with-pinned-objects (*wpo-quux*)
+ (values (funcall *wpo-quux*)))))
+(assert (equal '(1 2 3) (wpo-call)))
+
+(defun wpo-multiple-call ()
+ (unwind-protect
+ (sb-sys:with-pinned-objects (*wpo-quux*)
+ (funcall *wpo-quux*))))
+(assert (equal '(1 2 3) (wpo-multiple-call)))
+
+(defun wpo-call-named ()
+ (unwind-protect
+ (sb-sys:with-pinned-objects (*wpo-quux*)
+ (values (wpo-quux)))))
+(assert (equal '(1 2 3) (wpo-call-named)))
+
+(defun wpo-multiple-call-named ()
+ (unwind-protect
+ (sb-sys:with-pinned-objects (*wpo-quux*)
+ (wpo-quux))))
+(assert (equal '(1 2 3) (wpo-multiple-call-named)))
+
+(defun wpo-call-variable (&rest args)
+ (unwind-protect
+ (sb-sys:with-pinned-objects (*wpo-quux*)
+ (values (apply *wpo-quux* args)))))
+(assert (equal '(1 2 3) (wpo-call-variable)))
+
+(defun wpo-multiple-call-variable (&rest args)
+ (unwind-protect
+ (sb-sys:with-pinned-objects (*wpo-quux*)
+ (apply #'wpo-quux args))))
+(assert (equal '(1 2 3) (wpo-multiple-call-named)))
+
+(defun wpo-multiple-call-local ()
+ (flet ((quux ()
+ (wpo-quux)))
+ (unwind-protect
+ (sb-sys:with-pinned-objects (*wpo-quux*)
+ (quux)))))
+(assert (equal '(1 2 3) (wpo-multiple-call-local)))
+
+;;; bug 417: toplevel NIL confusing source path logic
+(handler-case
+ (delete-file (compile-file "bug-417.lisp"))
+ (sb-ext:code-deletion-note (e)
+ (error e)))
+
+;;; unknown values return convention getting disproportionate
+;;; amounts of values.
+(declaim (notinline one-value two-values))
+(defun one-value (x)
+ (not x))
+(defun two-values (x y)
+ (values y x))
+(defun wants-many-values (x y)
+ (multiple-value-bind (a b c d e f)
+ (one-value y)
+ (assert (and (eql (not y) a)
+ (not (or b c d e f)))))
+ (multiple-value-bind (a b c d e f)
+ (two-values y x)
+ (assert (and (eql a x) (eql b y)
+ (not (or c d e f)))))
+ (multiple-value-bind (a b c d e f g h i)
+ (one-value y)
+ (assert (and (eql (not y) a)
+ (not (or b c d e f g h i)))))
+ (multiple-value-bind (a b c d e f g h i)
+ (two-values y x)
+ (assert (and (eql a x) (eql b y)
+ (not (or c d e f g h i)))))
+ (multiple-value-bind (a b c d e f g h i j k l m n o p q r s)
+ (one-value y)
+ (assert (and (eql (not y) a)
+ (not (or b c d e f g h i j k l m n o p q r s)))))
+ (multiple-value-bind (a b c d e f g h i j k l m n o p q r s)
+ (two-values y x)
+ (assert (and (eql a x) (eql b y)
+ (not (or c d e f g h i j k l m n o p q r s))))))
+(wants-many-values 1 42)
+
+;;; constant coalescing
+
+(defun count-code-constants (x f)
+ (let ((code (sb-kernel:fun-code-header f))
+ (n 0))
+ (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
+ do (when (equal x (sb-kernel:code-header-ref code i))
+ (incf n)))
+ n))
+
+(defvar *lambda*)
+
+(defun compile2 (lambda)
+ (let* ((lisp "compiler-impure-tmp.lisp")
+ (fasl (compile-file-pathname lisp)))
+ (unwind-protect
+ (progn
+ (with-open-file (f lisp :direction :output)
+ (prin1 `(setf *lambda* ,lambda) f))
+ (multiple-value-bind (fasl warn fail) (compile-file lisp)
+ (declare (ignore warn))
+ (when fail
+ (error "File-compiling ~S failed." lambda))
+ (let ((*lambda* nil))
+ (load fasl)
+ (values *lambda* (compile nil lambda)))))
+ (ignore-errors (delete-file lisp))
+ (ignore-errors (delete-file fasl)))))
+
+;; named and unnamed
+(defconstant +born-to-coalesce+ '.born-to-coalesce.)
+(multiple-value-bind (file-fun core-fun)
+ (compile2 '(lambda ()
+ (let ((x (cons +born-to-coalesce+ nil))
+ (y (cons '.born-to-coalesce. nil)))
+ (list x y))))
+ (assert (= 1 (count-code-constants '.born-to-coalesce. file-fun)))
+ (assert (= 1 (count-code-constants '.born-to-coalesce. core-fun))))
+
+;; some things must retain identity under COMPILE, but we want to coalesce them under COMPILE-FILE
+(defun assert-coalescing (constant)
+ (let ((value (copy-seq (symbol-value constant))))
+ (multiple-value-bind (file-fun core-fun)
+ (compile2 `(lambda ()
+ (let ((x (cons ,constant nil))
+ (y (cons ',value nil)))
+ (list x y))))
+ (assert (= 1 (count-code-constants value file-fun)))
+ (assert (= 2 (count-code-constants value core-fun)))
+ (let* ((l (funcall file-fun))
+ (a (car (first l)))
+ (b (car (second l))))
+ (assert (and (equal value a)
+ (equal a b)
+ (eq a b))))
+ (let* ((l (funcall core-fun))
+ (a (car (first l)))
+ (b (car (second l))))
+ (assert (and (equal value a)
+ (equal a b)
+ (not (eq a b))))))))
+
+(defconstant +born-to-coalesce2+ "maybe coalesce me!")
+(assert-coalescing '+born-to-coalesce2+)
+
+(defconstant +born-to-coalesce3+ #*01101001011101110100011)
+(assert-coalescing '+born-to-coalesce3+)
+
+(defconstant +born-to-coalesce4+ '(foo bar "zot" 123 (nested "quux") #*0101110010))
+(assert-coalescing '+born-to-coalesce4+)
+
+(defclass some-constant-thing () ())
+
+;;; correct handling of nested things loaded via SYMBOL-VALUE
+(defvar *sneaky-nested-thing* (list (make-instance 'some-constant-thing)))
+(defconstant +sneaky-nested-thing+ *sneaky-nested-thing*)
+(multiple-value-bind (file-fun core-fun) (compile2 '(lambda () +sneaky-nested-thing+))
+ (assert (equal *sneaky-nested-thing* (funcall file-fun)))
+ (assert (equal *sneaky-nested-thing* (funcall core-fun))))
+
+;;; catch constant modifications thru undefined variables
+(defun sneak-set-dont-set-me (x)
+ (ignore-errors (setq dont-set-me x)))
+(defconstant dont-set-me 42)
+(assert (not (sneak-set-dont-set-me 13)))
+(assert (= 42 dont-set-me))
+(defun sneak-set-dont-set-me2 (x)
+ (ignore-errors (setq dont-set-me2 x)))
+(defconstant dont-set-me2 (make-instance 'some-constant-thing))
+(assert (not (sneak-set-dont-set-me2 13)))
+(assert (typep dont-set-me2 'some-constant-thing))
+
+;;; check that non-trivial constants are EQ across different files: this is
+;;; not something ANSI either guarantees or requires, but we want to do it
+;;; anyways.
+(defconstant +share-me-1+ 123.456d0)
+(defconstant +share-me-2+ "a string to share")
+(defconstant +share-me-3+ (vector 1 2 3))
+(defconstant +share-me-4+ (* 2 most-positive-fixnum))
+(multiple-value-bind (f1 c1) (compile2 '(lambda () (values +share-me-1+
+ +share-me-2+
+ +share-me-3+
+ +share-me-4+
+ pi)))
+ (multiple-value-bind (f2 c2) (compile2 '(lambda () (values +share-me-1+
+ +share-me-2+
+ +share-me-3+
+ +share-me-4+
+ pi)))
+ (flet ((test (fa fb)
+ (mapc (lambda (a b)
+ (assert (eq a b)))
+ (multiple-value-list (funcall fa))
+ (multiple-value-list (funcall fb)))))
+ (test f1 c1)
+ (test f1 f2)
+ (test f1 c2))))
+
+;;; user-defined satisfies-types cannot be folded
+(deftype mystery () '(satisfies mysteryp))
+(defvar *mystery* nil)
+(defun mysteryp (x) (eq x *mystery*))
+(defstruct thing (slot (error "missing") :type mystery))
+(defun test-mystery (m) (when (eq :mystery (thing-slot m)) :ok))
+(setf *mystery* :mystery)
+(assert (eq :ok (test-mystery (make-thing :slot :mystery))))
+
;;; success
-(quit :unix-status 104)