X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=07393fad2e22bd9b15d666af148b8b41b7a6996a;hb=f9ef8b045b60ae064c7bd40af599b46707ea4d8a;hp=43d93663a7808780c496e6fff670f92c8bf7b9d5;hpb=1bfc464c657a8f4ad24ef612f76a38d8f6f1bbad;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 43d9366..07393fa 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. @@ -23,8 +21,8 @@ (/show0 "condition.lisp 24") -(def!struct (condition-class (:include slot-class) - (:constructor bare-make-condition-class)) +(def!struct (condition-classoid (:include slot-classoid) + (:constructor make-condition-classoid)) ;; list of CONDITION-SLOT structures for the direct slots of this ;; class (slots nil :type list) @@ -46,20 +44,14 @@ (/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-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 + :metaclass-name condition-classoid + :metaclass-constructor make-condition-classoid :dd-type structure) (defun make-condition-object (actual-initargs) @@ -90,27 +82,31 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (/show0 "condition.lisp 103") (let ((condition-class (locally - ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM 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)) - (sb!xc:find-class 'condition)))) - (setf (condition-class-cpl condition-class) + ;; KLUDGE: There's a DEFTRANSFORM + ;; FIND-CLASSOID 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 find-classoid)) + (find-classoid 'condition)))) + (setf (condition-classoid-cpl condition-class) (list condition-class))) (/show0 "condition.lisp 103")) -(setf (condition-class-report (locally - ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM - ;; 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)))) +(setf (condition-classoid-report (locally + ;; KLUDGE: There's a DEFTRANSFORM + ;; FIND-CLASSOID 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 find-classoid)) + (find-classoid 'condition))) + (lambda (cond stream) + (format stream "Condition ~S was signalled." (type-of cond)))) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -118,9 +114,9 @@ (let* ((cpl (remove-duplicates (reverse (reduce #'append - (mapcar #'(lambda (x) - (condition-class-cpl - (sb!xc:find-class x))) + (mapcar (lambda (x) + (condition-classoid-cpl + (find-classoid x))) parent-types))))) (cond-layout (info :type :compiler-layout 'condition)) (olayout (info :type :compiler-layout name)) @@ -132,11 +128,11 @@ (new-inherits (order-layout-inherits (concatenate 'simple-vector (layout-inherits cond-layout) - (mapcar #'class-layout cpl))))) + (mapcar #'classoid-layout cpl))))) (if (and olayout (not (mismatch (layout-inherits olayout) new-inherits))) olayout - (make-layout :class (make-undefined-class name) + (make-layout :classoid (make-undefined-classoid name) :inherits new-inherits :depthoid -1 :length (layout-length cond-layout))))) @@ -157,9 +153,9 @@ ;; KLUDGE: A comment from CMU CL here said ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of ;; superclasses in define-condition call! - (dolist (class (condition-class-cpl (sb!xc:class-of x)) + (dolist (class (condition-classoid-cpl (classoid-of x)) (error "no REPORT? shouldn't happen!")) - (let ((report (condition-class-report class))) + (let ((report (condition-classoid-report class))) (when report (return (funcall report x stream))))))) @@ -169,9 +165,9 @@ (defun find-slot-default (class slot) (let ((initargs (condition-slot-initargs slot)) - (cpl (condition-class-cpl class))) + (cpl (condition-classoid-cpl class))) (dolist (class cpl) - (let ((default-initargs (condition-class-default-initargs class))) + (let ((default-initargs (condition-classoid-default-initargs class))) (dolist (initarg initargs) (let ((val (getf default-initargs initarg *empty-condition-slot*))) (unless (eq val *empty-condition-slot*) @@ -189,24 +185,24 @@ (defun find-condition-class-slot (condition-class slot-name) (dolist (sclass - (condition-class-cpl condition-class) + (condition-classoid-cpl condition-class) (error "There is no slot named ~S in ~S." slot-name condition-class)) - (dolist (slot (condition-class-slots sclass)) + (dolist (slot (condition-classoid-slots sclass)) (when (eq (condition-slot-name slot) slot-name) (return-from find-condition-class-slot slot))))) (defun condition-writer-function (condition new-value name) - (dolist (cslot (condition-class-class-slots - (layout-class (%instance-layout condition))) + (dolist (cslot (condition-classoid-class-slots + (layout-classoid (%instance-layout condition))) (setf (getf (condition-assigned-slots condition) name) new-value)) (when (eq (condition-slot-name cslot) name) (return (setf (car (condition-slot-cell cslot)) new-value))))) (defun condition-reader-function (condition name) - (let ((class (layout-class (%instance-layout condition)))) - (dolist (cslot (condition-class-class-slots class)) + (let ((class (layout-classoid (%instance-layout condition)))) + (dolist (cslot (condition-classoid-class-slots class)) (when (eq (condition-slot-name cslot) name) (return-from condition-reader-function (car (condition-slot-cell cslot))))) @@ -239,11 +235,11 @@ ;; Note: ANSI specifies no exceptional situations in this function. ;; signalling simple-type-error would not be wrong. (let* ((thing (if (symbolp thing) - (sb!xc:find-class thing) + (find-classoid thing) thing)) (class (typecase thing - (condition-class thing) - (class + (condition-classoid thing) + (classoid (error 'simple-type-error :datum thing :expected-type 'condition-class @@ -256,15 +252,15 @@ :format-control "bad thing for class argument:~% ~S" :format-arguments (list thing))))) (res (make-condition-object args))) - (setf (%instance-layout res) (class-layout class)) + (setf (%instance-layout res) (classoid-layout class)) ;; Set any class slots with initargs present in this call. - (dolist (cslot (condition-class-class-slots class)) + (dolist (cslot (condition-classoid-class-slots class)) (dolist (initarg (condition-slot-initargs cslot)) (let ((val (getf args initarg *empty-condition-slot*))) (unless (eq val *empty-condition-slot*) (setf (car (condition-slot-cell cslot)) val))))) ;; Default any slots with non-constant defaults now. - (dolist (hslot (condition-class-hairy-slots class)) + (dolist (hslot (condition-classoid-hairy-slots class)) (when (dolist (initarg (condition-slot-initargs hslot) t) (unless (eq (getf args initarg *empty-condition-slot*) *empty-condition-slot*) @@ -279,16 +275,18 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defun %compiler-define-condition (name direct-supers layout) (multiple-value-bind (class old-layout) - (insured-find-class name #'condition-class-p #'make-condition-class) - (setf (layout-class layout) class) - (setf (class-direct-superclasses class) - (mapcar #'sb!xc:find-class direct-supers)) + (insured-find-classoid name + #'condition-classoid-p + #'make-condition-classoid) + (setf (layout-classoid layout) class) + (setf (classoid-direct-superclasses class) + (mapcar #'find-classoid direct-supers)) (cond ((not old-layout) (register-layout layout)) ((not *type-system-initialized*) - (setf (layout-class old-layout) class) + (setf (layout-classoid old-layout) class) (setq layout old-layout) - (unless (eq (class-layout class) layout) + (unless (eq (classoid-layout class) layout) (register-layout layout))) ((redefine-layout-warning "current" old-layout @@ -297,7 +295,7 @@ (layout-inherits layout) (layout-depthoid layout)) (register-layout layout :invalidate t)) - ((not (class-layout class)) + ((not (classoid-layout class)) (register-layout layout))) (setf (layout-info layout) @@ -306,14 +304,14 @@ ;; 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)) - (layout-info (class-layout (sb!xc:find-class 'condition))))) + (declare (notinline find-classoid)) + (layout-info (classoid-layout (find-classoid 'condition))))) - (setf (sb!xc:find-class name) class) + (setf (find-classoid name) class) ;; Initialize CPL slot. - (setf (condition-class-cpl class) - (remove-if-not #'condition-class-p + (setf (condition-classoid-cpl class) + (remove-if-not #'condition-classoid-p (std-compute-class-precedence-list class)))) (values)) @@ -328,9 +326,9 @@ ;;; and documenting it here would be good. (Or, if this is not in fact ;;; ANSI-compliant, fixing it would also be good.:-) (defun compute-effective-slots (class) - (collect ((res (copy-list (condition-class-slots class)))) - (dolist (sclass (condition-class-cpl class)) - (dolist (sslot (condition-class-slots sclass)) + (collect ((res (copy-list (condition-classoid-slots class)))) + (dolist (sclass (condition-classoid-cpl class)) + (dolist (sslot (condition-classoid-slots sclass)) (let ((found (find (condition-slot-name sslot) (res)))) (cond (found (setf (condition-slot-initargs found) @@ -349,10 +347,10 @@ (res))) (defun %define-condition (name slots documentation report default-initargs) - (let ((class (sb!xc:find-class name))) - (setf (condition-class-slots class) slots) - (setf (condition-class-report class) report) - (setf (condition-class-default-initargs class) default-initargs) + (let ((class (find-classoid name))) + (setf (condition-classoid-slots class) slots) + (setf (condition-classoid-report class) report) + (setf (condition-classoid-default-initargs class) default-initargs) (setf (fdocumentation name 'type) documentation) (dolist (slot slots) @@ -361,20 +359,20 @@ (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.) (let ((eslots (compute-effective-slots class)) (e-def-initargs (reduce #'append - (mapcar #'condition-class-default-initargs - (condition-class-cpl class))))) + (mapcar #'condition-classoid-default-initargs + (condition-classoid-cpl class))))) (dolist (slot eslots) (ecase (condition-slot-allocation slot) (:class @@ -386,14 +384,14 @@ (funcall initform) initform)) *empty-condition-slot*)))) - (push slot (condition-class-class-slots class))) + (push slot (condition-classoid-class-slots class))) ((:instance nil) (setf (condition-slot-allocation slot) :instance) (when (or (functionp (condition-slot-initform slot)) (dolist (initarg (condition-slot-initargs slot) nil) (when (functionp (getf e-def-initargs initarg)) (return t)))) - (push slot (condition-class-hairy-slots class)))))))) + (push slot (condition-classoid-hairy-slots class)))))))) name) (defmacro define-condition (name (&rest parent-types) (&rest slot-specs) @@ -482,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)) @@ -499,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)) @@ -588,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))) @@ -618,6 +604,13 @@ "The function ~S is undefined." (cell-error-name condition))))) +(define-condition special-form-function (undefined-function) () + (:report + (lambda (condition stream) + (format stream + "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S." + (cell-error-name condition))))) + (define-condition arithmetic-error (error) ((operation :reader arithmetic-error-operation :initarg :operation @@ -703,6 +696,32 @@ "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) + (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 @@ -715,8 +734,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 @@ -724,7 +742,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))))) @@ -740,6 +758,85 @@ "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)))))) + +;;; should this inherit from error? good question +(define-condition timeout (error) ()) + + + +;;;; 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