From beb2077d0131ab82632a6353bd1366079e038c72 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Thu, 9 Feb 2017 00:50:35 +0300 Subject: [PATCH] CONTINUE restart for %UNKNOWN-KEY-ARG-ERROR. --- src/code/interr.lisp | 17 ++++++++++++++--- src/compiler/debug-dump.lisp | 20 +++++++++++--------- src/compiler/fndb.lisp | 2 +- src/compiler/generic/type-error.lisp | 5 +++-- src/compiler/generic/vm-fndb.lisp | 2 ++ src/compiler/ir1tran-lambda.lisp | 6 ++++-- src/compiler/ir2tran.lisp | 4 ++++ src/compiler/locall.lisp | 2 +- tests/condition.impure.lisp | 6 ++++++ 9 files changed, 46 insertions(+), 18 deletions(-) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 8e1637b84..5ad225c1f 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -239,9 +239,20 @@ :format-control "odd number of &KEY arguments")) (deferr unknown-key-arg-error (key-name) - (error 'simple-program-error - :format-control "unknown &KEY argument: ~S" - :format-arguments (list key-name))) + (let ((context (sb!di:error-context))) + (if (integerp context) + (restart-case + (error 'simple-program-error + :format-control "unknown &KEY argument: ~S" + :format-arguments (list key-name)) + (continue () + :report (lambda (stream) + (format stream "Ignore it.")) + (sb!vm::incf-context-pc *current-internal-error-context* + context))) + (error 'simple-program-error + :format-control "unknown &KEY argument: ~S" + :format-arguments (list key-name))))) ;; TODO: make the arguments (ARRAY INDEX &optional BOUND) ;; and don't need the bound for vectors. Just read it. diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 54a5d82a0..1740f499a 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -39,12 +39,12 @@ ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.) (vop nil :type vop)) -(defstruct (restart-location - (:constructor make-restart-location (label tn)) - (:predicate nil) +(def!struct (restart-location + (:constructor make-restart-location (&optional label tn)) (:copier nil)) - (label nil :type label :read-only t) - (tn nil :type tn :read-only t)) + (label nil :type (or null label)) + (tn nil :type (or null tn) :read-only t)) +(!set-load-form-method restart-location (:xc :target) :ignore-it) ;;; This is called during code generation in places where there is an ;;; "interesting" location: someplace where we are likely to end up @@ -120,12 +120,14 @@ (defun encode-restart-location (location x) (typecase x (restart-location - (let ((tn-offset (tn-offset (restart-location-tn x))) - (offset (- (label-position (restart-location-label x)) + (let ((offset (- (label-position (restart-location-label x)) location)) + (tn (restart-location-tn x)) (registers-size #.(integer-length (sb-size (sb-or-lose 'sb!vm::registers))))) - (the fixnum (logior (ash offset registers-size) - tn-offset)))) + (if tn + (the fixnum (logior (ash offset registers-size) + (tn-offset tn))) + offset))) (t x))) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 7bfccc597..44ef8732f 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1665,7 +1665,7 @@ (defknown (etypecase-failure ecase-failure) (t t) nil) (defknown %odd-key-args-error () nil) -(defknown %unknown-key-arg-error (t) nil) +(defknown %unknown-key-arg-error (t t) nil) (defknown (%ldb %mask-field) (bit-index bit-index integer) unsigned-byte (movable foldable flushable)) (defknown (%dpb %deposit-field) (integer bit-index bit-index integer) integer diff --git a/src/compiler/generic/type-error.lisp b/src/compiler/generic/type-error.lisp index e0598be13..d35d2835f 100644 --- a/src/compiler/generic/type-error.lisp +++ b/src/compiler/generic/type-error.lisp @@ -100,7 +100,8 @@ args)) ,@(and context `((:info *location-context*) - (:arg-types * * (:constant t)))) + (:arg-types ,@(make-list (length args) :initial-element '*) + (:constant t)))) (:vop-var vop) (:save-p :compute-only) (:generator 1000 @@ -116,7 +117,7 @@ (def odd-key-args-error odd-key-args-error sb!c::%odd-key-args-error nil) (def unknown-key-arg-error unknown-key-arg-error - sb!c::%unknown-key-arg-error nil key) + sb!c::%unknown-key-arg-error t key) (def nil-fun-returned-error nil-fun-returned-error nil nil fun)) (defun encode-internal-error-args (values) diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index c203db7f7..b66461497 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -465,3 +465,5 @@ (defknown %data-vector-and-index (array index) (values (simple-array * (*)) index) (foldable flushable)) + +(defknown restart-point (t) t ()) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 4bf0c49ed..7ec5172e4 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -628,8 +628,10 @@ (cond ,@(tests)))))) (unless allowp - (body `(when (and (/= ,n-losep 0) (not ,n-allowp)) - (%unknown-key-arg-error ,n-lose))))))) + (let ((location (make-restart-location))) + (body `(if (and (/= ,n-losep 0) (not ,n-allowp)) + (%unknown-key-arg-error ,n-lose ,location) + (restart-point ,location)))))))) (let ((ep (ir1-convert-lambda-body `((let ,(temps) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 596274509..8ba93706b 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -2052,6 +2052,10 @@ not stack-allocated LVAR ~S." source-lvar))))) (let ((*compiler-error-context* node)) (compiler-warn "violating package lock on ~/sb-impl:print-symbol-with-prefix/" symbol)))))) + +(defoptimizer (restart-point ir2-convert) ((location) node block) + (setf (restart-location-label (lvar-value location)) + (block-label (ir2-block-block block)))) ;;; Convert the code in a component into VOPs. (defun ir2-convert (component) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 228bfabbc..007aa9294 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -730,7 +730,7 @@ call `(lambda (&rest args) (declare (ignore args)) - (%unknown-key-arg-error ',(car loser))) + (%unknown-key-arg-error ',(car loser) nil)) '%unknown-key-arg-error) (return-from convert-more-call))) diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp index 94ee009f3..795757539 100644 --- a/tests/condition.impure.lisp +++ b/tests/condition.impure.lisp @@ -536,3 +536,9 @@ (assert (eq (test-use-value tail-call) 10)) (assert (eq (test-use-value call) 11)) (assert (eq (test-use-value return) value-lambda))))) + +(with-test (:name :unknown-key-restart) + (handler-bind ((error #'continue)) + (assert (= (funcall (checked-compile '(lambda (&key abc) (1+ abc))) + :bogus 30 :abc 20) + 21)))) -- 2.11.4.GIT