X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=1e747c4be7c0ca53e1547b8647e95a70520d7ba1;hb=12836ca105af62252aa0974c3f6992e60ce0ebf4;hp=1affc4059f1debb52d897a1a7217caafc08414f5;hpb=796873d7b696e1079d2319844444040d18e0e2b1;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 1affc40..1e747c4 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1003,33 +1003,18 @@ (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 + (ctu: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 + (ctu:file-compile '((declaim (optimize (debug 3))) (defstruct bug-405-foo bar) (let () @@ -1159,6 +1144,74 @@ (make-something-known-to-be-a-struct :x "X" :y "Y") #\x #\y))) (assert (not (ctu:find-named-callees f))))) + +(defclass some-slot-thing () + ((slot :initarg :slot))) +(with-test (:name :with-slots-the) + (let ((x (make-instance 'some-slot-thing :slot "foo"))) + (with-slots (slot) (the some-slot-thing x) + (assert (equal "foo" slot))))) + +;;; Missing &REST type in proclamation causing a miscompile. +(declaim (ftype + (function + (sequence unsigned-byte + &key (:initial-element t) (:initial-contents sequence)) + (values sequence &optional)) + bug-458354)) +(defun bug-458354 + (sequence length + &rest keys + &key (initial-element nil iep) (initial-contents nil icp)) + (declare (sb-ext:unmuffle-conditions style-warning)) + (declare (ignorable keys initial-element iep initial-contents icp)) + (apply #'sb-sequence:make-sequence-like sequence length keys)) +(with-test (:name :bug-458354) + (assert (equalp #((a b) (a b)) (bug-458354 #(1 2) 2 :initial-element '(a b))))) + +(with-test (:name :bug-542807) + (handler-bind ((style-warning #'error)) + (eval '(defstruct bug-542807 slot))) + (let (conds) + (handler-bind ((style-warning (lambda (c) + (push c conds)))) + (eval '(defstruct bug-542807 slot))) + (assert (= 1 (length conds))) + (assert (typep (car conds) 'sb-kernel::redefinition-with-defun)))) + +(with-test (:name :defmacro-not-list-lambda-list) + (assert (raises-error? (eval `(defmacro ,(gensym) "foo")) + type-error))) + +(with-test (:name :bug-308951) + (let ((x 1)) + (dotimes (y 10) + (let ((y y)) + (when (funcall (eval #'(lambda (x) (eql x 2))) y) + (defun bug-308951-foo (z) + (incf x (incf y z)))))) + (defun bug-308951-bar (z) + (bug-308951-foo z) + (values x))) + (assert (= 4 (bug-308951-bar 1)))) + +(declaim (inline bug-308914-storage)) +(defun bug-308914-storage (x) + (the (simple-array flt (*)) (bug-308914-unknown x))) + +(with-test (:name :bug-308914-workaround) + ;; This used to hang in ORDER-UVL-SETS. + (handler-case + (with-timeout 10 + (compile nil + `(lambda (lumps &key cg) + (let ((nodes (map 'list (lambda (lump) + (bug-308914-storage lump)) + lumps))) + (setf (aref nodes 0) 2) + (assert (every #'~= (apply #'concatenate 'list nodes) '(2 3 6 9))))))) + (sb-ext:timeout () + (error "Hang in ORDER-UVL-SETS?")))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself @@ -1910,4 +1963,117 @@ (setf *mystery* :mystery) (assert (eq :ok (test-mystery (make-thing :slot :mystery)))) +;;; Singleton types can also be constant. +(test-util:with-test (:name :propagate-singleton-types-to-eql) + (macrolet ((test (type value &aux (fun (gensym "FUN"))) + `(progn + (declaim (ftype (function () (values ,type &optional)) ,fun)) + (defun ,fun () + ',value) + (lambda (x) + (if (eql x (,fun)) + nil + (eql x (,fun))))))) + (values + (test (eql foo) foo) + (test (integer 0 0) 0) + (test (double-float 0d0 0d0) 0d0) + (test (eql #\c) #\c)))) + +(declaim (ftype (function () (integer 42 42)) bug-655581)) +(defun bug-655581 () + 42) +(declaim (notinline bug-655581)) +(test-util:with-test (:name :bug-655581) + (multiple-value-bind (type derived) + (funcall (compile nil `(lambda () + (ctu:compiler-derived-type (bug-655581))))) + (assert derived) + (assert (equal '(integer 42 42) type)))) + +(test-util:with-test (:name :clear-derived-types-on-set-fdefn) + (let ((*evaluator-mode* :compile) + (*derive-function-types* t)) + (eval `(progn + (defun clear-derived-types-on-set-fdefn-1 () + "foo") + (setf (symbol-function 'clear-derived-types-on-set-fdefn-1) + (constantly "foobar")) + (defun clear-derived-types-on-set-fdefn-2 () + (length (clear-derived-types-on-set-fdefn-1))))) + (assert (= 6 (clear-derived-types-on-set-fdefn-2))))) + +(test-util:with-test (:name (:bug-655126 :derive-function-types t)) + (let ((*evaluator-mode* :compile) + (*derive-function-types* t)) + (eval `(defun bug-655126 (x) x)) + ;; Full warnings are ok due to *derive-function-types* = T. + (assert (eq :full-warning + (handler-case + (eval `(defun bug-655126-2 () + (bug-655126))) + ((and warning (not style-warning)) () + :full-warning)))) + (assert (eq 'bug-655126 + (handler-case + (eval `(defun bug-655126 (x y) + (cons x y))) + ((and warning (not sb-kernel:redefinition-warning)) () + :oops)))) + (assert (eq :full-warning + (handler-case + (eval `(defun bug-655126 (x) + (bug-655126 x y))) + ((and warning + (not style-warning) + (not sb-kernel:redefinition-warning)) () + :full-warning)))))) + +(test-util:with-test (:name (:bug-655126 :derive-function-types nil)) + (let ((*evaluator-mode* :compile)) + (eval `(defun bug-655126/b (x) x)) + ;; Just style-warning here. + (assert (eq :style-warning + (handler-case + (eval `(defun bug-655126-2/b () + (bug-655126/b))) + (style-warning () + :style-warning)))) + (assert (eq 'bug-655126/b + (handler-case + (eval `(defun bug-655126/b (x y) + (cons x y))) + ((and warning (not sb-kernel:redefinition-warning)) () + :oops)))) + ;; Bogus self-call is always worth a full one. + (assert (eq :full-warning + (handler-case + (eval `(defun bug-655126/b (x) + (bug-655126/b x y))) + ((and warning + (not style-warning) + (not sb-kernel:redefinition-warning)) () + :full-warning)))))) + +(test-util:with-test (:name :bug-657499) + ;; Don't trust derived types within the compilation unit. + (ctu:file-compile + `((declaim (optimize safety)) + (defun bug-657499-foo () + (cons t t)) + (defun bug-657499-bar () + (let ((cons (bug-657499-foo))) + (setf (car cons) 3) + cons))) + :load t) + (locally (declare (optimize safety)) + (setf (symbol-function 'bug-657499-foo) (constantly "foobar")) + (assert (eq :type-error + (handler-case + (funcall 'bug-657499-bar) + (type-error (e) + (assert (eq 'cons (type-error-expected-type e))) + (assert (equal "foobar" (type-error-datum e))) + :type-error)))))) + ;;; success