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 (flet ((install-condition-slot-accessor
  18            (name slot-name lambda-list specializers
  19             access-function-name method-function method-initargs)
  20          (let ((gf (apply #'ensure-generic-function name
  21                           (unless (fboundp name) (list :lambda-list lambda-list)))))
  22            (if (and (eq (class-of gf) (find-class 'standard-generic-function))
  23                     (eq (sb-mop:generic-function-method-class gf)
  24                         (find-class 'standard-method)))
  25                (let ((method (apply #'make-instance
  26                                     'standard-method
  27                                     :specializers (mapcar #'find-class specializers)
  28                                     :lambda-list lambda-list
  29                                     :function method-function
  30                                     method-initargs)))
  31
  32                  (add-method gf method)
  33                  method)
  34                (eval
  35                 (let ((specialized-lambda-list
  36                        (mapcar (lambda (parameter specializer)
  37                                  (if (eq specializer t)
  38                                      parameter
  39                                      `(,parameter ,specializer)))
  40                                lambda-list specializers)))
  41                   `(defmethod ,name ,specialized-lambda-list
  42                      (,access-function-name ,@lambda-list ',slot-name))))))))
  43
  44   (macrolet
  45       ((standard-method-function (lambda &environment env)
  46          (binding* ((proto-gf (load-time-value (ensure-generic-function (gensym))))
  47                     (proto-method (sb-mop:class-prototype
  48                                    (sb-mop:generic-function-method-class proto-gf)))
  49                     ((lambda initargs) (sb-mop:make-method-lambda
  50                                         proto-gf proto-method lambda env))) ; FIXME: coerce to lexenv?
  51            `(values #',lambda ',initargs))))
  52
  53     (defun install-condition-slot-reader (name condition slot-name)
  54       (multiple-value-call #'install-condition-slot-accessor
  55         name slot-name '(condition) (list condition)
  56         'condition-slot-value
  57         (standard-method-function
  58          (lambda (condition)
  59            (condition-slot-value condition slot-name)))))
  60
  61     (defun install-condition-slot-writer (name condition slot-name)
  62       (multiple-value-call #'install-condition-slot-accessor
  63         name slot-name '(new-value condition) (list t condition)
  64         'set-condition-slot-value
  65         (standard-method-function
  66          (lambda (new-value condition)
  67            (set-condition-slot-value condition new-value slot-name)))))))