;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL")) #+kcl (eval-when (compile load eval) (when (fboundp 'remove-clcs-symbols) (remove-clcs-symbols)) ) ;DEFINE-CONDITION ;MAKE-CONDITION ;condition printing ;(define-condition CONDITION ...) ;CONDITIONP ;CONDITION-CLASS-P ;SIMPLE-CONDITION-P ;SIMPLE-CONDITION-CLASS-P #-(or clos pcl) (progn (DEFUN CONDITION-PRINT (CONDITION STREAM DEPTH) DEPTH ;ignored (COND (*PRINT-ESCAPE* (FORMAT STREAM "#<~S.~D>" (TYPE-OF CONDITION) (UNIQUE-ID CONDITION))) (T (CONDITION-REPORT CONDITION STREAM)))) (DEFSTRUCT (CONDITION :CONC-NAME (:CONSTRUCTOR |Constructor for CONDITION|) (:PREDICATE NIL) (:PRINT-FUNCTION CONDITION-PRINT)) (-DUMMY-SLOT- NIL)) (EVAL-WHEN (EVAL COMPILE LOAD) (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)) );NEHW-LAVE (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) (LET ((FN (MAKE-FUNCTION TYPE))) (COND ((NOT FN) (ERROR 'SIMPLE-TYPE-ERROR :DATUM TYPE :EXPECTED-TYPE '(SATISFIES MAKE-FUNCTION) :FORMAT-STRING "Not a condition type: ~S" :FORMAT-ARGUMENTS (LIST TYPE))) (T (APPLY FN SLOT-INITIALIZATIONS))))) (EVAL-WHEN (EVAL COMPILE LOAD) ;Some utilities that are used at macro expansion time (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))) (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))))) );NEHW-LAVE (DEFMACRO DEFINE-CONDITION (NAME (PARENT-TYPE) SLOT-SPECS &REST OPTIONS) (LET ((CONSTRUCTOR (LET ((*PACKAGE* *THIS-PACKAGE*)) ;Bind for the INTERN -and- the FORMAT (INTERN (FORMAT NIL "Constructor for ~S" NAME))))) (LET ((SLOTS (MAPCAR #'(LAMBDA (SLOT-SPEC) (IF (ATOM SLOT-SPEC) (LIST SLOT-SPEC) SLOT-SPEC)) 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 (CONDITION STREAM) (DECLARE (IGNORE CONDITION)) (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))))) (IF (NOT CONC-NAME-P) (SETQ CONC-NAME (INTERN (FORMAT NIL "~A-" 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)))))) (defun conditionp (object) (typep object 'condition)) (defun condition-class-p (object) (and (symbolp object) (MAKE-FUNCTION object))) ) #+(or clos pcl) (progn (eval-when (compile load eval) (defvar *condition-class-list* nil) ; list of (class-name initarg1 type1...) ) (DEFMACRO DEFINE-CONDITION (NAME PARENT-LIST SLOT-SPECS &REST OPTIONS) (unless (or parent-list (eq name 'condition)) (setq parent-list (list 'condition))) (let* ((REPORT-FUNCTION nil) (DOCUMENTATION nil)) (DO ((O OPTIONS (CDR O))) ((NULL O)) (LET ((OPTION (CAR O))) (CASE (CAR OPTION) (:REPORT (SETQ REPORT-FUNCTION (IF (STRINGP (CADR OPTION)) `(LAMBDA (CONDITION STREAM) (DECLARE (IGNORE CONDITION)) (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))))) `(progn (eval-when (compile) #+pcl (setq pcl::*defclass-times* '(compile load eval))) (defclass ,name ,parent-list ,slot-specs) (eval-when (compile load eval) (pushnew '(,name ,parent-list ,@(mapcan #'(lambda (slot-spec) (let* ((ia (getf (cdr slot-spec) ':initarg))) (when ia (list (cons ia (or (getf (cdr slot-spec) ':type) t)))))) SLOT-SPECS)) *condition-class-list*) #+kcl (setf (get ',name #+akcl 'si::s-data #-akcl 'si::is-a-structure) nil) ; (setf (get ',name 'documentation) ',documentation) ) ,@(when REPORT-FUNCTION `((DEFMETHOD PRINT-OBJECT ((X ,NAME) STREAM) (IF *PRINT-ESCAPE* (CALL-NEXT-METHOD) (,REPORT-FUNCTION X STREAM))))) ',NAME))) (eval-when (compile load eval) (define-condition condition () ()) #+pcl (when (fboundp 'pcl::proclaim-incompatible-superclasses) (mapc #'pcl::proclaim-incompatible-superclasses '((condition pcl::metaobject)))) ) (defun conditionp (object) (typep object 'condition)) (DEFMETHOD PRINT-OBJECT ((X condition) STREAM) (IF *PRINT-ESCAPE* (FORMAT STREAM "#<~S.~D>" (class-name (class-of x)) (UNIQUE-ID x)) (FORMAT STREAM "The condition ~A occurred." (TYPE-OF x)))) (defvar *condition-class* (find-class 'condition)) (defun condition-class-p (TYPE) (when (symbolp TYPE) (setq TYPE (find-class TYPE))) (and (typep TYPE 'standard-class) (member *condition-class* (#+pcl pcl::class-precedence-list #-pcl clos::class-precedence-list type)))) (DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS) (unless (condition-class-p TYPE) (ERROR 'SIMPLE-TYPE-ERROR :DATUM TYPE :EXPECTED-TYPE '(SATISFIES condition-class-p) :FORMAT-STRING "Not a condition type: ~S" :FORMAT-ARGUMENTS (LIST TYPE))) (apply #'make-instance TYPE SLOT-INITIALIZATIONS)) )