src/code/late-condition.lisp

   1 ;;;; Condition support in target lisp
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB-KERNEL")
  13 \f
  14 (fmakunbound 'install-condition-slot-reader)
  15 (fmakunbound 'install-condition-slot-writer)
  16
  17 (defmacro standard-method-function (lambda &environment env)
  18   (let ((proto-gf (load-time-value
  19                    (ensure-generic-function (gensym)))))
  20     (multiple-value-bind (lambda initargs)
  21         (sb-mop:make-method-lambda
  22          proto-gf
  23          (sb-mop:class-prototype (sb-mop:generic-function-method-class proto-gf))
  24          lambda
  25          env)
  26       `(values #',lambda ',initargs))))
  27
  28 (defun install-condition-slot-reader (name condition slot-name)
  29   (let ((gf (if (fboundp name)
  30                 (ensure-generic-function name)
  31                 (ensure-generic-function name :lambda-list '(condition)))))
  32     (if (and (eq (class-of gf) (find-class 'standard-generic-function))
  33              (eq (sb-mop:generic-function-method-class gf)
  34                  (find-class 'standard-method)))
  35         (multiple-value-bind (method-fun initargs)
  36               (standard-method-function
  37                (lambda (condition)
  38                  (condition-reader-function condition slot-name)))
  39             (add-method gf
  40                         (apply #'make-instance
  41                                'standard-method
  42                                :specializers (list (find-class condition))
  43                                :lambda-list '(condition)
  44                                :function method-fun
  45                                initargs)))
  46         (eval `(defmethod ,name ((condition ,condition))
  47                  (condition-reader-function condition ',slot-name))))))
  48
  49 (defun install-condition-slot-writer (name condition slot-name)
  50   (let ((gf (if (fboundp name)
  51                 (ensure-generic-function name)
  52                 (ensure-generic-function name :lambda-list '(new-value condition)))))
  53     (if (and (eq (class-of gf) (find-class 'standard-generic-function))
  54              (eq (sb-mop:generic-function-method-class gf)
  55                  (find-class 'standard-method)))
  56         (multiple-value-bind (method-fun initargs)
  57               (standard-method-function
  58                (lambda (new-value condition)
  59                  (condition-writer-function condition new-value slot-name)))
  60             (add-method gf
  61                         (apply #'make-instance
  62                                'standard-method
  63                                :specializers (list (find-class t)
  64                                                    (find-class condition))
  65                                :lambda-list '(new-value condition)
  66                                :function method-fun
  67                                initargs)))
  68         (eval `(defmethod ,name (new-value (condition ,condition))
  69            (condition-writer-function condition new-value ',slot-name))))))