diff --git a/src/code/error.lisp b/src/code/error.lisp index ee44212c17cd9bf99ff5018a77b28552db51c32a..56a7d54420b3d0362e039257f6e3d9bfaac3c548 100644 --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -25,6 +25,7 @@ simple-file-error simple-program-error simple-parse-error simple-style-warning simple-undefined-function constant-modified + invalid-case #+stack-checking stack-overflow #+heap-overflow-check heap-overflow)) @@ -1115,7 +1116,20 @@ (constant-modified-function-name c)) (print-references (reference-condition-references c) s))) (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3))))) - + +;; For errors in CASE and friends. +(define-condition invalid-case (reference-condition error) + ((name :initarg :name + :reader invalid-case-name) + (format :initarg :format-control + :reader invalid-case-format) + (args :initarg :format-arguments + :reader invalid-case-format-args)) + (:report (lambda (condition stream) + (format stream "~A: " (invalid-case-name condition)) + (apply #'format stream (invalid-case-format condition) (invalid-case-format-args condition)) + (print-references (reference-condition-references condition) stream)))) + (define-condition arithmetic-error (error) ((operation :reader arithmetic-error-operation :initarg :operation :initform nil) diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 773e1d7e300eb73c2b79b5f31d3ac16f074f8703..5e8a8dde65aed6dc70f459f6ccb54f5d304c3c62 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2538,7 +2538,8 @@ "SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-P" "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-ERROR" - "DD-PI")) + "DD-PI" + "INVALID-CASE")) (dolist (name diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 5144cdba0fd6b06aa7032c9853cb2b4d0746eef4..a689b18ae7f0acc4beca46822d20fa9c4afc94b0 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -1366,7 +1366,16 @@ (error (intl:gettext "No default clause allowed in ~S: ~S") name case) (push `(t nil ,@(rest case)) clauses))) ((and (eq name 'case)) - (error (intl:gettext "T and OTHERWISE may not be used as key designators for ~A") name)) + (let ((key (first case))) + (error 'kernel:invalid-case + :name name + :format-control (intl:gettext + "~<~A is a key designator only in the final otherwise-clause. ~ + Use (~A) to use it as a normal-clause or move the clause to the ~ + correct position.~:@>") + :format-arguments (list (list key key)) + :references (list '(:ansi-cl :section (5 3)) + (list :ansi-cl :macro name))))) ((eq (first case) t) ;; The key T is normal clause, because it's not ;; the last clause.