Define undefined conditions and handler functions following error-fun='error pattern

(Alan Ruttenberg)

Activation of function are in in comments for now, pending solving boot issues.

On malformed destructuring-bind, bogus-sublist-error was being
signaled, but said condition didn't exist, and so true error was

On review this code seems to be adapted from CMUCL, but special casing
error-fun = 'error and using program-error instead of the conditions.

I brought over the conditions from CMUCL, which are in a comment at
the bottom - they should loaded only after clos - wasn't sure of the

I then defined a function for bogus-sublist error, based on the
reports for the condition, and replaced arg-count-error with the more
detailed report as well.

Merges <>.

parent 2e6db6a7
......@@ -69,6 +69,25 @@
:format-control "Wrong number of arguments for ~S."
:format-arguments (list name)))
(defun bogus-sublist-error (&key kind name object lambda-list)
(error 'program-error
:format-control "Error while parsing arguments to ~A ~S:~%Bogus sublist:~% ~S~%to satisfy lambda-list:~% ~:S~%"
:format-arguments (list kind name object lambda-list)))
(defun lambda-list-broken-key-list-error (&key kind name problem info)
(error 'program-error
:format-control (concatenate 'string "Error while parsing arguments to ~A ~S:~%"
(ecase problem
"Keyword/value list is dotted: ~S")
"Odd number of elements in keyword/value list: ~S")
"Duplicate keyword: ~S")
"~{Unknown keyword: ~S ; expected one of ~{~S~^, ~}~}")))
:format-arguments (list kind name info)))
;;; Return, as multiple values, a body, possibly a DECLARE form to put
;;; where this code is inserted, the documentation for the parsed
;;; body, and bounds on the number of arguments.
......@@ -308,9 +327,11 @@
(verify-keywords ,rest-name ',keys ',allow-other-keys-p)
(when ,problem
,(if (eq error-fun 'error)
`(error 'program-error
"Unrecognized keyword argument ~S"
(car ,info))
:kind ',error-kind
,@(when name `(:name ',name))
:problem ,problem
:info ,info)
:kind ',error-kind
......@@ -327,11 +348,17 @@
(let ((,var ,path))
(if (listp ,var)
(,error-fun 'defmacro-bogus-sublist-error
:kind ',error-kind
,@(when name `(:name ',name))
:object ,var
:lambda-list ',object))))
,(if (eq error-fun 'error)
:kind ',error-kind
,@(when name `(:name ',name))
:object ,var
:lambda-list ',object)
`(,error-fun 'defmacro-bogus-sublist-error
:kind ',error-kind
,@(when name `(:name ',name))
:object ,var
:lambda-list ',object)))))
(defun push-let-binding (variable path systemp &optional condition
......@@ -380,3 +407,89 @@
(body (parse-defmacro lambda-list form (cddr definition) name 'defmacro
:environment env)))
`(lambda (,form ,env) (block ,name ,body))))
These conditions might be signaled but are not defined. Probably can't define them here as clos might not be active.
Taken from cmucl.
(define-condition defmacro-lambda-list-bind-error (program-error)
((kind :reader defmacro-lambda-list-bind-error-kind
:initarg :kind)
(name :reader defmacro-lambda-list-bind-error-name
:initarg :name
:initform nil)))
(defun print-defmacro-ll-bind-error-intro (condition stream)
(if (null (defmacro-lambda-list-bind-error-name condition))
(format stream
"Error while parsing arguments to ~A in ~S:~%"
(defmacro-lambda-list-bind-error-kind condition)
(condition-function-name condition))
(format stream
"Error while parsing arguments to ~A ~S:~%"
(defmacro-lambda-list-bind-error-kind condition)
(defmacro-lambda-list-bind-error-name condition))))
(define-condition defmacro-bogus-sublist-error
((object :reader defmacro-bogus-sublist-error-object :initarg :object)
(lambda-list :reader defmacro-bogus-sublist-error-lambda-list
:initarg :lambda-list))
(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)))))
(define-condition 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
:initarg :lambda-list)
(minimum :reader defmacro-ll-arg-count-error-minimum :initarg :minimum)
(maximum :reader defmacro-ll-arg-count-error-maximum :initarg :maximum))
(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 "Expected at least ~D"
(defmacro-ll-arg-count-error-minimum condition)))
((= (defmacro-ll-arg-count-error-minimum condition)
(defmacro-ll-arg-count-error-maximum condition))
(format stream "Expected exactly ~D"
(defmacro-ll-arg-count-error-minimum condition)))
(format stream "Expected between ~D and ~D"
(defmacro-ll-arg-count-error-minimum condition)
(defmacro-ll-arg-count-error-maximum condition))))
(format stream ", but got ~D."
(length (defmacro-ll-arg-count-error-argument condition))))))
(define-condition defmacro-lambda-list-broken-key-list-error
((problem :reader defmacro-ll-broken-key-list-error-problem
:initarg :problem)
(info :reader defmacro-ll-broken-key-list-error-info :initarg :info))
(:report (lambda (condition stream)
(print-defmacro-ll-bind-error-intro condition stream)
(format stream
(defmacro-ll-broken-key-list-error-problem condition)
"Keyword/value list is dotted: ~S")
"Odd number of elements in keyword/value list: ~S")
"Duplicate keyword: ~S")
"~{Unknown keyword: ~S; expected one of ~{~S~^, ~}~}"))
(defmacro-ll-broken-key-list-error-info condition)))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or sign in to comment