From feba3c704ebcf93a3351422fcc6cf8fa60b2637e Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sat, 26 Feb 2011 16:37:25 +0000
Subject: [PATCH] 1.0.45.14: CHECK-KEY-ARGS didn't take :ALLOW-OTHER-KEYS into
 account

  Cases of interest are:

  * No :ALLOW-OTHER-KEYS present for sure.

  * :ALLOW-OTHER-KEYS with a non-constant argument, or a non-constant
    keyword argument which may turn out to be :ALLOW-OTHER-KEYS at
    runtime.

  * Constant :ALLOW-OTHER-KEYS NIL.

  * Constant :ALLOW-OTHER-KEYS T.

  Thanks to Xach for the heads-up!
---
 NEWS                     |    2 ++
 src/compiler/ctype.lisp  |   64 ++++++++++++++++++++++++++++++----------------
 tests/compiler.pure.lisp |    5 ++++
 version.lisp-expr        |    2 +-
 4 files changed, 50 insertions(+), 23 deletions(-)

diff --git a/NEWS b/NEWS
index bcc676a..b077ffa 100644
--- a/NEWS
+++ b/NEWS
@@ -15,6 +15,8 @@ changes relative to sbcl-1.0.46:
     second argument reports a more sensible error. (lp#718905)
   * bug fix: invalid combinations of :PREDICATE and :TYPE options in DEFSTRUCT
     are detected. (lp#520607)
+  * bug fix: constant keyword argument checking didn't take :ALLOW-OTHER-KEYS
+    into account.
 
 changes in sbcl-1.0.46 relative to sbcl-1.0.45:
   * enhancement: largefile support on Solaris.
diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 8e1940b..dc9cffd 100644
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -244,28 +244,48 @@
 ;;; complain about absence of manifest winnage.
 (declaim (ftype (function (list fixnum fun-type) (values)) check-key-args))
 (defun check-key-args (args pre-key type)
-  (do ((key (nthcdr pre-key args) (cddr key))
-       (n (1+ pre-key) (+ n 2)))
-      ((null key))
-    (declare (fixnum n))
-    (let ((k (car key)))
-      (cond
-       ((not (check-arg-type k (specifier-type 'symbol) n)))
-       ((not (constant-lvar-p k))
-        (note-unwinnage "The ~:R argument (in keyword position) is not a ~
-                         constant."
-                        n))
-       (t
-        (let* ((name (lvar-value k))
-               (info (find name (fun-type-keywords type)
-                           :key #'key-info-name)))
-          (cond ((not info)
-                 (unless (fun-type-allowp type)
-                   (note-lossage "~S is not a known argument keyword."
-                                 name)))
-                (t
-                 (check-arg-type (second key) (key-info-type info)
-                                 (1+ n)))))))))
+  (let (lossages allow-other-keys)
+    (do ((key (nthcdr pre-key args) (cddr key))
+         (n (1+ pre-key) (+ n 2)))
+        ((null key))
+      (declare (fixnum n))
+      (let ((k (first key))
+            (v (second key)))
+        (cond
+          ((not (check-arg-type k (specifier-type 'symbol) n)))
+          ((not (constant-lvar-p k))
+           (note-unwinnage "~@<The ~:R argument (in keyword position) is not ~
+                            a constant, weakening keyword argument ~
+                            checking.~:@>" n)
+           ;; An unknown key may turn out to be :ALLOW-OTHER-KEYS at runtime,
+           ;; so we cannot signal full warnings for keys that look bad.
+           (unless allow-other-keys
+             (setf allow-other-keys :maybe)))
+          (t
+           (let* ((name (lvar-value k))
+                  (info (find name (fun-type-keywords type)
+                              :key #'key-info-name)))
+             (cond ((eq name :allow-other-keys)
+                    (unless allow-other-keys
+                      (if (constant-lvar-p v)
+                          (setf allow-other-keys (if (lvar-value v)
+                                                     :yes
+                                                     :no))
+                          (setf allow-other-keys :maybe))))
+                   ((not info)
+                    (unless (fun-type-allowp type)
+                      (pushnew name lossages :test #'eq)))
+                   (t
+                    (check-arg-type (second key) (key-info-type info)
+                                    (1+ n)))))))))
+    (when (and lossages (member allow-other-keys '(nil :no)))
+      (setf lossages (nreverse lossages))
+      (if (cdr lossages)
+          (note-lossage "~@<~{~S~^, ~} and ~S are not a known argument keywords.~:@>"
+                        (butlast lossages)
+                        (car (last lossages)))
+          (note-lossage "~S is not a known argument keyword."
+                        (car lossages)))))
   (values))
 
 ;;; Construct a function type from a definition.
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 0cd2fac..a41b164 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3765,3 +3765,8 @@
   (let ((f (eval '(constantly 42))))
     (handler-bind ((warning #'error))
       (assert (= 42 (funcall (compile nil `(lambda () (funcall ,f 1 2 3)))))))))
+
+(with-test (:name :known-fun-allows-other-keys)
+  (handler-bind ((warning #'error))
+    (funcall (compile nil '(lambda () (directory "." :allow-other-keys t))))
+    (funcall (compile nil `(lambda () (directory "." :bar t :allow-other-keys t))))))
diff --git a/version.lisp-expr b/version.lisp-expr
index a51d9aa..ad59cd3 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.46.13"
+"1.0.46.14"
-- 
1.7.10.4