X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=5ec5e1cca999c0edba08cd6d0d5a36f8141be20b;hb=7c16e6bf7a5559ffd81ea0816c5a44989709f51d;hp=33af05f24d1e816b29b77590df6e8edeb6a2a0a8;hpb=57d893458e9cb6fdc902d78f69fc3e4f362fe778;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 33af05f..5ec5e1c 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1229,9 +1229,9 @@
     (list (funcall #'target-fun 1 4) (funcall 'target-fun 1 4))))
 (test-target-fun-called #'caller-fun-3 (list -3 5))
 
-;; Reported by NIIMI Satoshi
-;; Subject: [Sbcl-devel] compilation error with optimization
-;; Date: Sun, 09 Apr 2006 17:36:05 +0900
+;;; Reported by NIIMI Satoshi
+;;; Subject: [Sbcl-devel] compilation error with optimization
+;;; Date: Sun, 09 Apr 2006 17:36:05 +0900
 (defun test-minimal-debug-info-for-unstored-but-used-parameter (n a)
   (declare (optimize (speed 3)
                      (debug 1)))
@@ -1239,4 +1239,27 @@
       0
       (test-minimal-debug-info-for-unstored-but-used-parameter (1- n) a)))
 
+;;; &KEY arguments with non-constant defaults.
+(declaim (notinline opaque-identity))
+(defun opaque-identity (x) x)
+(defstruct tricky-defaults
+  (fun #'identity :type function)
+  (num (opaque-identity 3) :type fixnum))
+(macrolet ((frob (form expected-expected-type)
+             `(handler-case ,form
+               (type-error (c) (assert (eq (type-error-expected-type c)
+                                           ',expected-expected-type)))
+               (:no-error (&rest vals) (error "~S returned values: ~S" ',form vals)))))
+  (frob (make-tricky-defaults :fun 3) function)
+  (frob (make-tricky-defaults :num #'identity) fixnum))
+
+(let ((fun (compile nil '(lambda (&key (key (opaque-identity 3)))
+                          (declare (optimize safety) (type integer key))
+                          key))))
+  (assert (= (funcall fun) 3))
+  (assert (= (funcall fun :key 17) 17))
+  (handler-case (funcall fun :key t)
+    (type-error (c) (assert (eq (type-error-expected-type c) 'integer)))
+    (:no-error (&rest vals) (error "no error"))))
+
 ;;; success