0.7.8.48:

        * Fixed printing of call frame when argument list is
          unavailable (reported by CSR on sbcl-devel 2002-10-15)
        * :ALLOW-OTHER-KEYS is an allowed keyword name

diff --git a/BUGS b/BUGS
index 4f7bea2..04f8dca 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1274,7 +1274,6 @@ WORKAROUND:
   b. Compiling of a local call with an unknown key and
      :ALLOW-OTHER-KEYS T should not cause a WARNING.
   c. Compiler should not warn on an unknown key :ALLOW-OTHER-KEYS.
-  d. :ALLOW-OTHER-KEYS should be allowed as an ordinary key parameter.
 
 212: "Sequence functions and circular arguments"
   COERCE, MERGE and CONCATENATE go into an infinite loop when given

diff --git a/NEWS b/NEWS
index 2c56e94..37d2ee8 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1336,6 +1336,8 @@ changes in sbcl-0.7.9 relative to sbcl-0.7.8:
     (reported by Paul F. Dietz, fixed by Gerd Moellman)
   * fixed bug: PUSH, PUSHNEW and POP now evaluate a place given by a
     symbol macro only once
+  * fixed printing of call frame when argument list is unavailable
+  * fixed bug: :ALLOW-OTHER-KEYS is an allowed keyword name
 
 planned incompatible changes in 0.7.x:
 * When the profiling interface settles down, maybe in 0.7.x, maybe

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 67c791f..87d5377 100644 (file)
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -557,19 +557,17 @@ Other commands:
          (nreverse reversed-result))
       (sb!di:lambda-list-unavailable
        ()
-       :lambda-list-unavailable))))
+       (make-unprintable-object "unavailable lambda list")))))
 
 ;;; Print FRAME with verbosity level 1. If we hit a &REST arg, then
 ;;; print as many of the values as possible, punting the loop over
 ;;; lambda-list variables since any other arguments will be in the
 ;;; &REST arg's list of values.
 (defun print-frame-call-1 (frame)
-  (let ((debug-fun (sb!di:frame-debug-fun frame))
-       (loc (sb!di:frame-code-location frame)))
+  (let ((debug-fun (sb!di:frame-debug-fun frame)))
 
     (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")")
-      (let ((args (mapcar #'ensure-printable-object
-                         (frame-args-as-list frame))))
+      (let ((args (ensure-printable-object (frame-args-as-list frame))))
        ;; Since we go to some trouble to make nice informative function
        ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
        ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
@@ -577,7 +575,9 @@ Other commands:
              (*print-level* nil))
          (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun))))
        ;; For the function arguments, we can just print normally.
-       (format t "~{ ~_~S~}" args)))
+        (if (listp args)
+            (format t "~{ ~_~S~}" args)
+            (format t " ~S" args))))
 
     (when (sb!di:debug-fun-kind debug-fun)
       (write-char #\[)

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 702cf50..265034e 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -1204,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
@@ -1639,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)))
@@ -1650,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))))
 

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index b091bdb..33f0a4d 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -499,11 +499,23 @@ BUG 48c, not yet fixed:
       (ignore-errors (delete-file obj)))))
 
 (symbol-macrolet-test)
-\f
+
 ;;; On the x86, this code failed to compile until sbcl-0.7.8.37:
 (defun x86-assembler-failure (x)
   (declare (optimize (speed 3) (safety 0)))
   (eq (setf (car x) 'a) nil))
+
+;;; bug 211: :ALLOW-OTHER-KEYS
+(defun bug211d (&key (x :x x-p) ((:allow-other-keys y) :y y-p))
+  (list x x-p y y-p))
+
+(assert (equal (bug211d) '(:x nil :y nil)))
+(assert (equal (bug211d :x 1) '(1 t :y nil)))
+(assert (raises-error? (bug211d :y 2) program-error))
+(assert (equal (bug211d :y 2 :allow-other-keys t :allow-other-keys nil)
+               '(:x nil t t)))
+(assert (raises-error? (bug211d :y 2 :allow-other-keys nil) program-error))
+
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself

diff --git a/version.lisp-expr b/version.lisp-expr
index 9b27384..3962ccb 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.8.47"
+"0.7.8.48"