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 68ece0c05753795c68ddd884cd3d5ca4b7fdf36c..f8029fd3556ab8ece51ef0395b4676c86f735ae2 100644 (file)
--- 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 45e50c3888b311f38ba02bd58c07922cb4010e18..280a21c35f57e308aac653864f0acb135ab2867f 100644 (file)
--- 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 dba6965e8b475a051f3a2fc7fd1f3fb029a95900..ed6189f982ae27e2862e054e8d9875facf02de48 100644 (file)
--- 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 ec0a11920400f20148fabccf8ca8c87d839bdb21..cec6f14cdf8d6cf5ef8b89fc3c49b26b361db4df 100644 (file)
--- 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 db1e8d66a7aa0a56545efd08bd2851dd2ae6ff6e..3857b461f5a30b5cb2f34ff7eab256070eb0df84 100644 (file)
--- 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)