From 1ae37c6f729950b6925275cea43546b701d8fde2 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sat, 26 Jun 2004 17:28:11 +0000 Subject: [PATCH] 0.8.12.4: MORE REFERENCES ... rearrange src/code/condition.lisp a little to allow slightly more references to appear; ... add some references in various error-producing forms in PCL --- src/code/condition.lisp | 273 +++++++++++++++++++++++++---------------------- src/pcl/boot.lisp | 34 +++--- src/pcl/defcombin.lisp | 17 ++- src/pcl/defs.lisp | 2 +- src/pcl/methods.lisp | 14 ++- version.lisp-expr | 2 +- 6 files changed, 188 insertions(+), 154 deletions(-) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index f8e70f3..5345544 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -583,6 +583,9 @@ (define-condition simple-error (simple-condition error) ()) +;;; not specified by ANSI, but too useful not to have around. +(define-condition simple-style-warning (simple-condition style-warning) ()) + (define-condition storage-condition (serious-condition) ()) (define-condition type-error (error) @@ -717,133 +720,6 @@ (reader-error-format-control condition) (reader-error-format-arguments condition))))))) -;;;; various other (not specified by ANSI) CONDITIONs -;;;; -;;;; These might logically belong in other files; they're here, after -;;;; setup of CONDITION machinery, only because that makes it easier to -;;;; get cold init to work. - -(define-condition simple-style-warning (simple-condition style-warning) ()) - -(define-condition values-type-error (type-error) - () - (:report - (lambda (condition stream) - (format stream - "~@" - (type-error-datum condition) - (type-error-expected-type condition))))) - -;;; KLUDGE: a condition for floating point errors when we can't or -;;; won't figure out what type they are. (In FreeBSD and OpenBSD we -;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably -;;; know how but the old code was broken by the conversion to POSIX -;;; signal handling and hasn't been fixed as of sbcl-0.6.7.) -;;; -;;; FIXME: Perhaps this should also be a base class for all -;;; floating point exceptions? -(define-condition floating-point-exception (arithmetic-error) - ((flags :initarg :traps - :initform nil - :reader floating-point-exception-traps)) - (:report (lambda (condition stream) - (format stream - "An arithmetic error ~S was signalled.~%" - (type-of condition)) - (let ((traps (floating-point-exception-traps condition))) - (if traps - (format stream - "Trapping conditions are: ~%~{ ~S~^~}~%" - traps) - (write-line - "No traps are enabled? How can this be?" - stream)))))) - -(define-condition index-too-large-error (type-error) - () - (:report - (lambda (condition stream) - (format stream - "The index ~S is too large." - (type-error-datum condition))))) - -(define-condition bounding-indices-bad-error (type-error) - ((object :reader bounding-indices-bad-object :initarg :object)) - (:report - (lambda (condition stream) - (let* ((datum (type-error-datum condition)) - (start (car datum)) - (end (cdr datum)) - (object (bounding-indices-bad-object condition))) - (etypecase object - (sequence - (format stream - "The bounding indices ~S and ~S are bad for a sequence of length ~S." - start end (length object))) - (array - ;; from WITH-ARRAY-DATA - (format stream - "The START and END parameters ~S and ~S are bad for an array of total size ~S." - start end (array-total-size object)))))))) - -(define-condition nil-array-accessed-error (type-error) - () - (:report (lambda (condition stream) - (declare (ignore condition)) - (format stream - "An attempt to access an array of element-type ~ - NIL was made. Congratulations!")))) - -(define-condition io-timeout (stream-error) - ((direction :reader io-timeout-direction :initarg :direction)) - (:report - (lambda (condition stream) - (declare (type stream stream)) - (format stream - "I/O timeout ~(~A~)ing ~S" - (io-timeout-direction condition) - (stream-error-stream condition))))) - -(define-condition namestring-parse-error (parse-error) - ((complaint :reader namestring-parse-error-complaint :initarg :complaint) - (args :reader namestring-parse-error-args :initarg :args :initform nil) - (namestring :reader namestring-parse-error-namestring :initarg :namestring) - (offset :reader namestring-parse-error-offset :initarg :offset)) - (:report - (lambda (condition stream) - (format stream - "parse error in namestring: ~?~% ~A~% ~V@T^" - (namestring-parse-error-complaint condition) - (namestring-parse-error-args condition) - (namestring-parse-error-namestring condition) - (namestring-parse-error-offset condition))))) - -(define-condition simple-package-error (simple-condition package-error) ()) - -(define-condition reader-package-error (reader-error) ()) - -(define-condition reader-eof-error (end-of-file) - ((context :reader reader-eof-error-context :initarg :context)) - (:report - (lambda (condition stream) - (format stream - "unexpected end of file on ~S ~A" - (stream-error-stream condition) - (reader-eof-error-context condition))))) - -(define-condition reader-impossible-number-error (reader-error) - ((error :reader reader-impossible-number-error-error :initarg :error)) - (:report - (lambda (condition stream) - (let ((error-stream (stream-error-stream condition))) - (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A" - (file-position error-stream) error-stream - (reader-error-format-control condition) - (reader-error-format-arguments condition) - (reader-impossible-number-error-error condition)))))) - -(define-condition timeout (serious-condition) ()) - ;;;; special SBCL extension conditions ;;; an error apparently caused by a bug in SBCL itself @@ -922,7 +798,8 @@ (:special-operator (format stream "Special Operator ~S" data)) (:macro (format stream "Macro ~S" data)) (:section (format stream "Section ~{~D~^.~}" data)) - (:glossary (format stream "Glossary Entry ~S" data))))) + (:glossary (format stream "Glossary entry for ~S" data)) + (:issue (format stream "writeup for Issue ~A" data))))) (:sbcl (format stream "The SBCL Manual") (format stream ", ") @@ -978,8 +855,9 @@ (reference-condition simple-warning) () (:default-initargs - :references (list '(:ansi-cl :function make-array) - '(:ansi-cl :function upgraded-array-element-type)))) + :references (list + '(:ansi-cl :function make-array) + '(:ansi-cl :function sb!xc:upgraded-array-element-type)))) (define-condition displaced-to-array-too-small-error (reference-condition simple-error) @@ -1009,6 +887,141 @@ (define-condition extension-failure (reference-condition simple-error) ()) +;;;; various other (not specified by ANSI) CONDITIONs +;;;; +;;;; These might logically belong in other files; they're here, after +;;;; setup of CONDITION machinery, only because that makes it easier to +;;;; get cold init to work. + +(define-condition values-type-error (type-error) + () + (:report + (lambda (condition stream) + (format stream + "~@" + (type-error-datum condition) + (type-error-expected-type condition))))) + +;;; KLUDGE: a condition for floating point errors when we can't or +;;; won't figure out what type they are. (In FreeBSD and OpenBSD we +;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably +;;; know how but the old code was broken by the conversion to POSIX +;;; signal handling and hasn't been fixed as of sbcl-0.6.7.) +;;; +;;; FIXME: Perhaps this should also be a base class for all +;;; floating point exceptions? +(define-condition floating-point-exception (arithmetic-error) + ((flags :initarg :traps + :initform nil + :reader floating-point-exception-traps)) + (:report (lambda (condition stream) + (format stream + "An arithmetic error ~S was signalled.~%" + (type-of condition)) + (let ((traps (floating-point-exception-traps condition))) + (if traps + (format stream + "Trapping conditions are: ~%~{ ~S~^~}~%" + traps) + (write-line + "No traps are enabled? How can this be?" + stream)))))) + +(define-condition index-too-large-error (type-error) + () + (:report + (lambda (condition stream) + (format stream + "The index ~S is too large." + (type-error-datum condition))))) + +(define-condition bounding-indices-bad-error (reference-condition type-error) + ((object :reader bounding-indices-bad-object :initarg :object)) + (:report + (lambda (condition stream) + (let* ((datum (type-error-datum condition)) + (start (car datum)) + (end (cdr datum)) + (object (bounding-indices-bad-object condition))) + (etypecase object + (sequence + (format stream + "The bounding indices ~S and ~S are bad ~ + for a sequence of length ~S." + start end (length object))) + (array + ;; from WITH-ARRAY-DATA + (format stream + "The START and END parameters ~S and ~S are ~ + bad for an array of total size ~S." + start end (array-total-size object))))))) + (:default-initargs + :references + (list '(:ansi-cl :glossary "bounding index designator") + '(:ansi-cl :issue "SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR")))) + +(define-condition nil-array-accessed-error (reference-condition type-error) + () + (:report (lambda (condition stream) + (declare (ignore condition)) + (format stream + "An attempt to access an array of element-type ~ + NIL was made. Congratulations!"))) + (:default-initargs + :references (list '(:ansi-cl :function sb!xc:upgraded-array-element-type) + '(:ansi-cl :section (15 1 2 1)) + '(:ansi-cl :section (15 1 2 2))))) + +(define-condition io-timeout (stream-error) + ((direction :reader io-timeout-direction :initarg :direction)) + (:report + (lambda (condition stream) + (declare (type stream stream)) + (format stream + "I/O timeout ~(~A~)ing ~S" + (io-timeout-direction condition) + (stream-error-stream condition))))) + +(define-condition namestring-parse-error (parse-error) + ((complaint :reader namestring-parse-error-complaint :initarg :complaint) + (args :reader namestring-parse-error-args :initarg :args :initform nil) + (namestring :reader namestring-parse-error-namestring :initarg :namestring) + (offset :reader namestring-parse-error-offset :initarg :offset)) + (:report + (lambda (condition stream) + (format stream + "parse error in namestring: ~?~% ~A~% ~V@T^" + (namestring-parse-error-complaint condition) + (namestring-parse-error-args condition) + (namestring-parse-error-namestring condition) + (namestring-parse-error-offset condition))))) + +(define-condition simple-package-error (simple-condition package-error) ()) + +(define-condition reader-package-error (reader-error) ()) + +(define-condition reader-eof-error (end-of-file) + ((context :reader reader-eof-error-context :initarg :context)) + (:report + (lambda (condition stream) + (format stream + "unexpected end of file on ~S ~A" + (stream-error-stream condition) + (reader-eof-error-context condition))))) + +(define-condition reader-impossible-number-error (reader-error) + ((error :reader reader-impossible-number-error-error :initarg :error)) + (:report + (lambda (condition stream) + (let ((error-stream (stream-error-stream condition))) + (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A" + (file-position error-stream) error-stream + (reader-error-format-control condition) + (reader-error-format-arguments condition) + (reader-impossible-number-error-error condition)))))) + +(define-condition timeout (serious-condition) ()) + ;;;; restart definitions (define-condition abort-failure (control-error) () diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index e3d3488..e88a9de 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -263,18 +263,18 @@ bootstrapping. :definition-source `((defgeneric ,fun-name) ,*load-pathname*) initargs)) -;;; As per section 3.4.2 of the ANSI spec, generic function lambda -;;; lists have some special limitations, which we check here. +(define-condition generic-function-lambda-list-error + (reference-condition simple-program-error) + () + (:default-initargs :references (list '(:ansi-cl :section (3 4 2))))) + (defun check-gf-lambda-list (lambda-list) (flet ((ensure (arg ok) (unless ok - (error - ;; (s/invalid/non-ANSI-conforming/ because the old PCL - ;; implementation allowed this, so people got used to - ;; it, and maybe this phrasing will help them to guess - ;; why their program which worked under PCL no longer works.) - "~@" - arg lambda-list)))) + (error 'generic-function-lambda-list-error + :format-control + "~@" + :format-arguments (list arg lambda-list))))) (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count) (parse-lambda-list lambda-list) @@ -2334,6 +2334,11 @@ bootstrapping. (declare (ignore ignore1 ignore2 ignore3)) required-parameters)) +(define-condition specialized-lambda-list-error + (reference-condition simple-program-error) + () + (:default-initargs :references (list '(:ansi-cl :section (3 4 3))))) + (defun parse-specialized-lambda-list (arglist &optional supplied-keywords (allowed-keywords '(&optional &rest &key &aux)) @@ -2344,22 +2349,21 @@ bootstrapping. ((eq arg '&aux) (values nil arglist nil nil)) ((memq arg lambda-list-keywords) - ;; Now, since we try to conform to ANSI, non-standard - ;; lambda-list-keywords should be treated as errors. + ;; non-standard lambda-list-keywords are errors. (unless (memq arg specialized-lambda-list-keywords) - (error 'simple-program-error + (error 'specialized-lambda-list-error :format-control "unknown specialized-lambda-list ~ keyword ~S~%" :format-arguments (list arg))) ;; no multiple &rest x &rest bla specifying (when (memq arg supplied-keywords) - (error 'simple-program-error + (error 'specialized-lambda-list-error :format-control "multiple occurrence of ~ specialized-lambda-list keyword ~S~%" :format-arguments (list arg))) ;; And no placing &key in front of &optional, either. (unless (memq arg allowed-keywords) - (error 'simple-program-error + (error 'specialized-lambda-list-error :format-control "misplaced specialized-lambda-list ~ keyword ~S~%" :format-arguments (list arg))) @@ -2382,7 +2386,7 @@ bootstrapping. (not (or (null (cadr lambda-list)) (memq (cadr lambda-list) specialized-lambda-list-keywords))))) - (error 'simple-program-error + (error 'specialized-lambda-list-error :format-control "in a specialized-lambda-list, excactly one ~ variable must follow &REST.~%" diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 13781e5..8b71ed4 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -298,6 +298,12 @@ ;; parse-method-group-specifiers parse the method-group-specifiers +(define-condition long-method-combination-error + (reference-condition simple-error) + () + (:default-initargs + :references (list '(:ansi-cl :macro define-method-combination)))) + (defun wrap-method-group-specifier-bindings (method-group-specifiers declarations real-body) (let (names @@ -316,16 +322,19 @@ (if (and (equal ,specializer-cache .specializers.) (not (null .specializers.))) (return-from .long-method-combination-function. - '(error "More than one method of type ~S ~ - with the same specializers." - ',name)) + '(error 'long-method-combination-error + :format-control "More than one method of type ~S ~ + with the same specializers." + :format-arguments (list ',name))) (setq ,specializer-cache .specializers.)) (push .method. ,name)) cond-clauses) (when required (push `(when (null ,name) (return-from .long-method-combination-function. - '(error "No ~S methods." ',name))) + '(error 'long-method-combination-error + :format-control "No ~S methods." + :format-arguments (list ',name)))) required-checks)) (loop (unless (and (constantp order) (neq order (setq order (eval order)))) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index d78d02c..c0bff27 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -665,7 +665,7 @@ :initarg :documentation) ;; We need to make a distinction between the methods initially set ;; up by :METHOD options to DEFGENERIC and the ones set up later by - ;; DEFMETHOD, because ANSI's specifies that executing DEFGENERIC on + ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on ;; an already-DEFGENERICed function clears the methods set by the ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making ;; this distinction seems a little kludgy, but it has the positive diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 8cd94fa..c15b6c8 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -288,6 +288,11 @@ (add-method generic-function new) new)) +(define-condition find-method-length-mismatch + (reference-condition simple-error) + () + (:default-initargs :references '(:ansi-cl :function find-method))) + (defun real-get-method (generic-function qualifiers specializers &optional (errorp t) always-check-specializers) @@ -299,9 +304,12 @@ ;; instead we need to to this here or users may get hit by a ;; failed AVER instead of a sensible error message. (when (/= lspec nreq) - (error "~@" - generic-function nreq specializers)))) + (error + 'find-method-length-mismatch + :format-control + "~@" + :format-arguments (list generic-function nreq specializers))))) (let ((hit (dolist (method methods) (let ((mspecializers (method-specializers method))) diff --git a/version.lisp-expr b/version.lisp-expr index a554b97..8c7b134 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.12.3" +"0.8.12.4" -- 1.7.10.4