From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 16 Dec 2015 02:18:38 +0000 (+0000)
Subject: src/: Factor out common machinery in `check-method-type' methods.
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/commitdiff_plain/b70cb6d8704405cbb9281f823390f561c03de70c?hp=3aab0efa423fe20713c8cc02e8aabdf7fe84056b

src/: Factor out common machinery in `check-method-type' methods.

The checking logic and error messages were partially duplicated in the
various methods.  Clean this mess up because that's just bad form (and
because it's about to change).

This also clears up a minor bug in the method on `aggregating-message',
which used to report a confusing error message if the method return type
wasn't what it was expecting.
---

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 68ece0c..f8029fd 100644
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -244,6 +244,11 @@ class-layout-proto.lisp
   vtmsgs-entries                                generic
   vtmsgs-subclass                               generic
 
+class-make-impl.lisp
+  check-method-argument-lists                   function
+  check-method-return-type                      function
+  check-method-return-type-against-message      function
+
 class-make-proto.lisp
   check-message-type                            generic
   check-method-type                             generic
diff --git a/doc/meta.tex b/doc/meta.tex
index 45e50c3..280a21c 100644
--- a/doc/meta.tex
+++ b/doc/meta.tex
@@ -221,6 +221,17 @@
       @> @<generalized-boolean>}
 \end{describe}
 
+\begin{describe}{fun}{check-method-return-type @<method-type> @<return-type>}
+\end{describe}
+
+\begin{describe}{fun}
+    {check-method-return-type-against-message @<method-type> @<message-type>}
+\end{describe}
+
+\begin{describe}{fun}
+    {check-method-argument-lists @<method-type> @<message-type>}
+\end{describe}
+
 %%%--------------------------------------------------------------------------
 \section{Class finalization protocol} \label{sec:meta.finalization}
 
diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp
index dba6965..ed6189f 100644
--- a/src/class-make-impl.lisp
+++ b/src/class-make-impl.lisp
@@ -221,15 +221,38 @@ (defmethod check-method-type
     ((method sod-method) (message sod-message) (type c-type))
   (error "Methods must have function type, not ~A" type))
 
+(export 'check-method-return-type)
+(defun check-method-return-type (method-type wanted-type)
+  "Signal an error unless METHOD-TYPE does not return the WANTED-TYPE."
+  (let ((method-returns (c-type-subtype method-type)))
+    (unless (c-type-equal-p method-returns wanted-type)
+      (error "Method return type ~A should be ~A"
+	     method-returns wanted-type))))
+
+(export 'check-method-return-type-against-message)
+(defun check-method-return-type-against-message (method-type message-type)
+  "Signal an error unless METHOD-TYPE and MESSAGE-TYPE return the same type."
+  (let ((message-returns (c-type-subtype message-type))
+	(method-returns (c-type-subtype method-type)))
+    (unless (c-type-equal-p message-returns method-returns)
+      (error "Method return type ~A doesn't match message ~A"
+	     method-returns message-returns))))
+
+(export 'check-method-argument-lists)
+(defun check-method-argument-lists (method-type message-type)
+  "Signal an error unless METHOD-TYPE and MESSAGE-TYPE have matching argument
+   lists.
+
+  This checks that the two types have matching lists of arguments."
+  (unless (argument-lists-compatible-p (c-function-arguments message-type)
+				       (c-function-arguments method-type))
+    (error "Method arguments ~A don't match message ~A"
+	   method-type message-type)))
+
 (defmethod check-method-type
     ((method sod-method) (message sod-message) (type c-function-type))
   (with-slots ((msgtype %type)) message
-    (unless (c-type-equal-p (c-type-subtype msgtype)
-			    (c-type-subtype type))
-      (error "Method return type ~A doesn't match message ~A"
-	      (c-type-subtype msgtype) (c-type-subtype type)))
-    (unless (argument-lists-compatible-p (c-function-arguments msgtype)
-					 (c-function-arguments type))
-      (error "Method arguments ~A don't match message ~A" type msgtype))))
+    (check-method-return-type-against-message type msgtype)
+    (check-method-argument-lists type msgtype)))
 
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/src/method-aggregate.lisp b/src/method-aggregate.lisp
index ec0a119..cec6f14 100644
--- a/src/method-aggregate.lisp
+++ b/src/method-aggregate.lisp
@@ -185,12 +185,8 @@ (defmethod check-method-type
   (let ((wanted (aggregating-message-method-return-type
 		 message (sod-message-combination message)))
 	(msgtype (sod-message-type message)))
-    (unless (c-type-equal-p (c-type-subtype type) wanted)
-      (error "Method return type ~A doesn't match message ~A"
-	      (c-type-subtype msgtype) (c-type-subtype type)))
-    (unless (argument-lists-compatible-p (c-function-arguments msgtype)
-					 (c-function-arguments type))
-      (error "Method arguments ~A don't match message ~A" type msgtype))))
+    (check-method-return-type type wanted)
+    (check-method-argument-lists type msgtype)))
 
 ;;;--------------------------------------------------------------------------
 ;;; Utilities.
diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index db1e8d6..3857b46 100644
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -147,11 +147,8 @@ (defmethod check-method-type ((method daemon-direct-method)
 			      (message sod-message)
 			      (type c-function-type))
   (with-slots ((msgtype %type)) message
-    (unless (c-type-equal-p (c-type-subtype type) c-type-void)
-      (error "Method return type ~A must be `void'" (c-type-subtype type)))
-    (unless (argument-lists-compatible-p (c-function-arguments msgtype)
-					 (c-function-arguments type))
-      (error "Method arguments ~A don't match message ~A" type msgtype))))
+    (check-method-return-type type c-type-void)
+    (check-method-argument-lists type msgtype)))
 
 (export 'delegating-direct-method)
 (defclass delegating-direct-method (basic-direct-method)