X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=3a2ce24ba38b04883a12ef6b74722d499b4c7c4e;hb=a32cea89ba8f5e8a0726f4182c7b6666646e6d3a;hp=21b4171101c2f7ef1435c2dcf1bd6dba8f253329;hpb=eded4f764cd9736b34a60d4a53b24cef1e9b203e;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 21b4171..3a2ce24 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -928,6 +928,113 @@ (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)))))) + ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself @@ -1272,20 +1379,21 @@ ;;; 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) @@ -1669,4 +1777,13 @@ (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