1 ;;;; Condition support in target lisp
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB-KERNEL")
14 (fmakunbound 'install-condition-slot-reader
)
15 (fmakunbound 'install-condition-slot-writer
)
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
27 :specializers
(mapcar #'find-class specializers
)
28 :lambda-list lambda-list
29 :function method-function
32 (add-method gf method
)
35 (let ((specialized-lambda-list
36 (mapcar (lambda (parameter specializer
)
37 (if (eq specializer t
)
39 `(,parameter
,specializer
)))
40 lambda-list specializers
)))
41 `(defmethod ,name
,specialized-lambda-list
42 (,access-function-name
,@lambda-list
',slot-name
))))))))
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
))))
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
)
57 (standard-method-function
59 (condition-slot-value condition slot-name
)))))
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
)))))))