X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=67951711e2df59ea068bf5e82401d6f2deeaef37;hb=f09f67b4233004079affc70de2ef2d49f27ca91a;hp=6c8ed83af94608eaa42dfac6f0ac1a7ef702db65;hpb=99f12b8ef75252c8d2d52705b53f2a8f9227443a;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 6c8ed83..6795171 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -618,7 +618,7 @@ (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 (equal (check-embedded-thes 1 0 3 :b) '(3 :b))) (assert (typep (check-embedded-thes 1 0 1.0 2.5f0) 'type-error)) @@ -953,6 +953,152 @@ (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"))))) + +;;; PROGV compilation and type checking when the declared type +;;; includes a FUNCTION subtype. +(declaim (type (or (function (t) (values boolean &optional)) string) + *hairy-progv-var*)) +(defvar *hairy-progv-var* #'null) +(with-test (:name :hairy-progv-type-checking) + (assert (eq :error + (handler-case + (progv '(*hairy-progv-var*) (list (eval 42)) + *hairy-progv-var*) + (type-error () :error)))) + (assert (equal "GOOD!" + (progv '(*hairy-progv-var*) (list (eval "GOOD!")) + *hairy-progv-var*)))) + +(with-test (:name :fill-complex-single-float) + (assert (every (lambda (x) (eql x #c(-1.0 -2.0))) + (funcall + (lambda () + (make-array 2 + :element-type '(complex single-float) + :initial-element #c(-1.0 -2.0))))))) + +(with-test (:name :make-array-symbol-as-initial-element) + (assert (every (lambda (x) (eq x 'a)) + (funcall + (compile nil + `(lambda () + (make-array 12 :initial-element 'a))))))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself