0.7.9.41:

[sbcl.git] / src / compiler / locall.lisp

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index cc552d3..304142d 100644 (file)
--- 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)))