X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcompiler%2Fir1tran.lisp;h=265034e27cad21e6cfd8640aa9145d3c7970ade2;hb=4372fa18426aa89379563bcbf61941317c93fce0;hp=0002cb214aad8fd92288ded92c10fb972d399ad2;hpb=ae97d229fa1b74032a5c7cba21840598da6726c8;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 0002cb2..265034e 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -944,7 +944,9 @@
 ;;; declarations that constrain the type of lexically apparent
 ;;; functions.
 (defun process-ftype-decl (spec res names fvars)
-  (declare (list spec names fvars) (type lexenv res))
+  (declare (type type-specifier spec)
+           (type list names fvars)
+           (type lexenv res))
   (let ((type (compiler-specifier-type spec)))
     (collect ((res nil cons))
       (dolist (name names)
@@ -1202,15 +1204,12 @@
 	   (make-lambda-var :%source-name name)))))
 
 ;;; Make the default keyword for a &KEY arg, checking that the keyword
-;;; isn't already used by one of the VARS. We also check that the
-;;; keyword isn't the magical :ALLOW-OTHER-KEYS.
+;;; isn't already used by one of the VARS.
 (declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg))
 (defun make-keyword-for-arg (symbol vars keywordify)
   (let ((key (if (and keywordify (not (keywordp symbol)))
 		 (keywordicate symbol)
 		 symbol)))
-    (when (eq key :allow-other-keys)
-      (compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS."))
     (dolist (var vars)
       (let ((info (lambda-var-arg-info var)))
 	(when (and info
@@ -1637,7 +1636,8 @@
 	      (n-allowp (gensym "N-ALLOWP-"))
 	      (n-losep (gensym "N-LOSEP-"))
 	      (allowp (or (optional-dispatch-allowp res)
-			  (policy *lexenv* (zerop safety)))))
+			  (policy *lexenv* (zerop safety))))
+              (found-allow-p nil))
 
 	  (temps `(,n-index (1- ,n-count)) n-key n-value-temp)
 	  (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
@@ -1648,24 +1648,30 @@
 		     (default (arg-info-default info))
 		     (keyword (arg-info-key info))
 		     (supplied-p (arg-info-supplied-p info))
-		     (n-value (gensym "N-VALUE-")))
-		(temps `(,n-value ,default))
-		(cond (supplied-p
-		       (let ((n-supplied (gensym "N-SUPPLIED-")))
-			 (temps n-supplied)
-			 (arg-vals n-value n-supplied)
-			 (tests `((eq ,n-key ',keyword)
-				  (setq ,n-supplied t)
-				  (setq ,n-value ,n-value-temp)))))
-		      (t
-		       (arg-vals n-value)
-		       (tests `((eq ,n-key ',keyword)
-				(setq ,n-value ,n-value-temp)))))))
+		     (n-value (gensym "N-VALUE-"))
+                     (clause (cond (supplied-p
+                                    (let ((n-supplied (gensym "N-SUPPLIED-")))
+                                      (temps n-supplied)
+                                      (arg-vals n-value n-supplied)
+                                      `((eq ,n-key ',keyword)
+                                        (setq ,n-supplied t)
+                                        (setq ,n-value ,n-value-temp))))
+                                   (t
+                                    (arg-vals n-value)
+                                    `((eq ,n-key ',keyword)
+                                      (setq ,n-value ,n-value-temp))))))
+		(when (and (not allowp) (eq keyword :allow-other-keys))
+                  (setq found-allow-p t)
+                  (setq clause (append clause `((setq ,n-allowp ,n-value-temp)))))
+
+                (temps `(,n-value ,default))
+		(tests clause)))
 
 	    (unless allowp
 	      (temps n-allowp n-losep)
-	      (tests `((eq ,n-key :allow-other-keys)
-		       (setq ,n-allowp ,n-value-temp)))
+              (unless found-allow-p
+                (tests `((eq ,n-key :allow-other-keys)
+                         (setq ,n-allowp ,n-value-temp))))
 	      (tests `(t
 		       (setq ,n-losep ,n-key))))