X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=87c22657c767e0ad4f878a6e6b4f854fe5dc48a9;hb=9abfd1a2b22862570c15ffa5129b1196d0480290;hp=c31a16fe0087332d89e2a0f513f92dd0a0917e05;hpb=61e6ba93d83266662a1e17431fab02a981ec6bc8;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index c31a16f..87c2265 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -942,6 +942,133 @@ (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"))))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself @@ -1286,20 +1413,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)