;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (IN-PACKAGE "CONDITIONS") (eval-when (compile load eval) (pushnew #+(or clos pcl) :clos-conditions #-(or clos pcl) :defstruct-conditions *features*) ) (eval-when (compile load eval) (when (and (member :clos-conditions *features*) (member :defstruct-conditions *features*)) (dolist (sym '(simple-condition-format-string simple-condition-format-arguments type-error-datum type-error-expected-type case-failure-name case-failure-possibilities stream-error-stream file-error-pathname package-error-package cell-error-name arithmetic-error-operation internal-error-function-name)) (when (fboundp sym) (fmakunbound sym))) (setq *features* (remove :defstruct-conditions *features*))) ) ;;; Start (DEFINE-CONDITION WARNING (CONDITION) ()) (DEFINE-CONDITION SERIOUS-CONDITION (CONDITION) ()) (DEFINE-CONDITION lisp:ERROR (SERIOUS-CONDITION) ()) (DEFUN SIMPLE-CONDITION-PRINTER (CONDITION STREAM) (APPLY #'FORMAT STREAM (SIMPLE-CONDITION-FORMAT-STRING CONDITION) (SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION))) (DEFINE-CONDITION SIMPLE-CONDITION (CONDITION) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) ((FORMAT-STRING :type string :initarg :FORMAT-STRING :reader SIMPLE-CONDITION-FORMAT-STRING) (FORMAT-ARGUMENTS :initarg :FORMAT-ARGUMENTS :reader SIMPLE-CONDITION-FORMAT-ARGUMENTS :initform '())) #-(or clos pcl)(:CONC-NAME %%SIMPLE-CONDITION-) (:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION SIMPLE-WARNING (#+(or clos pcl) SIMPLE-CONDITION WARNING) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) () #-(or clos pcl)(:CONC-NAME %%SIMPLE-WARNING-) #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION SIMPLE-ERROR (#+(or clos pcl) SIMPLE-CONDITION lisp:ERROR) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) () #-(or clos pcl)(:CONC-NAME %%SIMPLE-ERROR-) #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) ()) (DEFINE-CONDITION STACK-OVERFLOW (STORAGE-CONDITION) ()) (DEFINE-CONDITION STORAGE-EXHAUSTED (STORAGE-CONDITION) ()) (DEFINE-CONDITION TYPE-ERROR (lisp:ERROR) #-(or clos pcl) (DATUM EXPECTED-TYPE) #+(or clos pcl) ((DATUM :initarg :DATUM :reader TYPE-ERROR-DATUM) (EXPECTED-TYPE :initarg :EXPECTED-TYPE :reader TYPE-ERROR-EXPECTED-TYPE)) (:report (lambda (condition stream) (format stream "~S is not of type ~S." (TYPE-ERROR-DATUM CONDITION) (TYPE-ERROR-EXPECTED-TYPE CONDITION))))) (DEFINE-CONDITION SIMPLE-TYPE-ERROR (#+(or clos pcl) SIMPLE-CONDITION TYPE-ERROR) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) () #-(or clos pcl)(:CONC-NAME %%SIMPLE-TYPE-ERROR-) #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION CASE-FAILURE (TYPE-ERROR) #-(or clos pcl) (NAME POSSIBILITIES) #+(or clos pcl) ((NAME :initarg :NAME :reader CASE-FAILURE-NAME) (POSSIBILITIES :initarg :POSSIBILITIES :reader CASE-FAILURE-POSSIBILITIES)) (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "~S fell through ~S expression.~%Wanted one of ~:S." (TYPE-ERROR-DATUM CONDITION) (CASE-FAILURE-NAME CONDITION) (CASE-FAILURE-POSSIBILITIES CONDITION))))) (DEFINE-CONDITION PROGRAM-ERROR (lisp:ERROR) ()) (DEFINE-CONDITION CONTROL-ERROR (lisp:ERROR) ()) (DEFINE-CONDITION STREAM-ERROR (lisp:ERROR) #-(or clos pcl) (STREAM) #+(or clos pcl) ((STREAM :initarg :STREAM :reader STREAM-ERROR-STREAM))) (DEFINE-CONDITION END-OF-FILE (STREAM-ERROR) () (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "Unexpected end of file on ~S." (STREAM-ERROR-STREAM CONDITION))))) (DEFINE-CONDITION FILE-ERROR (lisp:ERROR) #-(or clos pcl) (PATHNAME) #+(or clos pcl) ((PATHNAME :initarg :PATHNAME :reader FILE-ERROR-PATHNAME))) (DEFINE-CONDITION PACKAGE-ERROR (lisp:ERROR) #-(or clos pcl) (PACKAGE) #+(or clos pcl) ((PACKAGE :initarg :PACKAGE :reader PACKAGE-ERROR-PACKAGE))) (DEFINE-CONDITION CELL-ERROR (lisp:ERROR) #-(or clos pcl) (NAME) #+(or clos pcl) ((NAME :initarg :NAME :reader CELL-ERROR-NAME))) (DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR) () (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "The function ~S is undefined." (CELL-ERROR-NAME CONDITION))))) (DEFINE-CONDITION ARITHMETIC-ERROR (lisp:ERROR) #-(or clos pcl) (OPERATION OPERANDS) #+(or clos pcl) ((OPERATION :initarg :OPERATION :reader ARITHMETIC-ERROR-OPERATION))) (DEFINE-CONDITION DIVISION-BY-ZERO (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION FLOATING-POINT-OVERFLOW (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION ABORT-FAILURE (CONTROL-ERROR) () (:REPORT "Abort failed.")) #+kcl (progn ;;; When this form is present, the compiled behavior disagrees with ;;; the interpreted behavior. The interpreted behavior is correct. (define-condition internal-error (lisp:error) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) ((function-name :initarg :function-name :reader internal-error-function-name :initform 'nil)) (:report (lambda (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) #+(or clos pcl)(call-next-method)))) (defun internal-simple-error-printer (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (apply #'format stream (simple-condition-format-string condition) (simple-condition-format-arguments condition))) (define-condition internal-simple-error (internal-error #+(or clos pcl) simple-condition) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-error-) (:report internal-simple-error-printer)) (define-condition internal-type-error (#+(or clos pcl) internal-error type-error) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-type-error-) #-(or clos pcl)(:report (lambda (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (format stream "~S is not of type ~S." (type-error-datum condition) (type-error-expected-type condition))))) (define-condition internal-simple-program-error (#+(or clos pcl) internal-simple-error program-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-program-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-simple-control-error (#+(or clos pcl) internal-simple-error control-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-control-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-unbound-variable (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) #-(or pcl clos) (defun internal-error-function-name (condition) (etypecase condition (internal-error (%%internal-error-function-name condition)) (internal-simple-error (%%internal-simple-error-function-name condition)) (internal-type-error (%%internal-type-error-function-name condition)) (internal-simple-program-error (%%internal-simple-program-error-function-name condition)) (internal-simple-control-error (%%internal-simple-control-error-function-name condition)) (internal-unbound-variable (%%internal-unbound-variable-function-name condition)) (internal-undefined-function (%%internal-undefined-function-function-name condition)) (internal-end-of-file (%%internal-end-of-file-function-name condition)) (internal-simple-file-error (%%internal-simple-file-error-function-name condition)) (internal-simple-stream-error (%%internal-simple-stream-error-function-name condition)))) ) #-(or clos pcl) (progn (DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION) (ETYPECASE CONDITION (SIMPLE-CONDITION (%%SIMPLE-CONDITION-FORMAT-STRING CONDITION)) (SIMPLE-WARNING (%%SIMPLE-WARNING-FORMAT-STRING CONDITION)) (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION)) (SIMPLE-ERROR (%%SIMPLE-ERROR-FORMAT-STRING CONDITION)) #+kcl(internal-simple-error (%%internal-simple-error-format-string condition)) #+kcl(internal-simple-program-error (%%internal-simple-program-error-format-string condition)) #+kcl(internal-simple-control-error (%%internal-simple-control-error-format-string condition)) #+kcl(internal-simple-file-error (%%internal-simple-file-error-format-string condition)) #+kcl(internal-simple-stream-error (%%internal-simple-stream-error-format-string condition)))) (DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION) (ETYPECASE CONDITION (SIMPLE-CONDITION (%%SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-WARNING (%%SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-ERROR (%%SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION)) #+kcl(internal-simple-error (%%internal-simple-error-format-arguments condition)) #+kcl(internal-simple-program-error (%%internal-simple-program-error-format-arguments condition)) #+kcl(internal-simple-control-error (%%internal-simple-control-error-format-arguments condition)) #+kcl(internal-simple-file-error (%%internal-simple-file-error-format-arguments condition)) #+kcl(internal-simple-stream-error (%%internal-simple-stream-error-format-arguments condition)))) (defun simple-condition-class-p (type) (member type '(SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-TYPE-ERROR SIMPLE-ERROR #+kcl internal-simple-error #+kcl internal-simple-program-error #+kcl internal-simple-control-error #+kcl internal-simple-file-error #+kcl internal-simple-stream-error))) ) #+(or clos pcl) (progn (defvar *simple-condition-class* (find-class 'simple-condition)) (defun simple-condition-class-p (TYPE) (when (symbolp TYPE) (setq TYPE (find-class TYPE))) (and (typep TYPE 'standard-class) (member *simple-condition-class* (#+pcl pcl::class-precedence-list #-pcl clos::class-precedence-list type)))) )