X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=d437d1cfeac1dbea0636c8c6945f391a5cd5e859;hb=722a3f7ec83e075a483161ffff76e1392c66cc22;hp=195a2f4dce63a6c1bc2aeb8e4c694e29562a164b;hpb=cb41e65e62328d1bd63df8477388503fa7e864bb;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 195a2f4..d437d1c 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 () @@ -1227,6 +1212,92 @@ (assert (every #'~= (apply #'concatenate 'list nodes) '(2 3 6 9))))))) (sb-ext:timeout () (error "Hang in ORDER-UVL-SETS?")))) + +(declaim (inline inlined-function-in-source-path)) +(defun inlined-function-in-source-path (x) + (+ x x)) + +(with-test (:name :inlined-function-in-source-path) + (let ((output + (with-output-to-string (*error-output*) + (compile nil `(lambda (x) + (declare (optimize speed)) + (funcall #'inlined-function-in-source-path x)))))) + ;; We want the name + (assert (search "INLINED-FUNCTION-IN-SOURCE-PATH" output)) + ;; ...not the leaf. + (assert (not (search "DEFINED-FUN" output))))) + +(defmacro bug-795705 () + t) + +(with-test (:name :bug-795705) + (assert (macro-function 'bug-795705)) + (fmakunbound 'bug-795705) + (assert (not (macro-function 'bug-795705)))) + +(with-test (:name (load-time-value :type-derivation)) + (let ((name 'load-time-value-type-derivation-test)) + (labels ((funtype (fun) + (sb-kernel:type-specifier + (sb-kernel:single-value-type + (sb-kernel:fun-type-returns + (sb-kernel:specifier-type + (sb-kernel:%simple-fun-type fun)))))) + (test (type1 type2 form value-cell-p) + (let* ((lambda-form `(lambda () + (load-time-value ,form))) + (core-fun (compile nil lambda-form)) + (core-type (funtype core-fun)) + (core-cell (ctu:find-value-cell-values core-fun)) + (defun-form `(defun ,name () + (load-time-value ,form))) + (file-fun (progn + (ctu:file-compile (list defun-form) :load t) + (symbol-function name))) + (file-type (funtype file-fun)) + (file-cell (ctu:find-value-cell-values file-fun))) + (if value-cell-p + (assert (and core-cell file-cell)) + (assert (not (or core-cell file-cell)))) + (unless (subtypep core-type type1) + (error "core: wanted ~S, got ~S" type1 core-type)) + (unless (subtypep file-type type2) + (error "file: wanted ~S, got ~S" type2 file-type))))) + (let ((* 10)) + (test '(integer 11 11) 'number + '(+ * 1) nil)) + (let ((* "fooo")) + (test '(integer 4 4) 'unsigned-byte + '(length *) nil)) + (test '(integer 10 10) '(integer 10 10) 10 nil) + (test 'cons 'cons '(cons t t) t)))) + +(with-test (:name (load-time-value :errors)) + (multiple-value-bind (warn fail) + (ctu:file-compile + `((defvar *load-time-value-error-value* 10) + (declaim (fixnum *load-time-value-error-value*)) + (defun load-time-value-error-test-1 () + (the list (load-time-value *load-time-value-error-value*)))) + :load t) + (assert warn) + (assert fail)) + (handler-case (load-time-value-error-test-1) + (type-error (e) + (and (eql 10 (type-error-datum e)) + (eql 'list (type-error-expected-type e))))) + (multiple-value-bind (warn2 fail2) + (ctu:file-compile + `((defun load-time-value-error-test-2 () + (the list (load-time-value 10)))) + :load t) + (assert warn2) + (assert fail2)) + (handler-case (load-time-value-error-test-2) + (type-error (e) + (and (eql 10 (type-error-datum e)) + (eql 'list (type-error-expected-type e)))))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself @@ -1708,6 +1779,7 @@ (list &whole x))) (program-error () :ok)))) +#+sb-eval (assert (eq :ok (handler-case (let ((*evaluator-mode* :interpret)) @@ -1726,7 +1798,7 @@ (defmacro macro-no-env () :foo)))) -(dolist (*evaluator-mode* '(:interpret :compile)) +(dolist (*evaluator-mode* '(#+sb-eval :interpret :compile)) (disassemble (eval '(defun disassemble-source-form-bug (x y z) (declare (optimize debug)) (list x y z))))) @@ -2018,4 +2090,160 @@ (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)))))) + +(declaim (unsigned-byte *symbol-value-test-var*)) +(defvar *symbol-value-test-var*) + +(declaim (unsigned-byte **global-symbol-value-test-var**)) +(defglobal **global-symbol-value-test-var** 0) + +(test-util:with-test (:name :symbol-value-type-derivation) + (let ((fun (compile + nil + `(lambda () + *symbol-value-test-var*)))) + (assert (equal '(function () (values unsigned-byte &optional)) + (%simple-fun-type fun)))) + (let ((fun (compile + nil + `(lambda () + **global-symbol-value-test-var**)))) + (assert (equal '(function () (values unsigned-byte &optional)) + (%simple-fun-type fun)))) + (let ((fun (compile + nil + `(lambda (*symbol-value-test-var*) + (declare (fixnum *symbol-value-test-var*)) + (symbol-value '*symbol-value-test-var*)))) + (ufix (type-specifier (specifier-type `(and unsigned-byte fixnum))))) + (assert (equal `(function (,ufix) (values ,ufix &optional)) + (%simple-fun-type fun)))) + (let ((fun (compile + nil + `(lambda () + (declare (fixnum **global-symbol-value-test-var**)) + (symbol-global-value '**global-symbol-value-test-var**)))) + (ufix (type-specifier (specifier-type `(and unsigned-byte fixnum))))) + (assert (equal `(function () (values ,ufix &optional)) + (%simple-fun-type fun))))) + +(test-util:with-test (:name :mv-bind-to-let-type-propagation) + (let ((f (compile nil `(lambda (x) + (declare (optimize speed) + (type (integer 20 50) x)) + (< (truncate x 10) 1)))) + (g (compile nil `(lambda (x) + (declare (optimize speed) + (type (integer 20 50) x)) + (< (nth-value 1 (truncate x 10)) 10)))) + (h (compile nil `(lambda (x) + (declare (optimize speed) + (type (integer 20 50) x)) + (multiple-value-bind (q r) + (truncate x 10) + (declare (ignore r)) + (< q 1))))) + (type0 '(function ((integer 20 50)) (values null &optional))) + (type1 '(function ((integer 20 50)) (values (member t) &optional)))) + (assert (equal type0 (sb-kernel:%simple-fun-type f))) + (assert (equal type1 (sb-kernel:%simple-fun-type g))) + (assert (equal type0 (sb-kernel:%simple-fun-type h))))) + +(test-util:with-test (:name :bug-308921) + (let ((*check-consistency* t)) + (ctu:file-compile + `((let ((exported-symbols-alist + (loop for symbol being the external-symbols of :cl + collect (cons symbol + (concatenate 'string + "#" + (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol) + (cdr (assoc symbol exported-symbols-alist))))) + :load nil))) + +(test-util:with-test (:name :bug-308941) + (multiple-value-bind (warn fail) + (let ((*check-consistency* t)) + (ctu:file-compile + "(eval-when (:compile-toplevel :load-toplevel :execute) + (defstruct foo3)) + (defstruct bar + (foo #.(make-foo3)))" + :load nil)) + ;; ...but the compiler should not break. + (assert (and warn fail)))) + ;;; success