From: Alexey Dejneka Date: Sat, 19 Oct 2002 05:59:46 +0000 (+0000) Subject: 0.7.8.48: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=4372fa18426aa89379563bcbf61941317c93fce0;hp=2b277125b2d14a05710d7c8e4c0a22f97eea662a;p=sbcl.git 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 --- 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 --- 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 --- 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 --- 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 --- 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) - + ;;; 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)) + ;;;; 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 --- 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"