From: Mark Wooding <mdw@distorted.org.uk>
Date: Sun, 30 Aug 2015 09:58:38 +0000 (+0100)
Subject: src/method-aggregate.lisp: Move return-type check into `define-' macro.
X-Git-Tag: 0.2.0~33
X-Git-Url: https://git.distorted.org.uk/~mdw/sod/commitdiff_plain/7b78999c5e8c9e3f06f6ad565dbafcb676747249?ds=sidebyside

src/method-aggregate.lisp: Move return-type check into `define-' macro.

It seems a better fit this way.
---

diff --git a/src/method-aggregate.lisp b/src/method-aggregate.lisp
index 1332e10..9d0a6dd 100644
--- a/src/method-aggregate.lisp
+++ b/src/method-aggregate.lisp
@@ -179,7 +179,7 @@
      (vars
       &key (codegen (gensym "CODEGEN-"))
 	   (methods (gensym "METHODS-")))
-     &key properties
+     &key properties return-type
 	  ((:around around-func) '#'funcall)
 	  ((:first-method first-method-func) nil firstp)
 	  ((:methods methods-func) '#'funcall))
@@ -211,6 +211,10 @@
    All of these variables, and the VARS, are available in the functions
    described below.
 
+   If a RETURN-TYPE is given, it's a C-type S-expression: a method is defined
+   on `check-aggregating-message-type' to check the that the message's return
+   type matches RETURN-TYPE.
+
    The AROUND, FIRST-METHOD, and METHODS are function designators (probably
    `lambda' forms) providing pieces of the aggregating behaviour.
 
@@ -233,7 +237,7 @@
    the appropriate direct method and deliver its return value to TARGET,
    which defaults to `:void'."
 
-  (with-gensyms (type msg combvar target arg-names args
+  (with-gensyms (type msg combvar target arg-names args want-type
 		 meth targ func call-methfunc
 		 aroundfunc fmethfunc methfunc)
     `(progn
@@ -251,6 +255,20 @@
 				    (cadr prop)))
 			    properties))))
 
+       ;; If a particular return type is wanted, check that.
+       ,@(and return-type
+	      `((defmethod check-aggregating-message-type
+		    ((,msg aggregating-message)
+		     (,combvar (eql ',comb))
+		     (,type c-function-type))
+		  (let ((,want-type (c-type ,return-type)))
+		    (unless (c-type-equal-p (c-type-subtype ,type)
+					    ,want-type)
+		      (error "Messages with `~(~A~)' combination ~
+			      must return `~A'."
+			     ,combvar ,want-type)))
+		  (call-next-method))))
+
        ;; Define the main kernel-compuation method.
        (defmethod compute-aggregating-message-kernel
 	   ((,msg aggregating-message) (,combvar (eql ',comb))
@@ -313,30 +331,8 @@
 ;;;--------------------------------------------------------------------------
 ;;; Fixed aggregating method combinations.
 
-(flet ((check (comb want type)
-	 (unless (eq (c-type-subtype type) want)
-	   (error "Messages with `~A' combination must return `~A'."
-		  (string-downcase comb) want))))
-  (defmethod check-aggregating-message-type
-      ((message aggregating-message)
-       (combination (eql :progn))
-       (type c-function-type))
-    (check combination c-type-void type)
-    (call-next-method))
-  (defmethod check-aggregating-message-type
-      ((message aggregating-message)
-       (combination (eql :and))
-       (type c-function-type))
-    (check combination c-type-int type)
-    (call-next-method))
-  (defmethod check-aggregating-message-type
-      ((message aggregating-message)
-       (combination (eql :or))
-       (type c-function-type))
-    (check combination c-type-int type)
-    (call-next-method)))
-
-(define-aggregating-method-combination :progn (nil))
+(define-aggregating-method-combination :progn (nil)
+  :return-type void)
 
 (define-aggregating-method-combination :sum ((acc val) :codegen codegen)
   :first-method (lambda (invoke)
@@ -373,6 +369,7 @@
 					      (make-set-inst acc val) nil))))
 
 (define-aggregating-method-combination :and ((ret val) :codegen codegen)
+  :return-type int
   :around (lambda (body)
 	    (codegen-push codegen)
 	    (deliver-expr codegen ret 0)
@@ -386,6 +383,7 @@
 					      (make-break-inst) nil))))
 
 (define-aggregating-method-combination :or ((ret val) :codegen codegen)
+  :return-type int
   :around (lambda (body)
 	    (codegen-push codegen)
 	    (deliver-expr codegen ret 1)