Changeset 10335


Ignore:
Timestamp:
11/03/05 23:51:22 (16 years ago)
Author:
piso
Message:

DEFINE-CONDITION

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/clos.lisp

    r10322 r10335  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: clos.lisp,v 1.190 2005-11-02 03:02:57 piso Exp $
     4;;; $Id: clos.lisp,v 1.191 2005-11-03 23:51:22 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    21312131;;; Conditions.
    21322132
    2133 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
    2134                                  &body options)
     2133(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options)
    21352134  (let ((parent-types (or parent-types '(condition)))
    21362135        (report nil))
    21372136    (dolist (option options)
    21382137      (when (eq (car option) :report)
    2139         (let ((arg (cadr option)))
    2140           (setf report
    2141                 (if (stringp arg)
    2142                     `#'(lambda (condition stream)
    2143                         (declare (ignore condition))
    2144                         (write-string ,arg stream))
    2145                     `#'(lambda (condition stream)
    2146                         (funcall #',arg condition stream)))))))
    2147     (if report
    2148         `(progn
    2149            (defclass ,name ,parent-types ,slot-specs ,@options)
    2150            (defmethod print-object ((condition ,name) stream)
    2151              (if *print-escape*
    2152                  (call-next-method)
    2153                  (funcall ,report condition stream)))
    2154            (setf (get ',name 'sys::condition-report-function) ,report)
    2155            ',name)
    2156         `(progn
    2157            (defclass ,name ,parent-types ,slot-specs ,@options)
    2158            ',name))))
     2138        (setf report (cadr option))
     2139        (return)))
     2140    (typecase report
     2141      (null
     2142       `(progn
     2143          (defclass ,name ,parent-types ,slot-specs ,@options)
     2144          ',name))
     2145      (string
     2146       `(progn
     2147          (defclass ,name ,parent-types ,slot-specs ,@options)
     2148          (defmethod print-object ((condition ,name) stream)
     2149            (if *print-escape*
     2150                (call-next-method)
     2151                (progn (write-string ,report stream) condition)))
     2152          ',name))
     2153      (t
     2154       `(progn
     2155          (defclass ,name ,parent-types ,slot-specs ,@options)
     2156          (defmethod print-object ((condition ,name) stream)
     2157            (if *print-escape*
     2158                (call-next-method)
     2159                (funcall #',report condition stream)))
     2160          ',name)))))
    21592161
    21602162(defun make-condition (type &rest initargs)
Note: See TracChangeset for help on using the changeset viewer.