X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=1e5c7c7bb3bb57934e74dd59bff0619401ae879c;hb=c33612272b00979a34861d962f5e7bd47f36ae6e;hp=86732a541018667c689d0bd155fd5f4a7d0fb13c;hpb=959057baab99d4328fc386aee3fcc812f5fcb3ed;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 86732a5..1e5c7c7 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -1,8 +1,6 @@ ;;;; stuff originally from CMU CL's error.lisp which can or should ;;;; come late (mostly related to the CONDITION class itself) ;;;; -;;;; FIXME: should perhaps be called condition.lisp, or moved into -;;;; classes.lisp ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -17,10 +15,12 @@ ;;;; the CONDITION class -(/show0 "late-target-error.lisp 20") +(/show0 "condition.lisp 20") (eval-when (:compile-toplevel :load-toplevel :execute) +(/show0 "condition.lisp 24") + (def!struct (condition-class (:include slot-class) (:constructor bare-make-condition-class)) ;; list of CONDITION-SLOT structures for the direct slots of this @@ -33,8 +33,8 @@ (report nil :type (or function null)) ;; list of alternating initargs and initforms (default-initargs () :type list) - ;; class precedence list as a list of class objects, with all - ;; non-condition classes removed + ;; class precedence list as a list of CLASS objects, with all + ;; non-CONDITION classes removed (cpl () :type list) ;; a list of all the effective instance allocation slots of this ;; class that have a non-constant initform or default-initarg. @@ -42,36 +42,39 @@ ;; environment of MAKE-CONDITION. (hairy-slots nil :type list)) +(/show0 "condition.lisp 49") + (defun make-condition-class (&rest rest) (apply #'bare-make-condition-class (rename-key-args '((:name :%name)) rest))) +(/show0 "condition.lisp 53") + ) ; EVAL-WHEN -(defstruct (condition - (:constructor make-condition-object (actual-initargs)) - (:alternate-metaclass instance - condition-class - make-condition-class) - (:copier nil)) - ;; actual initargs supplied to MAKE-CONDITION - (actual-initargs (required-argument) :type list) - ;; a plist mapping slot names to any values that were assigned or - ;; defaulted after creation - (assigned-slots () :type list)) +(!defstruct-with-alternate-metaclass condition + :slot-names (actual-initargs assigned-slots) + :boa-constructor %make-condition-object + :superclass-name instance + :metaclass-name condition-class + :metaclass-constructor make-condition-class + :dd-type structure) + +(defun make-condition-object (actual-initargs) + (%make-condition-object actual-initargs nil)) (defstruct (condition-slot (:copier nil)) - (name (required-argument) :type symbol) + (name (missing-arg) :type symbol) ;; list of all applicable initargs - (initargs (required-argument) :type list) + (initargs (missing-arg) :type list) ;; names of reader and writer functions - (readers (required-argument) :type list) - (writers (required-argument) :type list) + (readers (missing-arg) :type list) + (writers (missing-arg) :type list) ;; true if :INITFORM was specified - (initform-p (required-argument) :type (member t nil)) + (initform-p (missing-arg) :type (member t nil)) ;; If this is a function, call it with no args. Otherwise, it's the ;; actual value. - (initform (required-argument) :type t) + (initform (missing-arg) :type t) ;; allocation of this slot, or NIL until defaulted (allocation nil :type (member :instance :class nil)) ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value. @@ -83,8 +86,9 @@ ;;; from CMU CL, and didn't seem to be explained there, and I haven't ;;; figured out whether it's right. -- WHN 19990612 (eval-when (:compile-toplevel :load-toplevel :execute) + (/show0 "condition.lisp 103") (let ((condition-class (locally - ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for + ;; KLUDGE: There's a DEFTRANSFORM FIND-CLASS for ;; constant class names which creates fast but ;; non-cold-loadable, non-compact code. In this ;; context, we'd rather have compact, cold-loadable @@ -92,18 +96,19 @@ (declare (notinline sb!xc:find-class)) (sb!xc:find-class 'condition)))) (setf (condition-class-cpl condition-class) - (list condition-class)))) + (list condition-class))) + (/show0 "condition.lisp 103")) (setf (condition-class-report (locally - ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM + ;; KLUDGE: There's a DEFTRANSFORM FIND-CLASS ;; for constant class names which creates fast ;; but non-cold-loadable, non-compact code. In ;; this context, we'd rather have compact, ;; cold-loadable code. -- WHN 19990928 (declare (notinline sb!xc:find-class)) (find-class 'condition))) - #'(lambda (cond stream) - (format stream "Condition ~S was signalled." (type-of cond)))) + (lambda (cond stream) + (format stream "Condition ~S was signalled." (type-of cond)))) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -111,9 +116,9 @@ (let* ((cpl (remove-duplicates (reverse (reduce #'append - (mapcar #'(lambda (x) - (condition-class-cpl - (sb!xc:find-class x))) + (mapcar (lambda (x) + (condition-class-cpl + (sb!xc:find-class x))) parent-types))))) (cond-layout (info :type :compiler-layout 'condition)) (olayout (info :type :compiler-layout name)) @@ -354,12 +359,12 @@ (let ((name (condition-slot-name slot))) (dolist (reader (condition-slot-readers slot)) (setf (fdefinition reader) - #'(lambda (condition) - (condition-reader-function condition name)))) + (lambda (condition) + (condition-reader-function condition name)))) (dolist (writer (condition-slot-writers slot)) (setf (fdefinition writer) - #'(lambda (new-value condition) - (condition-writer-function condition new-value name)))))) + (lambda (new-value condition) + (condition-writer-function condition new-value name)))))) ;; Compute effective slots and set up the class and hairy slots ;; (subsets of the effective slots.) @@ -475,10 +480,10 @@ (setq report (if (stringp arg) `#'(lambda (condition stream) - (declare (ignore condition)) - (write-string ,arg stream)) + (declare (ignore condition)) + (write-string ,arg stream)) `#'(lambda (condition stream) - (funcall #',arg condition stream)))))) + (funcall #',arg condition stream)))))) (:default-initargs (do ((initargs (rest option) (cddr initargs))) ((endp initargs)) @@ -492,10 +497,6 @@ (t (error "unknown option: ~S" (first option))))) - (when (all-writers) - (warn "Condition slot setters probably not allowed in ANSI CL:~% ~S" - (all-writers))) - `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (%compiler-define-condition ',name ',parent-types ',layout)) @@ -581,15 +582,7 @@ ((pathname :reader file-error-pathname :initarg :pathname)) (:report (lambda (condition stream) - (format stream - "~@" - (file-error-pathname condition) - ;; FIXME: ANSI's FILE-ERROR doesn't have FORMAT-CONTROL and - ;; FORMAT-ARGUMENTS, and the inheritance here doesn't seem - ;; to give us FORMAT-CONTROL or FORMAT-ARGUMENTS either. - ;; So how does this work? - (serious-condition-format-control condition) - (serious-condition-format-arguments condition))))) + (format stream "error on file ~S" (file-error-pathname condition))))) (define-condition package-error (error) ((package :reader package-error-package :initarg :package))) @@ -652,7 +645,7 @@ (:report (lambda (condition stream) (let ((error-stream (stream-error-stream condition))) - (format stream "READER-ERROR ~@[at ~D ~]on ~S:~%~?" + (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?" (file-position error-stream) error-stream (reader-error-format-control condition) (reader-error-format-arguments condition)))))) @@ -696,6 +689,16 @@ "The index ~S is too large." (type-error-datum condition))))) +;;; Out-of-range &KEY END arguments are similar to, but off by one +;;; from out-of-range indices into the sequence. +(define-condition index-too-large-error (type-error) + () + (:report + (lambda (condition stream) + (format stream + "The end-of-sequence specifier ~S is too large." + (type-error-datum condition))))) + (define-condition io-timeout (stream-error) ((direction :reader io-timeout-direction :initarg :direction)) (:report @@ -708,8 +711,7 @@ (define-condition namestring-parse-error (parse-error) ((complaint :reader namestring-parse-error-complaint :initarg :complaint) - (arguments :reader namestring-parse-error-arguments :initarg :arguments - :initform nil) + (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 @@ -717,7 +719,7 @@ (format stream "parse error in namestring: ~?~% ~A~% ~V@T^" (namestring-parse-error-complaint condition) - (namestring-parse-error-arguments condition) + (namestring-parse-error-args condition) (namestring-parse-error-namestring condition) (namestring-parse-error-offset condition))))) @@ -733,6 +735,80 @@ "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)))))) + +;;;; special SBCL extension conditions + +;;; an error apparently caused by a bug in SBCL itself +;;; +;;; Note that we don't make any serious effort to use this condition +;;; for *all* errors in SBCL itself. E.g. type errors and array +;;; indexing errors can occur in functions called from SBCL code, and +;;; will just end up as ordinary TYPE-ERROR or invalid index error, +;;; because the signalling code has no good way to know that the +;;; underlying problem is a bug in SBCL. But in the fairly common case +;;; that the signalling code does know that it's found a bug in SBCL, +;;; this condition is appropriate, reusing boilerplate and helping +;;; users to recognize it as an SBCL bug. +(define-condition bug (simple-error) + () + (:report + (lambda (condition stream) + (format stream + "~@< ~? ~:@_~?~:>" + (simple-condition-format-control condition) + (simple-condition-format-arguments condition) + "~@.~:@>" + '((fmakunbound 'compile)))))) +(defun bug (format-control &rest format-arguments) + (error 'bug + :format-control format-control + :format-arguments format-arguments)) + +;;; a condition for use in stubs for operations which aren't supported +;;; on some platforms +;;; +;;; E.g. in sbcl-0.7.0.5, it might be appropriate to do something like +;;; #-(or freebsd linux) +;;; (defun load-foreign (&rest rest) +;;; (error 'unsupported-operator :name 'load-foreign)) +;;; #+(or freebsd linux) +;;; (defun load-foreign ... actual definition ...) +;;; By signalling a standard condition in this case, we make it +;;; possible for test code to distinguish between (1) intentionally +;;; unimplemented and (2) unintentionally just screwed up somehow. +;;; (Before this condition was defined, test code tried to deal with +;;; this by checking for FBOUNDP, but that didn't work reliably. In +;;; sbcl-0.7.0, a a package screwup left the definition of +;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on +;;; architectures where it was supposed to be supported, and the +;;; regression tests cheerfully passed because they assumed that +;;; unFBOUNDPness meant they were running on an system which didn't +;;; support the extension.) +(define-condition unsupported-operator (cell-error) () + (:report + (lambda (condition stream) + (format stream + "unsupported on this platform (OS, CPU, whatever): ~S" + (cell-error-name condition))))) ;;;; restart definitions @@ -773,5 +849,5 @@ "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if none exists.")) -(/show0 "late-target-error.lisp end of file") +(/show0 "condition.lisp end of file")