From 1ec065092f42b4b0be3dcb833f3f5f24451701fd Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Mon, 9 Jul 2018 12:48:26 +0100
Subject: [PATCH] src/: Lift keyword-argument protocol from effective methods
 to messages.

We're going to want to use this stuff during class finalization, before
we've made the effective methods.

This also refactors the machinery somewhat, introducing a new function
`compute-effective-method-keyword-arguments' to do the slightly fiddly
work in initializing `effective-method'.
---
 doc/SYMBOLS           |  9 ++++----
 doc/layout.tex        | 16 ++++++++++----
 src/builtin.lisp      |  7 +++----
 src/method-impl.lisp  | 58 +++++++++++++++++++++++----------------------------
 src/method-proto.lisp | 53 +++++++++++++++++++++++++++++++++-------------
 5 files changed, 84 insertions(+), 59 deletions(-)

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index ff820f1..95604ae 100644
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -512,6 +512,7 @@ method-proto.lisp
   codegen-method                                generic
   codegen-target                                generic
   compute-effective-method-body                 generic
+  compute-effective-method-keyword-arguments    function
   compute-effective-methods                     generic
   compute-method-entry-functions                generic
   compute-sod-effective-method                  generic
@@ -541,12 +542,12 @@ method-proto.lisp
   method-entry-function-name                    generic
   method-entry-function-type                    generic
   method-entry-slot-name                        generic
-  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-message-keyword-argument-lists            generic
   sod-method-description                        generic
   sod-method-function-name                      generic
   sod-method-function-type                      generic
@@ -1318,9 +1319,6 @@ method-entry-function-type
   method-entry
 method-entry-slot-name
   method-entry
-method-keyword-argument-lists
-  effective-method t t
-  sod::initialization-effective-method t t
 module-dependencies
   module
 (setf module-dependencies)
@@ -1530,6 +1528,9 @@ sod-message-effective-method-class
   sod::teardown-message
 sod-message-kernel-function
   aggregating-message
+sod-message-keyword-argument-lists
+  sod::initialization-message sod-class t t
+  sod-message sod-class t t
 sod-message-method-class
   basic-message sod-class t
   simple-message sod-class t
diff --git a/doc/layout.tex b/doc/layout.tex
index 952cec0..ca31a9c 100644
--- a/doc/layout.tex
+++ b/doc/layout.tex
@@ -234,15 +234,23 @@
 \end{describe}
 
 \begin{describe}{gf}
-    {sod-message-effective-method-class @<message> @> @<class>}
+    {sod-message-keyword-argument-lists @<message> @<class>
+                                        @<direct-methods> @<state>
+      \nlret @<list>}
 \end{describe}
 
-\begin{describe}{gf}{primary-method-class @<message> @> @<class>}
+\begin{describe}{fun}
+    {compute-effective-method-keyword-arguments @<message>
+                                                @<class>
+                                                @<direct-methods>
+      \nlret @<list>}
 \end{describe}
 
 \begin{describe}{gf}
-    {method-keyword-argument-lists @<method> @<direct-methods> @<state>
-      @> @<list>}
+    {sod-message-effective-method-class @<message> @> @<class>}
+\end{describe}
+
+\begin{describe}{gf}{primary-method-class @<message> @> @<class>}
 \end{describe}
 
 \begin{describe}{gf}
diff --git a/src/builtin.lisp b/src/builtin.lisp
index 5897da0..776d3a1 100644
--- a/src/builtin.lisp
+++ b/src/builtin.lisp
@@ -294,8 +294,8 @@ static const SodClass *const ~A__cpl[] = {
     ((message initialization-message))
   'initialization-effective-method)
 
-(defmethod method-keyword-argument-lists
-    ((method initialization-effective-method) direct-methods state)
+(defmethod sod-message-keyword-argument-lists
+    ((message initialization-message) (class sod-class) direct-methods state)
   (append (call-next-method)
 	  (mapcan (lambda (class)
 		    (let* ((initargs (sod-class-initargs class))
@@ -317,8 +317,7 @@ static const SodClass *const ~A__cpl[] = {
 					 (report-inheritance-path
 					  state class))
 				       arglist)))))
-		  (sod-class-precedence-list
-		   (effective-method-class method)))))
+		  (sod-class-precedence-list class))))
 
 (defmethod lifecycle-method-kernel
     ((method initialization-effective-method) codegen target)
diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index e93fb3a..91c22bb 100644
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -249,29 +249,29 @@
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 
-(defmethod method-keyword-argument-lists
-    ((method effective-method) direct-methods state)
-  (with-slots (message) method
-    (and (keyword-message-p message)
-	 (cons (cons (lambda (arg)
-		       (let ((class (sod-message-class message)))
-			 (info-with-location
-			  message "Type `~A' declared in message ~
-				   definition in `~A' (here)"
-			  (argument-type arg) class)
-			 (report-inheritance-path state class)))
-		     (c-function-keywords (sod-message-type message)))
-	       (mapcar (lambda (m)
-			 (cons (lambda (arg)
-				 (let ((class (sod-method-class m)))
-				   (info-with-location
-				    m "Type `~A' declared in ~A direct ~
-				       method of `~A' (defined here)"
-				    (argument-type arg)
-				    (sod-method-description m) class)
-				   (report-inheritance-path state class)))
-			       (c-function-keywords (sod-method-type m))))
-		       direct-methods)))))
+(defmethod sod-message-keyword-argument-lists
+    ((message sod-message) (class sod-class) direct-methods state)
+  (and (keyword-message-p message)
+       (cons (cons (lambda (arg)
+		     (let ((class (sod-message-class message)))
+		       (info-with-location
+			message "Type `~A' declared in message ~
+				 definition in `~A' (here)"
+			(argument-type arg) class)
+		       (report-inheritance-path state class)))
+		   (c-function-keywords (sod-message-type message)))
+	     (mapcar (lambda (method)
+		       (cons (lambda (arg)
+			       (let ((class (sod-method-class method)))
+				 (info-with-location
+				  method "Type `~A' declared in ~A direct ~
+					  method of `~A' (defined here)"
+				  (argument-type arg)
+				  (sod-method-description method) class)
+				 (report-inheritance-path state class)))
+			     (c-function-keywords (sod-method-type method))))
+		     direct-methods))))
+
 
 (defmethod shared-initialize :after
     ((method effective-method) slot-names &key direct-methods)
@@ -282,15 +282,9 @@
   ;; class construction.
   (with-slots ((class %class) message keywords) method
     (setf keywords
-	  (merge-keyword-lists
-	   (lambda ()
-	     (values class
-		     (format nil
-			     "methods for message `~A' ~
-			      applicable to class `~A'"
-			     message class)))
-	   (method-keyword-argument-lists method direct-methods
-	    (make-inheritance-path-reporter-state class))))))
+	  (compute-effective-method-keyword-arguments message
+						      class
+						      direct-methods))))
 
 (export '(basic-effective-method
 	  effective-method-around-methods effective-method-before-methods
diff --git a/src/method-proto.lisp b/src/method-proto.lisp
index 4a624c5..1298431 100644
--- a/src/method-proto.lisp
+++ b/src/method-proto.lisp
@@ -57,6 +57,44 @@
    The list contains all methods applicable for MESSAGE when sent to an
    instance of CLASS, most specific first."))
 
+(export 'sod-message-keyword-argument-lists)
+(defgeneric sod-message-keyword-argument-lists
+    (message class direct-methods state)
+  (:documentation
+   "Returns a list of keyword argument lists to be merged.
+
+   This should return a list suitable for passing to `merge-keyword-lists',
+   i.e., each element should be a pair consisting of a function describing
+   the source of the argument list (returning location and description), and
+   a list of `argument' objects.
+
+   The MESSAGE is the message being processed; CLASS is a receiver class
+   under consideration; DIRECT-METHODS is the complete list of applicable
+   direct methods (most specific first); and STATE is an `inheritance-path-
+   reporter-state' object which can be used by the returned reporting
+   functions."))
+
+(export 'compute-effective-method-keyword-arguments)
+(defun compute-effective-method-keyword-arguments
+    (message class direct-methods)
+  "Return a merged keyword argument list.
+
+   The returned list combines all of the applicable methods, provided as
+   DIRECT-METHODS, applicable to MESSAGE when received by an instance of
+   CLASS, possibly with other keywords as determined by `sod-keyword-
+   argument-lists'."
+  (let ((state (make-inheritance-path-reporter-state class)))
+    (merge-keyword-lists (lambda ()
+			   (values class
+				   (format nil
+					   "methods for message `~A' ~
+					    applicable to class `~A'"
+					   message class)))
+			 (sod-message-keyword-argument-lists message
+							     class
+							     direct-methods
+							     state))))
+
 (export 'sod-message-effective-method-class)
 (defgeneric sod-message-effective-method-class (message)
   (:documentation
@@ -71,21 +109,6 @@
 
    This protocol is used by `simple-message' subclasses."))
 
-(export 'method-keyword-argument-lists)
-(defgeneric method-keyword-argument-lists (method direct-methods state)
-  (:documentation
-   "Returns a list of keyword argument lists to be merged.
-
-   This should return a list suitable for passing to `merge-keyword-lists',
-   i.e., each element should be a pair consisting of a function describing
-   the source of the argument list (returning location and description), and
-   a list of `argument' objects.
-
-   The METHOD is the effective method being processed; DIRECT-METHODS is the
-   complete list of applicable direct methods (most specific first); and
-   STATE is an `inheritance-path-reporter-state' object which can be used by
-   the returned reporting functions."))
-
 (export 'compute-sod-effective-method)
 (defgeneric compute-sod-effective-method (message class)
   (:documentation
-- 
2.11.0

