X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcondition.lisp;h=29c854a2b3f380e728a003895527157a5db0bf50;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=bf840db744988edc78e82b3dd72fa0bc14e709e7;hpb=f9d6d21a7f54638292214ceb9886edc03b99d545;p=sbcl.git diff --git a/src/code/condition.lisp b/src/code/condition.lisp index bf840db..29c854a 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. @@ -15,6 +13,26 @@ (in-package "SB!KERNEL") +;;;; miscellaneous support utilities + +;;; Signalling an error when trying to print an error condition is +;;; generally a PITA, so whatever the failure encountered when +;;; wondering about FILE-POSITION within a condition printer, 'tis +;;; better silently to give up than to try to complain. +(defun file-position-or-nil-for-error (stream &optional (pos nil posp)) + ;; Arguably FILE-POSITION shouldn't be signalling errors at all; but + ;; "NIL if this cannot be determined" in the ANSI spec doesn't seem + ;; absolutely unambiguously to prohibit errors when, e.g., STREAM + ;; has been closed so that FILE-POSITION is a nonsense question. So + ;; my (WHN) impression is that the conservative approach is to + ;; IGNORE-ERRORS. (I encountered this failure from within a homebrew + ;; defsystemish operation where the ERROR-STREAM had been CL:CLOSEd, + ;; I think by nonlocally exiting through a WITH-OPEN-FILE, by the + ;; time an error was reported.) + (if posp + (ignore-errors (file-position stream pos)) + (ignore-errors (file-position stream)))) + ;;;; the CONDITION class (/show0 "condition.lisp 20") @@ -23,8 +41,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 +64,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) @@ -80,7 +92,9 @@ ;; 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. - (cell nil :type (or cons null))) + (cell nil :type (or cons null)) + ;; slot documentation + (documentation nil :type (or string null))) ;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed ;;; in its CPL, while other classes derived from CONDITION-CLASS don't @@ -90,26 +104,30 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (/show0 "condition.lisp 103") (let ((condition-class (locally - ;; 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)) - (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 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) +(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 +136,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 +150,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 +175,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 +187,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,28 +207,27 @@ (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))))) - (let ((val (getf (condition-assigned-slots condition) name *empty-condition-slot*))) (if (eq val *empty-condition-slot*) @@ -218,17 +235,15 @@ (slot (find-condition-class-slot class name))) (unless slot (error "missing slot ~S of ~S" name condition)) - (dolist (initarg (condition-slot-initargs slot)) - (let ((val (getf actual-initargs - initarg - *empty-condition-slot*))) - (unless (eq val *empty-condition-slot*) - (return-from condition-reader-function - (setf (getf (condition-assigned-slots condition) - name) - val))))) - (setf (getf (condition-assigned-slots condition) name) - (find-slot-default class slot))) + (do ((initargs actual-initargs (cddr initargs))) + ((endp initargs) + (setf (getf (condition-assigned-slots condition) name) + (find-slot-default class slot))) + (when (member (car initargs) (condition-slot-initargs slot)) + (return-from condition-reader-function + (setf (getf (condition-assigned-slots condition) + name) + (cadr initargs)))))) val)))) ;;;; MAKE-CONDITION @@ -238,12 +253,11 @@ "Make an instance of a condition object using the specified initargs." ;; 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) + (let* ((thing (or (and (symbolp thing) (find-classoid thing nil)) thing)) (class (typecase thing - (condition-class thing) - (class + (condition-classoid thing) + (classoid (error 'simple-type-error :datum thing :expected-type 'condition-class @@ -256,67 +270,73 @@ :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*) (return nil))) (setf (getf (condition-assigned-slots res) (condition-slot-name hslot)) (find-slot-default class hslot)))) - res)) ;;;; DEFINE-CONDITION (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)) - (cond ((not old-layout) - (register-layout layout)) - ((not *type-system-initialized*) - (setf (layout-class old-layout) class) - (setq layout old-layout) - (unless (eq (class-layout class) layout) +(defun %compiler-define-condition (name direct-supers layout + all-readers all-writers) + (with-single-package-locked-error + (:symbol name "defining ~A as a condition") + (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers)) + (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers)) + (multiple-value-bind (class old-layout) + (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-classoid old-layout) class) + (setq layout old-layout) + (unless (eq (classoid-layout class) layout) + (register-layout layout))) + ((redefine-layout-warning "current" + old-layout + "new" + (layout-length layout) + (layout-inherits layout) + (layout-depthoid layout) + (layout-n-untagged-slots layout)) + (register-layout layout :invalidate t)) + ((not (classoid-layout class)) (register-layout layout))) - ((redefine-layout-warning "current" - old-layout - "new" - (layout-length layout) - (layout-inherits layout) - (layout-depthoid layout)) - (register-layout layout :invalidate t)) - ((not (class-layout class)) - (register-layout layout))) - - (setf (layout-info layout) - (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)) - (layout-info (class-layout (sb!xc:find-class 'condition))))) - - (setf (sb!xc:find-class name) class) - - ;; Initialize CPL slot. - (setf (condition-class-cpl class) - (remove-if-not #'condition-class-p - (std-compute-class-precedence-list class)))) + + (setf (layout-info layout) + (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 find-classoid)) + (layout-info (classoid-layout (find-classoid 'condition))))) + + (setf (find-classoid name) class) + + ;; Initialize CPL slot. + (setf (condition-classoid-cpl class) + (remove-if-not #'condition-classoid-p + (std-compute-class-precedence-list class))))) (values)) - ) ; EVAL-WHEN ;;; Compute the effective slots of CLASS, copying inherited slots and @@ -328,10 +348,11 @@ ;;; 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)) - (let ((found (find (condition-slot-name sslot) (res)))) + (collect ((res (copy-list (condition-classoid-slots class)))) + (dolist (sclass (cdr (condition-classoid-cpl class))) + (dolist (sslot (condition-classoid-slots sclass)) + (let ((found (find (condition-slot-name sslot) (res) + :key #'condition-slot-name))) (cond (found (setf (condition-slot-initargs found) (union (condition-slot-initargs found) @@ -348,53 +369,72 @@ (res (copy-structure sslot))))))) (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) - (setf (fdocumentation name 'type) documentation) - - (dolist (slot slots) - - ;; Set up reader and writer functions. - (let ((name (condition-slot-name slot))) - (dolist (reader (condition-slot-readers slot)) - (setf (fdefinition reader) - #'(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)))))) - - ;; 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))))) - (dolist (slot eslots) - (ecase (condition-slot-allocation slot) - (:class - (unless (condition-slot-cell slot) - (setf (condition-slot-cell slot) - (list (if (condition-slot-initform-p slot) - (let ((initform (condition-slot-initform slot))) - (if (functionp initform) - (funcall initform) - initform)) - *empty-condition-slot*)))) - (push slot (condition-class-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)))))))) - name) +;;; Early definitions of slot accessor creators. +;;; +;;; Slot accessors must be generic functions, but ANSI does not seem +;;; to specify any of them, and we cannot support it before end of +;;; warm init. So we use ordinary functions inside SBCL, and switch to +;;; GFs only at the end of building. +(declaim (notinline install-condition-slot-reader + install-condition-slot-writer)) +(defun install-condition-slot-reader (name condition slot-name) + (declare (ignore condition)) + (setf (fdefinition name) + (lambda (condition) + (condition-reader-function condition slot-name)))) +(defun install-condition-slot-writer (name condition slot-name) + (declare (ignore condition)) + (setf (fdefinition name) + (lambda (new-value condition) + (condition-writer-function condition new-value slot-name)))) + +(defun %define-condition (name parent-types layout slots documentation + report default-initargs all-readers all-writers) + (with-single-package-locked-error + (:symbol name "defining ~A as a condition") + (%compiler-define-condition name parent-types layout all-readers all-writers) + (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) + + ;; Set up reader and writer functions. + (let ((slot-name (condition-slot-name slot))) + (dolist (reader (condition-slot-readers slot)) + (install-condition-slot-reader reader name slot-name)) + (dolist (writer (condition-slot-writers slot)) + (install-condition-slot-writer writer name slot-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-classoid-default-initargs + (condition-classoid-cpl class))))) + (dolist (slot eslots) + (ecase (condition-slot-allocation slot) + (:class + (unless (condition-slot-cell slot) + (setf (condition-slot-cell slot) + (list (if (condition-slot-initform-p slot) + (let ((initform (condition-slot-initform slot))) + (if (functionp initform) + (funcall initform) + initform)) + *empty-condition-slot*)))) + (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-classoid-hairy-slots class)))))))) + name)) (defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options) @@ -432,6 +472,7 @@ (slot-name (first spec)) (allocation :instance) (initform-p nil) + documentation initform) (collect ((initargs) (readers) @@ -455,6 +496,13 @@ (:initarg (initargs arg)) (:allocation (setq allocation arg)) + (:documentation + (when documentation + (error "more than one :DOCUMENTATION in ~S" spec)) + (unless (stringp arg) + (error "slot :DOCUMENTATION argument is not a string: ~S" + arg)) + (setq documentation arg)) (:type) (t (error "unknown slot option:~% ~S" (first options)))))) @@ -467,6 +515,7 @@ :readers ',(readers) :writers ',(writers) :initform-p ',initform-p + :documentation ',documentation :initform ,(if (constantp initform) `',(eval initform) @@ -499,22 +548,20 @@ (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)) - - (declaim (ftype (function (t) t) ,@(all-readers))) - (declaim (ftype (function (t t) t) ,@(all-writers))) - - (%define-condition ',name - (list ,@(slots)) - ,documentation - ,report - (list ,@default-initargs)))))) + (eval-when (:compile-toplevel) + (%compiler-define-condition ',name ',parent-types ',layout + ',(all-readers) ',(all-writers))) + (eval-when (:load-toplevel :execute) + (%define-condition ',name + ',parent-types + ',layout + (list ,@(slots)) + ,documentation + ,report + (list ,@default-initargs) + ',(all-readers) + ',(all-writers))))))) ;;;; DESCRIBE on CONDITIONs @@ -523,7 +570,7 @@ ;;; methods) (defun describe-condition (condition stream) (format stream - "~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>" + "~&~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>~%" condition (type-of condition) (concatenate 'list @@ -547,16 +594,21 @@ (define-condition simple-condition () ((format-control :reader simple-condition-format-control - :initarg :format-control) + :initarg :format-control + :type format-control) (format-arguments :reader simple-condition-format-arguments :initarg :format-arguments - :initform '())) + :initform '() + :type list)) (:report simple-condition-printer)) (define-condition simple-warning (simple-condition warning) ()) (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) @@ -588,15 +640,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 +662,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 @@ -658,11 +709,277 @@ :initform '())) (:report (lambda (condition stream) - (let ((error-stream (stream-error-stream condition))) - (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?" - (file-position error-stream) error-stream - (reader-error-format-control condition) - (reader-error-format-arguments condition)))))) + (let* ((error-stream (stream-error-stream condition)) + (pos (file-position-or-nil-for-error error-stream))) + (let (lineno colno) + (when (and pos + (< pos sb!xc:array-dimension-limit) + ;; KLUDGE: lseek() (which is what FILE-POSITION + ;; reduces to on file-streams) is undefined on + ;; "some devices", which in practice means that it + ;; can claim to succeed on /dev/stdin on Darwin + ;; and Solaris. This is obviously bad news, + ;; because the READ-SEQUENCE below will then + ;; block, not complete, and the report will never + ;; be printed. As a workaround, we exclude + ;; interactive streams from this attempt to report + ;; positions. -- CSR, 2003-08-21 + (not (interactive-stream-p error-stream)) + (file-position error-stream :start)) + (let ((string + (make-string pos + :element-type (stream-element-type + error-stream)))) + (when (= pos (read-sequence string error-stream)) + (setq lineno (1+ (count #\Newline string)) + colno (- pos + (or (position #\Newline string :from-end t) -1) + 1)))) + (file-position-or-nil-for-error error-stream pos)) + (format stream + "READER-ERROR ~@[at ~W ~]~ + ~@[(line ~W~]~@[, column ~W) ~]~ + on ~S:~%~?" + pos lineno colno error-stream + (reader-error-format-control condition) + (reader-error-format-arguments 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)))))) + +(define-condition simple-storage-condition (storage-condition simple-condition) ()) + +;;; 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 (simple-error) ()) + + +;;; (:ansi-cl :function remove) +;;; (:ansi-cl :section (a b c)) +;;; (:ansi-cl :glossary "similar") +;;; +;;; (:sbcl :node "...") +;;; (:sbcl :variable *ed-functions*) +;;; +;;; FIXME: this is not the right place for this. +(defun print-reference (reference stream) + (ecase (car reference) + (:amop + (format stream "AMOP") + (format stream ", ") + (destructuring-bind (type data) (cdr reference) + (ecase type + (:generic-function (format stream "Generic Function ~S" data)) + (:section (format stream "Section ~{~D~^.~}" data))))) + (:ansi-cl + (format stream "The ANSI Standard") + (format stream ", ") + (destructuring-bind (type data) (cdr reference) + (ecase type + (:function (format stream "Function ~S" data)) + (: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 for ~S" data)) + (:issue (format stream "writeup for Issue ~A" data))))) + (:sbcl + (format stream "The SBCL Manual") + (format stream ", ") + (destructuring-bind (type data) (cdr reference) + (ecase type + (:node (format stream "Node ~S" data)) + (:variable (format stream "Variable ~S" data)) + (:function (format stream "Function ~S" data))))) + ;; FIXME: other documents (e.g. CLIM, Franz documentation :-) + )) +(define-condition reference-condition () + ((references :initarg :references :reader reference-condition-references))) +(defvar *print-condition-references* t) +(def!method print-object :around ((o reference-condition) s) + (call-next-method) + (unless (or *print-escape* *print-readably*) + (when (and *print-condition-references* + (reference-condition-references o)) + (format s "~&See also:~%") + (pprint-logical-block (s nil :per-line-prefix " ") + (do* ((rs (reference-condition-references o) (cdr rs)) + (r (car rs) (car rs))) + ((null rs)) + (print-reference r s) + (unless (null (cdr rs)) + (terpri s))))))) + +(define-condition duplicate-definition (reference-condition warning) + ((name :initarg :name :reader duplicate-definition-name)) + (:report (lambda (c s) + (format s "~@" + (duplicate-definition-name c)))) + (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3))))) + +(define-condition package-at-variance (reference-condition simple-warning) + () + (:default-initargs :references (list '(:ansi-cl :macro defpackage)))) + +(define-condition defconstant-uneql (reference-condition error) + ((name :initarg :name :reader defconstant-uneql-name) + (old-value :initarg :old-value :reader defconstant-uneql-old-value) + (new-value :initarg :new-value :reader defconstant-uneql-new-value)) + (:report + (lambda (condition stream) + (format stream + "~@" + (defconstant-uneql-name condition) + (defconstant-uneql-old-value condition) + (defconstant-uneql-new-value condition)))) + (:default-initargs :references (list '(:ansi-cl :macro defconstant) + '(:sbcl :node "Idiosyncrasies")))) + +(define-condition array-initial-element-mismatch + (reference-condition simple-warning) + () + (:default-initargs + :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) + () + (:default-initargs + :references (list '(:ansi-cl :function adjust-array)))) + +(define-condition type-warning (reference-condition simple-warning) + () + (:default-initargs :references (list '(:sbcl :node "Handling of Types")))) + +(define-condition local-argument-mismatch (reference-condition simple-warning) + () + (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3))))) + +(define-condition format-args-mismatch (reference-condition) + () + (:default-initargs :references (list '(:ansi-cl :section (22 3 10 2))))) + +(define-condition format-too-few-args-warning + (format-args-mismatch simple-warning) + ()) +(define-condition format-too-many-args-warning + (format-args-mismatch simple-style-warning) + ()) + +(define-condition extension-failure (reference-condition simple-error) + ()) + +(define-condition structure-initarg-not-keyword + (reference-condition simple-style-warning) + () + (:default-initargs :references (list '(:ansi-cl :section (2 4 8 13))))) + +#!+sb-package-locks +(progn + +(define-condition package-lock-violation (reference-condition package-error) + ((format-control :initform nil :initarg :format-control + :reader package-error-format-control) + (format-arguments :initform nil :initarg :format-arguments + :reader package-error-format-arguments)) + (:report + (lambda (condition stream) + (let ((control (package-error-format-control condition))) + (if control + (apply #'format stream + (format nil "~~@" + (package-name (package-error-package condition)) + control) + (package-error-format-arguments condition)) + (format stream "~@" + (package-name (package-error-package condition))))))) + ;; no :default-initargs -- reference-stuff provided by the + ;; signalling form in target-package.lisp + #!+sb-doc + (:documentation + "Subtype of CL:PACKAGE-ERROR. A subtype of this error is signalled +when a package-lock is violated.")) + +(define-condition package-locked-error (package-lock-violation) () + #!+sb-doc + (:documentation + "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is +signalled when an operation on a package violates a package lock.")) + +(define-condition symbol-package-locked-error (package-lock-violation) + ((symbol :initarg :symbol :reader package-locked-error-symbol)) + #!+sb-doc + (:documentation + "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is +signalled when an operation on a symbol violates a package lock. The +symbol that caused the violation is accessed by the function +SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) + +) ; progn + +(define-condition undefined-alien-error (error) ()) + +(define-condition undefined-alien-variable-error (undefined-alien-error) () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "Attempt to access an undefined alien variable.")))) + +(define-condition undefined-alien-function-error (undefined-alien-error) () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "Attempt to call an undefined alien function.")))) + ;;;; various other (not specified by ANSI) CONDITIONs ;;;; @@ -670,6 +987,19 @@ ;;;; setup of CONDITION machinery, only because that makes it easier to ;;;; get cold init to work. +;;; OAOOM warning: see cross-condition.lisp +(define-condition encapsulated-condition (condition) + ((condition :initarg :condition :reader encapsulated-condition))) + +(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 @@ -703,6 +1033,43 @@ "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 @@ -715,8 +1082,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 +1090,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 +1106,84 @@ "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-or-nil-for-error 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) ()) + +(define-condition declaration-type-conflict-error (reference-condition + simple-error) + () + (:default-initargs + :format-control "symbol ~S cannot be both the name of a type and the name of a declaration" + :references (list '(:ansi-cl :section (3 8 21))))) + +;;; Single stepping conditions + +(define-condition step-condition () + ((form :initarg :form :reader step-condition-form)) + #!+sb-doc + (:documentation "Common base class of single-stepping conditions. +STEP-CONDITION-FORM holds a string representation of the form being +stepped.")) + +#!+sb-doc +(setf (fdocumentation 'step-condition-form 'function) + "Form associated with the STEP-CONDITION.") + +(define-condition step-form-condition (step-condition) + ((source-path :initarg :source-path :reader step-condition-source-path) + (pathname :initarg :pathname :reader step-condition-pathname)) + #!+sb-doc + (:documentation "Condition signalled by code compiled with +single-stepping information when about to execute a form. +STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the +pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH +holds the source-path to the original form within that file or NIL. +Associated with this condition are always the restarts STEP-INTO, +STEP-NEXT, and STEP-CONTINUE.")) + +#!+sb-doc +(setf (fdocumentation 'step-condition-source-path 'function) + "Source-path of the original form associated with the +STEP-FORM-CONDITION or NIL." + (fdocumentation 'step-condition-pathname 'function) + "Pathname of the original source-file associated with the +STEP-FORM-CONDITION or NIL.") + +(define-condition step-result-condition (step-condition) + ((result :initarg :result :reader step-condition-result))) + +#!+sb-doc +(setf (fdocumentation 'step-condition-result 'function) + "Return values associated with STEP-VALUES-CONDITION as a list, +or the variable value associated with STEP-VARIABLE-CONDITION.") + +(define-condition step-values-condition (step-result-condition) + () + #!+sb-doc + (:documentation "Condition signalled by code compiled with +single-stepping information after executing a form. +STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds +the values returned by the form as a list. No associated restarts.")) + +(define-condition step-variable-condition (step-result-condition) + () + #!+sb-doc + (:documentation "Condition signalled by code compiled with +single-stepping information when referencing a variable. +STEP-CONDITION-FORM hold the symbol, and STEP-CONDITION-RESULT holds +the value of the variable. No associated restarts.")) + ;;;; restart definitions @@ -751,7 +1195,7 @@ #!+sb-doc "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if none exists." - (invoke-restart (find-restart 'abort condition)) + (invoke-restart (find-restart-or-control-error 'abort condition)) ;; ABORT signals an error in case there was a restart named ABORT ;; that did not transfer control dynamically. This could happen with ;; RESTART-BIND. @@ -761,7 +1205,7 @@ #!+sb-doc "Transfer control to a restart named MUFFLE-WARNING, signalling a CONTROL-ERROR if none exists." - (invoke-restart (find-restart 'muffle-warning condition))) + (invoke-restart (find-restart-or-control-error 'muffle-warning condition))) (macrolet ((define-nil-returning-restart (name args doc) #!-sb-doc (declare (ignore doc)) @@ -769,8 +1213,9 @@ #!+sb-doc ,doc ;; FIXME: Perhaps this shared logic should be pulled out into ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code.. - (when (find-restart ',name condition) - (invoke-restart ',name ,@args))))) + (let ((restart (find-restart ',name condition))) + (when restart + (invoke-restart restart ,@args)))))) (define-nil-returning-restart continue () "Transfer control to a restart named CONTINUE, or return NIL if none exists.") (define-nil-returning-restart store-value (value) @@ -780,5 +1225,26 @@ "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if none exists.")) +;;; single-stepping restarts + +(macrolet ((def (name doc) + #!-sb-doc (declare (ignore doc)) + `(defun ,name (condition) + #!+sb-doc ,doc + (invoke-restart (find-restart-or-control-error ',name condition))))) + (def step-continue + "Transfers control to the STEP-CONTINUE restart associated with +the condition, continuing execution without stepping. Signals a +CONTROL-ERROR if the restart does not exist.") + (def step-next + "Transfers control to the STEP-NEXT restart associated with the +condition, executing the current form without stepping and continuing +stepping with the next form. Signals CONTROL-ERROR is the restart does +not exists.") + (def step-into + "Transfers control to the STEP-INTO restart associated with the +condition, stepping into the current form. Signals a CONTROL-ERROR is +the restart does not exist.")) + (/show0 "condition.lisp end of file")