X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-condition.lisp;h=622051b55a18ecf7fb5afbfa164aa9bc5efccd3a;hb=8cad02355db787b9f077b77f508329550ccd0db6;hp=2aa8921b80e5a3cd516ee1f37b3ef849fd83d3a1;hpb=784b195743728436795b90f95273c3535ebee9a5;p=sbcl.git

diff --git a/src/code/late-condition.lisp b/src/code/late-condition.lisp
index 2aa8921..622051b 100644
--- a/src/code/late-condition.lisp
+++ b/src/code/late-condition.lisp
@@ -13,9 +13,57 @@
 
 (fmakunbound 'install-condition-slot-reader)
 (fmakunbound 'install-condition-slot-writer)
+
+(defmacro standard-method-function (lambda &environment env)
+  (let ((proto-gf (load-time-value
+                   (ensure-generic-function (gensym)))))
+    (multiple-value-bind (lambda initargs)
+        (sb-mop:make-method-lambda
+         proto-gf
+         (sb-mop:class-prototype (sb-mop:generic-function-method-class proto-gf))
+         lambda
+         env)
+      `(values #',lambda ,initargs))))
+
 (defun install-condition-slot-reader (name condition slot-name)
-  (eval `(defmethod ,name ((.condition. ,condition))
-           (condition-reader-function .condition. ',slot-name))))
+  (let ((gf (if (fboundp name)
+                (ensure-generic-function name)
+                (ensure-generic-function name :lambda-list '(condition)))))
+    (if (and (eq (class-of gf) (find-class 'standard-generic-function))
+             (eq (sb-mop:generic-function-method-class gf)
+                 (find-class 'standard-method)))
+        (multiple-value-bind (method-fun initargs)
+              (standard-method-function
+               (lambda (condition)
+                 (condition-reader-function condition slot-name)))
+            (add-method gf
+                        (apply #'make-instance
+                               'standard-method
+                               :specializers (list (find-class condition))
+                               :lambda-list '(condition)
+                               :function method-fun
+                               initargs)))
+        (eval `(defmethod ,name ((condition ,condition))
+                 (condition-reader-function condition ',slot-name))))))
+
 (defun install-condition-slot-writer (name condition slot-name)
-  (eval `(defmethod ,name (new-value (.condition. ,condition))
-           (condition-writer-function .condition. new-value ',slot-name))))
+  (let ((gf (if (fboundp name)
+                (ensure-generic-function name)
+                (ensure-generic-function name :lambda-list '(new-value condition)))))
+    (if (and (eq (class-of gf) (find-class 'standard-generic-function))
+             (eq (sb-mop:generic-function-method-class gf)
+                 (find-class 'standard-method)))
+        (multiple-value-bind (method-fun initargs)
+              (standard-method-function
+               (lambda (new-value condition)
+                 (condition-writer-function condition new-value slot-name)))
+            (add-method gf
+                        (apply #'make-instance
+                               'standard-method
+                               :specializers (list (find-class t)
+                                                   (find-class condition))
+                               :lambda-list '(new-value condition)
+                               :function method-fun
+                               initargs)))
+        (eval `(defmethod ,name (new-value (condition ,condition))
+           (condition-writer-function condition new-value ',slot-name))))))