;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
+(when (eq sb-ext:*evaluator-mode* :interpret)
+ (sb-ext:quit :unix-status 104))
+
(load "test-util.lisp")
(load "assertoid.lisp")
(use-package "TEST-UTIL")
(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))))))
+
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
;;; FUNCALL forms in compiler macros, lambda-list parsing
(define-compiler-macro test-cmacro-1
- (&whole whole a &optional b &rest c &key d)
- (list whole a b c d))
+ (&whole whole a (a2) &optional b &rest c &key d)
+ (list whole a a2 b c d))
-(macrolet ((test (form a b c d)
+(macrolet ((test (form a a2 b c d)
`(let ((form ',form))
- (destructuring-bind (whole a b c d)
+ (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 2 :d 3) 1 2 '(:d 3) 3)
- (test (test-cmacro-1 11 12 :d 13) 11 12 '(:d 13) 13))
+ (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)
(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)
(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
projects / sbcl.git / blobdiff