Optimize MAKE-ARRAY on unknown element-type.

[sbcl.git] / src / code / late-condition.lisp

diff --git a/src/code/late-condition.lisp b/src/code/late-condition.lisp
index afd22b5..71c570d 100644 (file)
--- a/src/code/late-condition.lisp
+++ b/src/code/late-condition.lisp
@@ -13,13 +13,57 @@
 \f
 (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)
-  (unless (fboundp name)
-    (ensure-generic-function 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)
-  (unless (fboundp name)
-    (ensure-generic-function 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))))))