X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=38690b4600fd13f9815222e25a52b4080da057c1;hb=1a61f069111cb6f7263852b73eea1bd8cda9ef68;hp=1e747c4be7c0ca53e1547b8647e95a70520d7ba1;hpb=12836ca105af62252aa0974c3f6992e60ce0ebf4;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 1e747c4..38690b4 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1212,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 @@ -1693,6 +1779,7 @@ (list &whole x))) (program-error () :ok)))) +#+sb-eval (assert (eq :ok (handler-case (let ((*evaluator-mode* :interpret)) @@ -1711,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))))) @@ -2076,4 +2163,62 @@ (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))))) + ;;; success