src/class-layout-impl.lisp: Abstract out `sod-message-applicable-methods'.

We shall want this more later.

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 944a9752a29f1a8948bb417a400da100ebb038d8..ff820f1165812bf16dfe7a45126431c81408cf19 100644 (file)
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -544,6 +544,7 @@ method-proto.lisp
   method-keyword-argument-lists                 generic
   primary-method-class                          generic
   simple-method-body                            generic
+  sod-message-applicable-methods                generic
   sod-message-argument-tail                     generic
   sod-message-effective-method-class            generic
   sod-method-description                        generic
@@ -1514,6 +1515,8 @@ sod-initializer-slot
   sod-initializer
 sod-initializer-value
   sod-initializer
+sod-message-applicable-methods
+  sod-message sod-class
 sod-message-argument-tail
   basic-message
 sod-message-class

diff --git a/doc/layout.tex b/doc/layout.tex
index b106aa422c3d448f7912a7a027167d1c8ed49bdd..952cec08db13e5e807cca234db3d4b99822c59fb 100644 (file)
--- a/doc/layout.tex
+++ b/doc/layout.tex
@@ -229,6 +229,10 @@
      \dhead{gf}{effective-method-keywords @<method> @> @<list>}}
 \end{describe*}
 
+\begin{describe}{gf}
+    {sod-message-applicable-methods @<message> @<class> @> list}
+\end{describe}
+
 \begin{describe}{gf}
     {sod-message-effective-method-class @<message> @> @<class>}
 \end{describe}

diff --git a/src/class-layout-impl.lisp b/src/class-layout-impl.lisp
index 119996eb20149d06237684be3bec4109ef918e4a..7ff46679b818cec6e397b50e65b5bdf474c29def 100644 (file)
--- a/src/class-layout-impl.lisp
+++ b/src/class-layout-impl.lisp
@@ -127,14 +127,18 @@ (defmethod print-object ((entry method-entry) stream)
            (sod-class-nickname (method-entry-chain-head entry))
            (method-entry-role entry))))
 
+(defmethod sod-message-applicable-methods
+    ((message sod-message) (class sod-class))
+  (mappend (lambda (super)
+            (remove message
+                    (sod-class-methods super)
+                    :key #'sod-method-message
+                    :test-not #'eql))
+          (sod-class-precedence-list class)))
+
 (defmethod compute-sod-effective-method
     ((message sod-message) (class sod-class))
-  (let ((direct-methods (mappend (lambda (super)
-                                  (remove message
-                                          (sod-class-methods super)
-                                          :key #'sod-method-message
-                                          :test-not #'eql))
-                                (sod-class-precedence-list class))))
+  (let ((direct-methods (sod-message-applicable-methods message class)))
     (make-instance (sod-message-effective-method-class message)
                   :message message
                   :class class

diff --git a/src/method-proto.lisp b/src/method-proto.lisp
index f7f1f474b8a9e93dfee6d60ac9ce9f6d2e4d6a6d..4a624c53da529b227087d0c40bc97fb24457b174 100644 (file)
--- a/src/method-proto.lisp
+++ b/src/method-proto.lisp
@@ -49,6 +49,14 @@ (defclass effective-method ()
    will be a list of applicable methods sorted in most-to-least specific
    order."))
 
+(export 'sod-message-applicable-methods)
+(defgeneric sod-message-applicable-methods (message class)
+  (:documentation
+   "Return a list of applicable methods for a MESSAGE.
+
+   The list contains all methods applicable for MESSAGE when sent to an
+   instance of CLASS, most specific first."))
+
 (export 'sod-message-effective-method-class)
 (defgeneric sod-message-effective-method-class (message)
   (:documentation