Changeset 5149


Ignore:
Timestamp:
12/15/03 17:11:38 (17 years ago)
Author:
piso
Message:

DEFINE-CONDITION, MAKE-CONDITION

File:
1 edited

Legend:

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

    r5148 r5149  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: clos.lisp,v 1.36 2003-12-15 16:25:48 piso Exp $
     4;;; $Id: clos.lisp,v 1.37 2003-12-15 17:11:38 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    15921592  (compute-applicable-methods-using-classes gf (mapcar #'class-of args)))
    15931593
     1594;;; Conditions.
     1595
     1596(defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
     1597         &body options)
     1598  (let ((parent-types (or parent-types '(condition)))
     1599        (report nil))
     1600    (dolist (option options)
     1601      (format t "option = ~S~%" option)
     1602      (when (eq (car option) :report)
     1603        (let ((arg (cadr option)))
     1604          (setf report
     1605                (if (stringp arg)
     1606                    `#'(lambda (condition stream)
     1607                        (declare (ignore condition))
     1608                        (write-string ,arg stream))
     1609                    `#'(lambda (condition stream)
     1610                        (funcall #',arg condition stream)))))))
     1611    `(progn
     1612       (defclass ,name ,parent-types ,slot-specs ,@options)
     1613       (defmethod print-object ((condition ,name) stream)
     1614         (if *print-escape*
     1615             (call-next-method)
     1616             (funcall ,report condition stream)))
     1617       ',name)))
     1618
     1619(defun make-condition (type &rest initargs)
     1620  (or (%make-condition type initargs)
     1621      (apply #'make-instance (find-class type) initargs)))
     1622
    15941623(provide 'clos)
Note: See TracChangeset for help on using the changeset viewer.