From: Alexey Dejneka <adejneka@comail.ru>
Date: Sat, 20 Dec 2003 07:13:47 +0000 (+0000)
Subject: 0.8.6.41:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=13e74e5f0d215aa140f9c07330b09ebb286a171a;p=sbcl.git

0.8.6.41:
        * Optimize INSTALL-CONDITION-SLOT-{READER,WRITER} for
          STANDARD-GENERIC-FUNCTION as suggested by Brian Mastenbrook
          and CSR.
---

diff --git a/NEWS b/NEWS
index ec5029a..e4bb460 100644
--- a/NEWS
+++ b/NEWS
@@ -2223,6 +2223,7 @@ changes in sbcl-0.8.7 relative to sbcl-0.8.6:
   * SB-SIMPLE-STREAMS enhancement: simple-streams can now be used as
     streams for the REPL, for the debugger, and so on.  (thanks to
     David Licteblau)
+  * DEFINE-CODITION is more efficient.  (thanks to Brian Mastenbrook)
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** the value of the :REHASH-THRESHOLD argument to MAKE-HASH-TABLE
        is ignored if it is too small, rather than propagating through
@@ -2230,7 +2231,7 @@ changes in sbcl-0.8.7 relative to sbcl-0.8.6:
     ** extremely complex negations of CONS types were not being
        sufficiently canonicalized, leading to inconsistencies in
        SUBTYPEP.
-    ** VALUES tranformer lost derive type.
+    ** VALUES tranformer lost derived type.
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles
diff --git a/src/code/late-condition.lisp b/src/code/late-condition.lisp
index afd22b5..622051b 100644
--- a/src/code/late-condition.lisp
+++ b/src/code/late-condition.lisp
@@ -13,13 +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)
-  (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))))))
diff --git a/version.lisp-expr b/version.lisp-expr
index 3108d43..18b5dd3 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.6.40"
+"0.8.6.41"