diff --git a/code/error.lisp b/code/error.lisp index d056ae76a8b2dd95d70202a8c829299df1160302..4db1ed1b5af42f681502680256242aa3aff3836f 100644 --- a/code/error.lisp +++ b/code/error.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.33 1993/08/25 01:13:02 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.34 1993/08/30 21:24:18 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,9 +18,10 @@ (in-package "CONDITIONS") (use-package "EXTENSIONS") +(use-package "KERNEL") (in-package "KERNEL") -(export '(layout-invalid simple-style-warning)) +(export '(layout-invalid simple-style-warning condition-function-name)) (in-package "LISP") (export '(break error warn cerror @@ -335,158 +336,438 @@ ;;;; Conditions. -(defun condition-print (condition stream depth) - (declare (ignore depth)) - (if *print-escape* - (print-unreadable-object (condition stream :identity t) - (prin1 (type-of condition) stream)) - (handler-case - (condition-report condition stream) - (error () (format stream "...~2%; Error reporting condition: ~S.~%" - condition))))) +(eval-when (compile load eval) -(eval-when (eval compile load) +(defstruct (condition-class (:include slot-class)) + ;; + ;; List of CONDITION-SLOT structures for the direct slots of this class. + (slots nil :type list) + ;; + ;; List of CONDITION-SLOT structures for all of the effective class slots of + ;; this class. + (class-slots nil :type list) + ;; + ;; Report function or NIL. + (report nil :type (or function null)) + ;; + ;; List of alternating initargs and initforms. + (default-initargs () :type list) + ;; + ;; CPL as a list of class objects, with all non-condition classes removed. + (cpl () :type list)) -(defmacro parent-type (condition-type) `(get ,condition-type 'parent-type)) -(defmacro slots (condition-type) `(get ,condition-type 'slots)) -(defmacro conc-name (condition-type) `(get ,condition-type 'conc-name)) -(defmacro report-function (condition-type) - `(get ,condition-type 'report-function)) -(defmacro make-function (condition-type) `(get ,condition-type 'make-function)) +); eval-when (compile load eval) -) ;eval-when +(defstruct (condition + (:constructor make-condition-object (actual-initargs)) + (:alternate-metaclass instance condition-class + make-condition-class)) + + (function-name nil) + ;; + ;; Actual initargs supplied to MAKE-CONDITION. + (actual-initargs (required-argument) :type list) + ;; + ;; Plist mapping slot names to any values that were assigned or defaulted + ;; after creation. + (assigned-slots () :type list)) + + +(defstruct condition-slot + (name (required-argument) :type symbol) + ;; + ;; List of all applicable initargs. + (initargs (required-argument) :type list) + ;; + ;; Names of reader and writer functions. + (readers (required-argument) :type list) + (writers (required-argument) :type list) + ;; + ;; True if :INITFORM was specified. + (initform-p (required-argument) :type (member t nil)) + ;; + ;; If a function, call it with no args. Otherwise, the actual value. + (initform (required-argument) :type t) + ;; + ;; Allocation of this slot. Nil only until defaulted. + (allocation nil :type (member :instance :class nil)) + ;; + ;; If :class allocation, a cons whose car holds the value. + (cell nil :type (or cons null))) -(defun condition-report (condition stream) - (do ((type (type-of condition) (parent-type type))) - ((not type) - (format stream "The condition ~A occurred." (type-of condition))) - (let ((reporter (report-function type))) - (when reporter - (funcall reporter condition stream) - (return nil))))) - -(setf (make-function 'condition) '|constructor for condition|) - -(defun make-condition (type &rest slot-initializations) - "Makes a condition of type type using slot-initializations as initial values - for the slots." - (let ((fn (make-function type))) - (cond ((not fn) (error 'simple-type-error - :datum type - :expected-type '(satisfies make-function) - :format-control "Not a condition type: ~S" - :format-arguments (list type))) - (t (apply fn slot-initializations))))) - - -;;; Some utilities used at macro expansion time. -;;; -(eval-when (eval compile load) +(eval-when (compile load eval) + (setf (condition-class-cpl (find-class 'condition)) + (list (find-class 'condition)))) -(defmacro resolve-function (function expression resolver) - `(cond ((and ,function ,expression) - (cerror "Use only the :~A information." - "Only one of :~A and :~A is allowed." - ',function ',expression)) - (,expression (setq ,function ,resolver)))) - -(defun parse-new-and-used-slots (slots parent-type) - (let ((new '()) (used '())) - (dolist (slot slots) - (if (slot-used-p (car slot) parent-type) - (push slot used) - (push slot new))) - (values new used))) +(setf (condition-class-report (find-class 'condition)) + #'(lambda (cond stream) + (format stream "Condition ~S was signalled." (type-of cond)))) -(defun slot-used-p (slot-name type) - (cond ((eq type 'condition) nil) - ((not type) (error "The type ~S does not inherit from condition." type)) - ((assoc slot-name (slots type))) - (t (slot-used-p slot-name (parent-type type))))) +(eval-when (compile load eval) -) ;eval-when +(defun find-condition-layout (name parent-types) + (let* ((cpl (remove-duplicates + (reverse + (reduce #'append + (mapcar #'(lambda (x) + (condition-class-cpl + (find-class x))) + parent-types))))) + (cond-layout (info type compiler-layout 'condition)) + (olayout (info type compiler-layout name)) + (new-inherits + (concatenate 'simple-vector + (layout-inherits cond-layout) + (mapcar #'class-layout cpl)))) + (if (and olayout + (not (mismatch (layout-inherits olayout) new-inherits))) + olayout + (make-layout :class (make-undefined-class name) + :inherits new-inherits + :inheritance-depth -1 + :length (layout-length cond-layout))))) + +); EVAL-WHEN (COMPILE LOAD EVAL) -(defmacro define-condition (name (parent-type) &optional slot-specs - &rest options) - "(DEFINE-CONDITION name (parent-type) - ( {slot-name | (slot-name {slot-option}*)}*) - options)" - (when (eq parent-type 'simple-condition) - (setq parent-type 'internal-simple-condition)) - (let ((constructor (let ((*package* (find-package "CONDITIONS"))) - ;; Bind for the INTERN and the FORMAT. - (intern (format nil "Constructor for ~S" name))))) - (let ((slots (mapcar #'(lambda (slot-spec) - (cond - ((atom slot-spec) - (list slot-spec)) - ((atom (cdr slot-spec)) - slot-spec) - ((atom (cddr slot-spec)) - (warn "Old style slot specifier: ~S" slot-spec) - slot-spec) - (t - (destructuring-bind - (name &key (type nil typep) initform - &allow-other-keys) - slot-spec - `(,name ,initform - ,@(when typep `(:type ,type))))))) - slot-specs))) - (multiple-value-bind (new-slots used-slots) - (parse-new-and-used-slots slots parent-type) - (let ((conc-name-p nil) - (conc-name nil) - (report-function nil) - (documentation nil)) - (do ((o options (cdr o))) - ((null o)) - (let ((option (car o))) - (case (car option) ;should be ecase - (:conc-name - (setq conc-name-p t) - (setq conc-name (cadr option))) - (:report - (setq report-function - (if (stringp (cadr option)) - `(lambda (stream) - (write-string ,(cadr option) stream)) - (cadr option)))) - (:documentation (setq documentation (cadr option))) - (otherwise - (cerror "Ignore this DEFINE-CONDITION option." - "Invalid DEFINE-CONDITION option: ~S" option))))) - (unless conc-name-p - (setq conc-name - (intern (concatenate 'simple-string (symbol-name name) - "-") - *package*))) - ;; The following three forms are compile-time side-effects. For now, - ;; they affect the global environment, but with modified abstractions - ;; for parent-type, slots, and conc-name, the compiler could easily - ;; make them local. - (setf (parent-type name) parent-type) - (setf (slots name) slots) - (setf (conc-name name) conc-name) - ;; finally, the expansion ... - `(progn - (defstruct (,name - (:constructor ,constructor) - (:predicate nil) - (:copier nil) - (:print-function condition-print) - (:include ,parent-type ,@used-slots) - (:conc-name ,conc-name)) - ,@new-slots) - (setf (documentation ',name 'type) ',documentation) - (setf (parent-type ',name) ',parent-type) - (setf (slots ',name) ',slots) - (setf (conc-name ',name) ',conc-name) - (setf (report-function ',name) - ,(if report-function `#',report-function)) - (setf (make-function ',name) ',constructor) - ',name)))))) + +;;;; Condition reporting: + +(defun %print-condition (s stream d) + (declare (ignore d)) + (if *print-escape* + (print-unreadable-object (s stream :identity t :type t)) + (dolist (class (condition-class-cpl (class-of s)) + (error "No REPORT? Shouldn't happen!")) + (let ((report (condition-class-report class))) + (when report + (return (funcall report s stream))))))) + +;;;; Condition slots: + +(defvar *empty-slot* '(empty)) + +(defun find-slot-default (class slot) + (let ((initargs (condition-slot-initargs slot)) + (cpl (condition-class-cpl class))) + (dolist (class cpl) + (let ((default-initargs (condition-class-default-initargs class))) + (dolist (initarg initargs) + (let ((val (getf default-initargs initarg *empty-slot*))) + (unless (eq val *empty-slot*) + (return-from find-slot-default + (if (functionp val) + (funcall val) + val))))))) + + (if (condition-slot-initform-p slot) + (let ((initform (condition-slot-initform slot))) + (if (functionp initform) + (funcall initform) + initform)) + (error "Condition slot is not bound: ~S" + (condition-slot-name slot))))) + +(defun find-slot (classes name) + (dolist (sclass classes nil) + (dolist (slot (condition-class-slots sclass)) + (when (eq (condition-slot-name slot) name) + (return-from find-slot slot))))) + +(defun condition-writer-function (condition new-value name) + (dolist (cslot (condition-class-class-slots + (layout-class (%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)) + (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-slot*))) + (if (eq val *empty-slot*) + (let ((actual-initargs (condition-actual-initargs condition)) + (slot (find-slot (condition-class-cpl class) name))) + (dolist (initarg (condition-slot-initargs slot)) + (let ((val (getf actual-initargs initarg *empty-slot*))) + (unless (eq val *empty-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))) + val)))) + + +(defun make-condition (thing &rest args) + "Make an instance of a condition object using the specified initargs." + (let* ((thing (if (symbolp thing) + (find-class thing) + thing)) + (class (typecase thing + (condition-class thing) + (class + (error "~S is not a condition class.")) + (t + (error "Bad thing for class arg:~% ~S" thing)))) + (res (make-condition-object args))) + (setf (%instance-layout res) (class-layout class)) + ;; + ;; Set any class slots with initargs present in this call. + (dolist (cslot (condition-class-class-slots class)) + (dolist (initarg (condition-slot-initargs cslot)) + (let ((val (getf args initarg *empty-slot*))) + (unless (eq val *empty-slot*) + (setf (car (condition-slot-cell cslot)) val))))) + + res)) + + +;;;; DEFINE-CONDITION +(eval-when (compile load eval) +(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 #'find-class direct-supers)) + (cond ((not old-layout) + (register-layout layout)) + ((redefine-layout-warning old-layout "current" + layout "new") + (register-layout layout :invalidate t))) + + (setf (find-class name) class) + ;; + ;; Initialize CPL slot from layout. + (collect ((cpl)) + (cpl class) + (let ((inherits (layout-inherits layout))) + (do ((i (1- (length inherits)) (1- i))) + ((minusp i)) + (let ((super (find-class + (class-name + (layout-class (svref inherits i)))))) + (when (typep super 'condition-class) + (cpl super))))) + (setf (condition-class-cpl class) (cpl)))) + (undefined-value)) + +); eval-when (compile load eval) + +(defun %define-condition (name slots documentation report default-initargs) + (let ((class (find-class name))) + (setf (slot-class-print-function class) #'%print-condition) + (setf (condition-class-slots class) slots) + (setf (condition-class-report class) report) + (setf (condition-class-default-initargs class) default-initargs) + (setf (documentation name 'type) documentation) + + (dolist (slot slots) + (let* ((name (condition-slot-name slot)) + (islot (find-slot (cdr (condition-class-cpl class)) name))) + ;; + ;; Handle :allocation. If a new class slot, allocate cell. If NIL, + ;; default it. + (ecase (condition-slot-allocation slot) + (:class + (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-slot*)))) + (:instance) + ((nil) + (when islot + (setf (condition-slot-allocation slot) + (condition-slot-allocation islot))))) + + ;; + ;; Default initform. + (when (and islot (not (condition-slot-initform-p slot))) + (setf (condition-slot-initform slot) + (condition-slot-initform islot)) + (setf (condition-slot-initform-p slot) + (condition-slot-initform-p islot))) + + ;; + ;; Set up reader & writer functions. + (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)))))) + + (collect ((class-slots)) + ;; + ;; Direct class slots: + (dolist (slot slots) + (when (eq (condition-slot-allocation slot) :class) + (class-slots slot))) + ;; + ;; Indirect class slots: + (dolist (sclass (class-direct-superclasses class)) + (dolist (cslot (condition-class-class-slots sclass)) + (when (and (eq (condition-slot-allocation + (find-slot (condition-class-cpl class) + (condition-slot-name cslot))) + :class) + (not (member cslot (class-slots) + :key #'condition-slot-name + :test #'eq))) + (class-slots (copy-structure cslot))))) + + (dolist (slot (union slots (class-slots))) + (let ((name (condition-slot-name slot))) + (collect ((initargs (condition-slot-initargs slot) union)) + (dolist (super (class-direct-superclasses class)) + (dolist (sslot (condition-class-slots super)) + (when (eq (condition-slot-name sslot) name) + (initargs (condition-slot-initargs sslot))))) + (setf (condition-slot-initargs slot) (initargs))))) + + (setf (condition-class-class-slots class) (class-slots)))) + + name) + + +(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) + &body options) + "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option* + Define NAME as a condition type. This new type inherits slots and its + report function from the specified PARENT-TYPEs. A slot spec is a list of: + (slot-name :reader <rname> :initarg <iname> {Option Value}* + + The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION + and :TYPE and the overall options :DEFAULT-INITARGS and + [type] :DOCUMENTATION are also allowed. + + The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either + a string or a two-argument lambda or function name. If a function, the + function is called with the condition and stream to report the condition. + If a string, the string is printed. + + Condition types are classes, but (as allowed by ANSI and not as described in + CLtL2) and neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and + SLOT-VALUE may not be used on condition objects." + (let* ((parent-types (or parent-types '(condition))) + (layout (find-condition-layout name parent-types)) + (documentation nil) + (report nil) + (default-initargs ())) + (collect ((slots) + (all-readers nil append) + (all-writers nil append)) + (dolist (spec slot-specs) + (when (keywordp spec) + (warn "Keyword slot name indicates probable syntax error:~% ~S" + spec)) + (let* ((spec (if (consp spec) spec (list spec))) + (slot-name (first spec)) + (allocation :instance) + (initform-p nil) + initform) + (collect ((initargs) + (readers) + (writers)) + (do ((options (rest spec) (cddr options))) + ((null options)) + (unless (and (consp options) (consp (cdr options))) + (error "Malformed condition slot spec:~% ~S." spec)) + (let ((arg (second options))) + (case (first options) + (:reader (readers arg)) + (:writer (writers arg)) + (:accessor + (readers arg) + (writers `(setf ,arg))) + (:initform + (when initform-p + (error "More than one :INITFORM in:~% ~S" spec)) + (setq initform-p t) + (setq initform arg)) + (:initarg (initargs arg)) + (:allocation + (setq allocation arg)) + (:type) + (t + (error "Unknown slot option:~% ~S" (first options)))))) + + (unless (initargs) + (warn "Probable error: no initargs for condition slot:~% ~S" + slot-name)) + (unless (readers) + (warn "Probable error: no readers for condition slot:~% ~S" + slot-name)) + + (all-readers (readers)) + (all-writers (writers)) + (slots `(make-condition-slot + :name ',slot-name + :initargs ',(initargs) + :readers ',(readers) + :writers ',(writers) + :initform-p ',initform-p + :initform + ,(if (constantp initform) + `',(eval initform) + `#'(lambda () ,initform))))))) + + (dolist (option options) + (unless (consp option) + (error "Bad option:~% ~S" option)) + (case (first option) + (:documentation (setq documentation (second option))) + (:report + (let ((arg (second option))) + (setq report + (if (stringp arg) + `#'(lambda (condition stream) + (declare (ignore condition)) + (write-string ,arg stream)) + `#',arg)))) + (:default-initargs + (do ((initargs (rest option) (cddr initargs))) + ((endp initargs)) + (let ((val (second initargs))) + (setq default-initargs + (list* `',(first initargs) + (if (constantp val) + `',(eval val) + `#'(lambda () ,val)) + default-initargs))))) + (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 load eval) + (%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)))))) ;;;; HANDLER-BIND and SIGNAL. @@ -512,9 +793,7 @@ (define-condition serious-condition (condition) ()) -(define-condition error (serious-condition) - ((function-name :init-form nil - :accessor serious-condition-function-name))) +(define-condition error (serious-condition) ()) (define-condition warning (condition) ()) (define-condition style-warning (warning) ()) @@ -523,88 +802,39 @@ (apply #'format stream (simple-condition-format-control condition) (simple-condition-format-arguments condition))) -(deftype simple-condition () - '(or internal-simple-condition simple-warning simple-type-error - simple-error simple-style-warning)) - -;;; The simple-condition is really called internal-simple-condition, so -;;; SIMPLE-CONDITION-FORMAT-CONTROL and SIMPLE-CONDITION-FORMAT-ARGUMENTS could -;;; be written to handle the simple-condition, simple-warning, -;;; simple-style-warning, simple-type-error, and simple-error types. -;;; DEFINE-CONDITION special-cases inheriting simple-condition to make this -;;; work. This seems to create some kind of bogus multiple inheritance that -;;; the user sees. -;;; -(define-condition internal-simple-condition (condition) - ((format-control :acessor internal-simple-condition-format-control) - (format-arguments :init-form '() - :accessor internal-simple-condition-format-arguments)) +(define-condition simple-condition () + ((format-control :reader simple-condition-format-control + :initarg :format-control) + (format-arguments :reader simple-condition-format-arguments + :initarg :format-arguments + :initform '())) (:report simple-condition-printer)) -(setf (symbol-plist 'simple-condition) - (symbol-plist 'internal-simple-condition)) - - -;;; The simple-warning type has a conc-name, so SIMPLE-CONDITION-FORMAT-CONTROL -;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the -;;; simple-condition, simple-warning, simple-type-error, and simple-error -;;; types. This seems to create some kind of bogus multiple inheritance that -;;; the user sees. -;;; -(define-condition simple-warning (warning) - ((format-control :accessor internal-simple-warning-format-control) - (format-arguments :init-form '() - :accessor internal-simple-warning-format-arguments)) - (:report simple-condition-printer)) -;;; -(define-condition simple-style-warning (style-warning) - ((format-control :accessor internal-simple-style-warning-format-control) - (format-arguments :init-form '() - :accessor internal-simple-style-warning-format-arguments)) - (:report simple-condition-printer)) +(define-condition simple-warning (simple-condition warning) ()) +(define-condition simple-style-warning (simple-condition style-warning) ()) (defun print-simple-error (condition stream) (format stream "~&~@<Error in function ~S: ~3i~:_~?~:>" - (serious-condition-function-name condition) - (internal-simple-error-format-control condition) - (internal-simple-error-format-arguments condition))) - -;;; The simple-error type has a conc-name, so SIMPLE-CONDITION-FORMAT-CONTROL -;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the -;;; simple-condition, simple-warning, simple-type-error, and simple-error types. -;;; This seems to create some kind of bogus multiple inheritance that the user -;;; sees. -;;; -(define-condition simple-error (error) - ((format-control :accessor internal-simple-error-format-control) - (format-arguments :init-form '() - :accessor internal-simple-error-format-arguments)) - (:report print-simple-error)) + (condition-function-name condition) + (simple-condition-format-control condition) + (simple-condition-format-arguments condition))) +(define-condition simple-error (simple-condition error) () + (:report print-simple-error)) (define-condition storage-condition (serious-condition) ()) (define-condition type-error (error) - (datum - expected-type) + ((datum :reader type-error-datum :initarg :datum) + (expected-type :reader type-error-expected-type :initarg :expected-type)) (:report (lambda (condition stream) (format stream "~@<Type-error in ~S: ~3i~:_~S is not of type ~S~:>" - (serious-condition-function-name condition) + (condition-function-name condition) (type-error-datum condition) (type-error-expected-type condition))))) -;;; The simple-type-error type has a conc-name, so -;;; SIMPLE-CONDITION-FORMAT-CONTROL and SIMPLE-CONDITION-FORMAT-ARGUMENTS could -;;; be written to handle the simple-condition, simple-warning, -;;; simple-type-error, and simple-error types. This seems to create some kind -;;; of bogus multiple inheritance that the user sees. -;;; -(define-condition simple-type-error (type-error) - ((format-control :accessor internal-simple-type-error-format-control) - (format-arguments :init-form '() - :accessor internal-simple-type-error-format-arguments)) - (:report simple-condition-printer)) +(define-condition simple-type-error (simple-condition type-error) ()) (define-condition kernel:layout-invalid (type-error) () @@ -612,13 +842,13 @@ (lambda (condition stream) (format stream "Layout-invalid error in ~S:~@ Type test of class ~S was passed obsolete instance:~% ~S" - (serious-condition-function-name condition) + (condition-function-name condition) (kernel:class-proper-name (type-error-expected-type condition)) (type-error-datum condition))))) (define-condition case-failure (type-error) - (name - possibilities) + ((name :reader case-failure-name :initarg :name) + (possibilities :reader case-failure-possibilities :initarg :possibilities)) (:report (lambda (condition stream) (format stream "~@<~S fell through ~S expression. ~:_Wanted one of ~:S.~:>" @@ -627,55 +857,11 @@ (case-failure-possibilities condition))))) -;;; SIMPLE-CONDITION-FORMAT-CONTROL and SIMPLE-CONDITION-FORMAT-ARGUMENTS. -;;; These exist for the obvious types to seemingly give the impression of -;;; multiple inheritance. That is, the last three types inherit from warning, -;;; type-error, and error while inheriting from simple-condition also. -;;; -(defun simple-condition-format-control (condition) - (etypecase condition - (internal-simple-condition - (internal-simple-condition-format-control condition)) - (simple-warning - (internal-simple-warning-format-control condition)) - (simple-style-warning - (internal-simple-style-warning-format-control condition)) - (simple-type-error - (internal-simple-type-error-format-control condition)) - (simple-error - (internal-simple-error-format-control condition)))) -;;; -(defun simple-condition-format-arguments (condition) - (etypecase condition - (internal-simple-condition - (internal-simple-condition-format-arguments condition)) - (simple-warning - (internal-simple-warning-format-arguments condition)) - (simple-style-warning - (internal-simple-style-warning-format-arguments condition)) - (simple-type-error - (internal-simple-type-error-format-arguments condition)) - (simple-error - (internal-simple-error-format-arguments condition)))) - - (define-condition program-error (error) ()) (define-condition parse-error (error) ()) - -(defun print-control-error (condition stream) - (format stream "~&~@<Error in function ~S: ~3i~:_~?~:>" - (serious-condition-function-name condition) - (control-error-format-control condition) - (control-error-format-arguments condition))) - -(define-condition control-error (error) - ((format-control :accessor control-error-format-control) - (format-arguments :init-form '() - :accessor control-error-format-arguments)) - (:report print-control-error)) - - -(define-condition stream-error (error) (stream)) +(define-condition control-error (simple-error) ()) +(define-condition stream-error (error) + ((stream :reader stream-error-stream :initarg :stream))) (define-condition end-of-file (stream-error) () (:report @@ -683,18 +869,21 @@ (format stream "End-of-File on ~S" (stream-error-stream condition))))) -(define-condition file-error (error) (pathname)) +(define-condition file-error (error) + ((pathname :reader file-error-pathname :initarg :pathname))) -(define-condition package-error (error) (package)) +(define-condition package-error (error) + ((package :reader package-error-package :initarg :package))) -(define-condition cell-error (error) (name)) +(define-condition cell-error (error) + ((name :reader cell-error-name :initarg :name))) (define-condition unbound-variable (cell-error) () (:report (lambda (condition stream) (format stream "Error in ~S: the variable ~S is unbound." - (serious-condition-function-name condition) + (condition-function-name condition) (cell-error-name condition))))) (define-condition undefined-function (cell-error) () @@ -702,10 +891,12 @@ (lambda (condition stream) (format stream "Error in ~S: the function ~S is undefined." - (serious-condition-function-name condition) + (condition-function-name condition) (cell-error-name condition))))) -(define-condition arithmetic-error (error) (operation operands) +(define-condition arithmetic-error (error) + ((operation :reader arithmetic-error-operation :initarg :operation) + (operands :reader arithmetic-error-operands :initarg :operands)) (:report (lambda (condition stream) (format stream "Arithmetic error ~S signalled." (type-of condition))