Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

3 changed files:

Changes:

  • src/code/error.lisp
    --- 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)
    

  • src/code/exports.lisp
    --- 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
    

  • src/code/macros.lisp
    --- 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.