X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=304142d62f55023f9534e3f34be1f08ef1186e7e;hb=7ce2c42adf3d62f03086de940adaee48e6161a40;hp=cc552d36e68e98679ce53fd3460f7280604cecfb;hpb=9347abeb5f42dc83d372c19b14e86204a6a588dd;p=sbcl.git

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index cc552d3..304142d 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -40,7 +40,8 @@
     (let ((arg (car args))
 	  (var (car vars)))
       (cond ((leaf-refs var)
-	     (assert-continuation-type arg (leaf-type var)))
+	     (assert-continuation-type arg (leaf-type var)
+                                       (lexenv-policy (node-lexenv call))))
 	    (t
 	     (flush-dest arg)
 	     (setf (car args) nil)))))
@@ -427,7 +428,7 @@
   (values))
 
 ;;; Attempt to convert a multiple-value call. The only interesting
-;;; case is a call to a function that Looks-Like-An-MV-Bind, has
+;;; case is a call to a function that LOOKS-LIKE-AN-MV-BIND, has
 ;;; exactly one reference and no XEP, and is called with one values
 ;;; continuation.
 ;;;
@@ -456,7 +457,8 @@
       (assert-continuation-type
        (first (basic-combination-args call))
        (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
-			 :rest *universal-type*))))
+			 :rest *universal-type*)
+       (lexenv-policy (node-lexenv call)))))
   (values))
 
 ;;; Attempt to convert a call to a lambda. If the number of args is
@@ -578,6 +580,8 @@
 	 (flame (policy call (or (> speed inhibit-warnings)
 				 (> space inhibit-warnings))))
 	 (loser nil)
+         (allowp nil)
+         (allow-found nil)
 	 (temps (make-gensym-list max))
 	 (more-temps (make-gensym-list (length more))))
     (collect ((ignores)
@@ -617,17 +621,28 @@
 	    (let ((name (continuation-value cont))
 		  (dummy (first temp))
 		  (val (second temp)))
+              ;; FIXME: check whether KEY was supplied earlier
+              (when (and (eq name :allow-other-keys) (not allow-found))
+                (let ((val (second key)))
+                  (cond ((constant-continuation-p val)
+                         (setq allow-found t
+                               allowp (continuation-value val)))
+                        (t (when flame
+                             (compiler-note "non-constant :ALLOW-OTHER-KEYS value"))
+                           (setf (basic-combination-kind call) :error)
+                           (return-from convert-more-call)))))
 	      (dolist (var (key-vars)
 			   (progn
 			     (ignores dummy val)
-			     (setq loser name)))
+                             (unless (eq name :allow-other-keys)
+                               (setq loser name))))
 		(let ((info (lambda-var-arg-info var)))
 		  (when (eq (arg-info-key info) name)
 		    (ignores dummy)
 		    (supplied (cons var val))
 		    (return)))))))
 
-	(when (and loser (not (optional-dispatch-allowp fun)))
+	(when (and loser (not (optional-dispatch-allowp fun)) (not allowp))
 	  (compiler-warn "function called with unknown argument keyword ~S"
 			 loser)
 	  (setf (basic-combination-kind call) :error)
@@ -854,7 +869,10 @@
 	  (cont (node-cont call))
 	  (call-type (node-derived-type call)))
       (when (eq (continuation-use cont) call)
-	(assert-continuation-type cont (continuation-asserted-type result)))
+        (set-continuation-type-assertion
+         cont
+         (continuation-asserted-type result)
+         (continuation-type-to-check result)))
       (unless (eq call-type *wild-type*)
 	(do-uses (use result)
 	  (derive-node-type use call-type)))