X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro-errors.lisp;h=b4bc377108cdcad96a56554e413b16931f4d5b1c;hb=8286d1fc02d1e769a766fbf1670bca474237161f;hp=0ec4b1c6089a4b5fa077b24c1284f9946f0d194e;hpb=872175cd9cb5b4966a36d4bd92421cc407a0355b;p=sbcl.git diff --git a/src/code/parse-defmacro-errors.lisp b/src/code/parse-defmacro-errors.lisp index 0ec4b1c..b4bc377 100644 --- a/src/code/parse-defmacro-errors.lisp +++ b/src/code/parse-defmacro-errors.lisp @@ -1,9 +1,6 @@ ;;;; error-handling machinery for PARSE-DEFMACRO, separated from ;;;; PARSE-DEFMACRO code itself because the happy path can be handled -;;;; earlier in the bootstrap sequence than DEFINE-CONDITION can be, -;;;; and because some of the error handling depends on SBCL -;;;; extensions, while PARSE-DEFMACRO needs to run in the -;;;; cross-compiler on the host Common Lisp +;;;; earlier in the bootstrap sequence than DEFINE-CONDITION can be ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -17,16 +14,16 @@ (in-package "SB!KERNEL") ;;; We save space in macro definitions by calling this function. -(defun do-arg-count-error (error-kind name arg lambda-list minimum maximum) - (multiple-value-bind (fname sb!debug:*stack-top-hint*) - (find-caller-name-and-frame) - (declare (ignorable fname)) - (error 'defmacro-ll-arg-count-error +(defun arg-count-error (error-kind name args lambda-list minimum maximum) + (let (#-sb-xc-host + (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) + (error 'arg-count-error :kind error-kind :name name - :argument arg + :args args :lambda-list lambda-list - :minimum minimum :maximum maximum))) + :minimum minimum + :maximum maximum))) (define-condition defmacro-lambda-list-bind-error (error) ((kind :reader defmacro-lambda-list-bind-error-kind @@ -35,71 +32,92 @@ :initarg :name :initform nil))) -(defun print-defmacro-ll-bind-error-intro (condition stream) - (format stream - "error while parsing arguments to ~A~@[ ~S~]:~%" - (defmacro-lambda-list-bind-error-kind condition) - (defmacro-lambda-list-bind-error-name condition))) +;;; shared logic for REPORTing variants of DEFMACRO-LAMBDA-LIST-BIND-ERROR: +;;; Set up appropriate prettying and indentation on STREAM, print some +;;; boilerplate related to CONDITION (an instance of +;;; DEFMACRO-LAMBDA-LIST-BIND-ERROR), then execute BODY. +(defmacro !printing-defmacro-lambda-list-bind-error ((condition stream) + &body body) + `(%printing-defmacro-lambda-list-bind-error ,condition + ,stream + (lambda (,stream) + (declare (type stream ,stream)) + ,@body))) +(defun %printing-defmacro-lambda-list-bind-error (condition stream fun) + (declare (type stream stream) (type function fun)) + (pprint-logical-block (stream nil) + (format stream + "error while parsing arguments to ~A~@[ ~S~]:~2I~:@_" + (defmacro-lambda-list-bind-error-kind condition) + (defmacro-lambda-list-bind-error-name condition)) + (pprint-logical-block (stream nil) + (funcall fun stream)))) (define-condition defmacro-bogus-sublist-error - (defmacro-lambda-list-bind-error) + (defmacro-lambda-list-bind-error) ((object :reader defmacro-bogus-sublist-error-object :initarg :object) (lambda-list :reader defmacro-bogus-sublist-error-lambda-list :initarg :lambda-list)) (:report (lambda (condition stream) - (print-defmacro-ll-bind-error-intro condition stream) - (format stream - "bogus sublist:~% ~S~%to satisfy lambda-list:~% ~:S~%" - (defmacro-bogus-sublist-error-object condition) - (defmacro-bogus-sublist-error-lambda-list condition))))) + (!printing-defmacro-lambda-list-bind-error (condition stream) + (format stream + "bogus sublist ~2I~_~S ~I~_to satisfy lambda-list ~2I~_~:S" + (defmacro-bogus-sublist-error-object condition) + (defmacro-bogus-sublist-error-lambda-list condition)))))) -(define-condition defmacro-ll-arg-count-error (defmacro-lambda-list-bind-error) - ((argument :reader defmacro-ll-arg-count-error-argument :initarg :argument) - (lambda-list :reader defmacro-ll-arg-count-error-lambda-list +(define-condition arg-count-error (defmacro-lambda-list-bind-error) + ((args :reader arg-count-error-args :initarg :args) + (lambda-list :reader arg-count-error-lambda-list :initarg :lambda-list) - (minimum :reader defmacro-ll-arg-count-error-minimum :initarg :minimum) - (maximum :reader defmacro-ll-arg-count-error-maximum :initarg :maximum)) + (minimum :reader arg-count-error-minimum :initarg :minimum) + (maximum :reader arg-count-error-maximum :initarg :maximum)) (:report (lambda (condition stream) - (print-defmacro-ll-bind-error-intro condition stream) - (format stream - "invalid number of elements in:~% ~:S~%~ - to satisfy lambda-list:~% ~:S~%" - (defmacro-ll-arg-count-error-argument condition) - (defmacro-ll-arg-count-error-lambda-list condition)) - (cond ((null (defmacro-ll-arg-count-error-maximum condition)) - (format stream "at least ~D expected" - (defmacro-ll-arg-count-error-minimum condition))) - ((= (defmacro-ll-arg-count-error-minimum condition) - (defmacro-ll-arg-count-error-maximum condition)) - (format stream "exactly ~D expected" - (defmacro-ll-arg-count-error-minimum condition))) - (t - (format stream "between ~D and ~D expected" - (defmacro-ll-arg-count-error-minimum condition) - (defmacro-ll-arg-count-error-maximum condition)))) - (format stream ", but ~D found" - (length (defmacro-ll-arg-count-error-argument condition)))))) + (!printing-defmacro-lambda-list-bind-error (condition stream) + (format stream + "invalid number of elements in ~2I~_~:S ~ + ~I~_to satisfy lambda list ~2I~_~:S: ~I~_" + (arg-count-error-args condition) + (arg-count-error-lambda-list condition)) + (cond ((null (arg-count-error-maximum condition)) + (format stream "at least ~W expected" + (arg-count-error-minimum condition))) + ((= (arg-count-error-minimum condition) + (arg-count-error-maximum condition)) + (format stream "exactly ~W expected" + (arg-count-error-minimum condition))) + (t + (format stream "between ~W and ~W expected" + (arg-count-error-minimum condition) + (arg-count-error-maximum condition)))) + (format stream ", but ~W found" + (length (arg-count-error-args condition))))))) -(define-condition defmacro-ll-broken-key-list-error +(define-condition defmacro-lambda-list-broken-key-list-error (defmacro-lambda-list-bind-error) - ((problem :reader defmacro-ll-broken-key-list-error-problem + ((problem :reader defmacro-lambda-list-broken-key-list-error-problem :initarg :problem) - (info :reader defmacro-ll-broken-key-list-error-info :initarg :info)) + (info :reader defmacro-lambda-list-broken-key-list-error-info + :initarg :info)) (:report (lambda (condition stream) - (print-defmacro-ll-bind-error-intro condition stream) - (format stream - ;; FIXME: These should probably just be three - ;; subclasses of the base class, so that we don't - ;; need to maintain the set of tags both here and - ;; implicitly wherever this macro is used. - (ecase - (defmacro-ll-broken-key-list-error-problem condition) - (:dotted-list - "dotted keyword/value list: ~S") - (:odd-length - "odd number of elements in keyword/value list: ~S") - (:unknown-keyword - "~{unknown keyword: ~S; expected one of ~{~S~^, ~}~}")) - (defmacro-ll-broken-key-list-error-info condition))))) + (!printing-defmacro-lambda-list-bind-error (condition stream) + (format stream + ;; FIXME: These should probably just be three + ;; subclasses of the base class, so that we don't + ;; need to maintain the set of tags both here and + ;; implicitly wherever this macro is used. (This + ;; might get easier once CLOS is initialized in + ;; cold init.) + (ecase + (defmacro-lambda-list-broken-key-list-error-problem + condition) + (:dotted-list + "dotted keyword/value list: ~S") + (:odd-length + "odd number of elements in keyword/value list: ~S") + (:unknown-keyword + "~{unknown keyword: ~S; expected one of ~ + ~{~S~^, ~}~}")) + (defmacro-lambda-list-broken-key-list-error-info + condition))))))