Merge branch 'master' of ssh://sbcl.git.sourceforge.net/gitroot/sbcl/sbcl

[sbcl.git] / tests / compiler.impure.lisp

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 1e747c4..81c72bd 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1212,6 +1212,21 @@
                       (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)))))
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
@@ -1693,6 +1708,7 @@
                            (list &whole x)))
               (program-error ()
                 :ok))))
+#+sb-eval
 (assert (eq :ok
             (handler-case
                 (let ((*evaluator-mode* :interpret))
@@ -1711,7 +1727,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 +2092,40 @@
                     (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)))))
+
 ;;; success