X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=c31a16fe0087332d89e2a0f513f92dd0a0917e05;hb=b20e8cac4dd15882d5e0fda1bcf04c487df1360f;hp=89a9d83db26915411e7cea44dd78493a4fa1a925;hpb=45bc305be4e269d2e1a477c8e0ae9a64df1ccd1c;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 89a9d83..c31a16f 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -928,6 +928,20 @@
     (eval '(labels ((%f (&key x) x)) (%f nil nil)))
   (error (c) :good)
   (:no-error (val) (error "no error: ~S" val)))
+
+;;; PROGV must not bind constants, or violate declared types -- ditto for SET.
+(assert (raises-error? (set pi 3)))
+(assert (raises-error? (progv '(pi s) '(3 pi) (symbol-value x))))
+(declaim (cons *special-cons*))
+(assert (raises-error? (set '*special-cons* "nope") type-error))
+(assert (raises-error? (progv '(*special-cons*) '("no hope") (car *special-cons*)) type-error))
+
+;;; No bogus warnings for calls to functions with complex lambda-lists.
+(defun complex-function-signature (&optional x &rest y &key z1 z2)
+  (cons x y))
+(with-test (:name :complex-call-doesnt-warn)
+  (handler-bind ((warning #'error))
+    (compile nil '(lambda (x) (complex-function-signature x :z1 1 :z2 2)))))
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
@@ -1622,17 +1636,60 @@
 (defconstant +born-to-coalesce4+ '(foo bar "zot" 123 (nested "quux") #*0101110010))
 (assert-coalescing '+born-to-coalesce4+)
 
+(defclass some-constant-thing () ())
+
+;;; correct handling of nested things loaded via SYMBOL-VALUE
+(defvar *sneaky-nested-thing* (list (make-instance 'some-constant-thing)))
+(defconstant +sneaky-nested-thing+ *sneaky-nested-thing*)
+(multiple-value-bind (file-fun core-fun) (compile2 '(lambda () +sneaky-nested-thing+))
+  (assert (equal *sneaky-nested-thing* (funcall file-fun)))
+  (assert (equal *sneaky-nested-thing* (funcall core-fun))))
+
 ;;; catch constant modifications thru undefined variables
 (defun sneak-set-dont-set-me (x)
   (ignore-errors (setq dont-set-me x)))
 (defconstant dont-set-me 42)
 (assert (not (sneak-set-dont-set-me 13)))
 (assert (= 42 dont-set-me))
-(defclass some-constant-thing () ())
 (defun sneak-set-dont-set-me2 (x)
   (ignore-errors (setq dont-set-me2 x)))
 (defconstant dont-set-me2 (make-instance 'some-constant-thing))
 (assert (not (sneak-set-dont-set-me2 13)))
 (assert (typep dont-set-me2 'some-constant-thing))
 
+;;; check that non-trivial constants are EQ across different files: this is
+;;; not something ANSI either guarantees or requires, but we want to do it
+;;; anyways.
+(defconstant +share-me-1+ 123.456d0)
+(defconstant +share-me-2+ "a string to share")
+(defconstant +share-me-3+ (vector 1 2 3))
+(defconstant +share-me-4+ (* 2 most-positive-fixnum))
+(multiple-value-bind (f1 c1) (compile2 '(lambda () (values +share-me-1+
+                                                           +share-me-2+
+                                                           +share-me-3+
+                                                           +share-me-4+
+                                                           pi)))
+  (multiple-value-bind (f2 c2) (compile2 '(lambda () (values +share-me-1+
+                                                             +share-me-2+
+                                                             +share-me-3+
+                                                             +share-me-4+
+                                                             pi)))
+    (flet ((test (fa fb)
+             (mapc (lambda (a b)
+                     (assert (eq a b)))
+                   (multiple-value-list (funcall fa))
+                   (multiple-value-list (funcall fb)))))
+      (test f1 c1)
+      (test f1 f2)
+      (test f1 c2))))
+
+;;; user-defined satisfies-types cannot be folded
+(deftype mystery () '(satisfies mysteryp))
+(defvar *mystery* nil)
+(defun mysteryp (x) (eq x *mystery*))
+(defstruct thing (slot (error "missing") :type mystery))
+(defun test-mystery (m) (when (eq :mystery (thing-slot m)) :ok))
+(setf *mystery* :mystery)
+(assert (eq :ok (test-mystery (make-thing :slot :mystery))))
+
 ;;; success