X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=e16d8d60baa163b1d619b9b9af8fbc099becba86;hb=7f008dde7e2c89187a963444e09a8bc594bd9f91;hp=3d163b8f3378974b9e4d69d450c6bdb96c394ff7;hpb=581e3d62de8cb37e13ad9db63e5537c0f962be28;p=sbcl.git

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 3d163b8..e16d8d6 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)))))
@@ -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)
@@ -766,10 +781,10 @@
   ;; information.
   (setf (tail-set-info (lambda-tail-set clambda)) nil))
 
-;;; Handle the environment semantics of LET conversion. We add CLAMBDA
-;;; and its LETs to LETs for the CALL's home function. We merge the
-;;; calls for CLAMBDA with the calls for the home function, removing
-;;; CLAMBDA in the process. We also merge the ENTRIES.
+;;; Handle the PHYSENV semantics of LET conversion. We add CLAMBDA and
+;;; its LETs to LETs for the CALL's home function. We merge the calls
+;;; for CLAMBDA with the calls for the home function, removing CLAMBDA
+;;; in the process. We also merge the ENTRIES.
 ;;;
 ;;; We also unlink the function head from the component head and set
 ;;; COMPONENT-REANALYZE to true to indicate that the DFO should be
@@ -788,20 +803,20 @@
   (depart-from-tail-set clambda)
 
   (let* ((home (node-home-lambda call))
-	 (home-env (lambda-physenv home)))
+	 (home-physenv (lambda-physenv home)))
 
     (aver (not (eq home clambda)))
 
     ;; CLAMBDA belongs to HOME now.
     (push clambda (lambda-lets home))
     (setf (lambda-home clambda) home)
-    (setf (lambda-physenv clambda) home-env)
+    (setf (lambda-physenv clambda) home-physenv)
 
     ;; All of CLAMBDA's LETs belong to HOME now.
     (let ((lets (lambda-lets clambda)))
       (dolist (let lets)
         (setf (lambda-home let) home)
-        (setf (lambda-physenv let) home-env))
+	(setf (lambda-physenv let) home-physenv))
       (setf (lambda-lets home) (nconc lets (lambda-lets home))))
     ;; CLAMBDA no longer has an independent existence as an entity
     ;; which has LETs.
@@ -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)))