X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=c5f7b4184d7edb1aa2a1f78b9a0697486ff09a09;hb=ee3bfc5a989b5c0a1ea5a094e9541169ea2eb4ad;hp=38866b91d06be644c53f940c8a0cc2b05c314d42;hpb=cad792b6636677ceb5f3652f8d21292cfd073c55;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 38866b9..c5f7b41 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -903,7 +903,7 @@
   (declare (list decl vars) (type lexenv res))
   (let ((type (compiler-specifier-type (first decl))))
     (collect ((restr nil cons)
-	      (new-vars nil cons))
+             (new-vars nil cons))
       (dolist (var-name (rest decl))
 	(let* ((bound-var (find-in-bindings vars var-name))
 	       (var (or bound-var
@@ -911,26 +911,31 @@
 			(find-free-var var-name))))
 	  (etypecase var
 	    (leaf
-	     (let* ((old-type (or (lexenv-find var type-restrictions)
-				  (leaf-type var)))
-		    (int (if (or (fun-type-p type)
-				 (fun-type-p old-type))
-			     type
-			     (type-approx-intersection2 old-type type))))
-	       (cond ((eq int *empty-type*)
-		      (unless (policy *lexenv* (= inhibit-warnings 3))
-			(compiler-warn
-			 "The type declarations ~S and ~S for ~S conflict."
-			 (type-specifier old-type) (type-specifier type)
-			 var-name)))
-		     (bound-var (setf (leaf-type bound-var) int))
-		     (t
-		      (restr (cons var int))))))
+             (flet ((process-var (var bound-var)
+                      (let* ((old-type (or (lexenv-find var type-restrictions)
+                                           (leaf-type var)))
+                             (int (if (or (fun-type-p type)
+                                          (fun-type-p old-type))
+                                      type
+                                      (type-approx-intersection2 old-type type))))
+                        (cond ((eq int *empty-type*)
+                               (unless (policy *lexenv* (= inhibit-warnings 3))
+                                 (compiler-warn
+                                  "The type declarations ~S and ~S for ~S conflict."
+                                  (type-specifier old-type) (type-specifier type)
+                                  var-name)))
+                              (bound-var (setf (leaf-type bound-var) int))
+                              (t
+                               (restr (cons var int)))))))
+               (process-var var bound-var)
+               (awhen (and (lambda-var-p var)
+                           (lambda-var-specvar var))
+                      (process-var it nil))))
 	    (cons
 	     ;; FIXME: non-ANSI weirdness
 	     (aver (eq (car var) 'MACRO))
 	     (new-vars `(,var-name . (MACRO . (the ,(first decl)
-						   ,(cdr var))))))
+                                                ,(cdr var))))))
 	    (heap-alien-info
 	     (compiler-error
 	      "~S is an alien variable, so its type can't be declared."
@@ -1530,12 +1535,21 @@
 			      :where-from (leaf-where-from var)
 			      :specvar (lambda-var-specvar var)))
 			   fvars))
-	 (fun (ir1-convert-lambda-body `((%funcall ,fun
-						   ,@(reverse vals)
-						   ,@defaults))
-				       arg-vars
-				       :debug-name "&OPTIONAL processor"
-                                       :note-lexical-bindings nil)))
+	 (fun (collect ((default-bindings)
+                        (default-vals))
+                (dolist (default defaults)
+                  (if (constantp default)
+                      (default-vals default)
+                      (let ((var (gensym)))
+                        (default-bindings `(,var ,default))
+                        (default-vals var))))
+                (ir1-convert-lambda-body `((let (,@(default-bindings))
+                                             (%funcall ,fun
+                                                       ,@(reverse vals)
+                                                       ,@(default-vals))))
+                                         arg-vars
+                                         :debug-name "&OPTIONAL processor"
+                                         :note-lexical-bindings nil))))
     (mapc (lambda (var arg-var)
 	    (when (cdr (leaf-refs arg-var))
 	      (setf (leaf-ever-used var) t)))