src/frontend.lisp: Report an error if no output types are requested.

[sod] / src / method-aggregate.lisp

diff --git a/src/method-aggregate.lisp b/src/method-aggregate.lisp
index 1332e1075e44602bf8d785c6e4b4fc0c802a649c..bd8fe8ad40d1596a66f0ba944f0f0c0f8f36b5ed 100644 (file)
--- a/src/method-aggregate.lisp
+++ b/src/method-aggregate.lisp
@@ -28,11 +28,12 @@ (cl:in-package #:sod)
 ;;;--------------------------------------------------------------------------
 ;;; Classes and protocol.
 
-(export 'aggregating-message)
+(export '(aggregating-message
+         sod-message-combination sod-message-kernel-function))
 (defclass aggregating-message (simple-message)
   ((combination :initarg :combination :type keyword
-               :reader message-combination)
-   (kernel-function :type function :reader message-kernel-function))
+               :reader sod-message-combination)
+   (kernel-function :type function :reader sod-message-kernel-function))
   (:documentation
    "Message class for aggregating method combinations.
 
@@ -105,14 +106,14 @@ (defmethod check-message-type ((message aggregating-message) type)
   (with-slots (combination) message
     (check-aggregating-message-type message combination type)))
 
-(defmethod message-effective-method-class ((message aggregating-message))
+(defmethod sod-message-effective-method-class ((message aggregating-message))
   'aggregating-effective-method)
 
 (defmethod simple-method-body
     ((method aggregating-effective-method) codegen target)
   (let ((argument-names (effective-method-basic-argument-names method))
        (primary-methods (effective-method-primary-methods method)))
-    (funcall (message-kernel-function (effective-method-message method))
+    (funcall (sod-message-kernel-function (effective-method-message method))
             codegen target argument-names primary-methods)))
 
 (defmethod shared-initialize :before
@@ -179,7 +180,7 @@ (defmacro define-aggregating-method-combination
      (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 +212,10 @@ (defmacro define-aggregating-method-combination
    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 +238,7 @@ (defmacro define-aggregating-method-combination
    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 +256,20 @@ (defmacro define-aggregating-method-combination
                                    (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 +332,8 @@        (defmethod compute-aggregating-message-kernel
 ;;;--------------------------------------------------------------------------
 ;;; 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 +370,7 @@ (define-aggregating-method-combination :max ((acc val) :codegen codegen)
                                              (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 +384,7 @@ (define-aggregating-method-combination :and ((ret val) :codegen codegen)
                                              (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)
@@ -408,18 +407,21 @@ (defmethod aggregating-message-properties
     :before :fragment
     :first :fragment
     :each :fragment
-    :after :fragment))
+    :after :fragment
+    :count :id))
 
 (defmethod compute-aggregating-message-kernel
     ((message aggregating-message) (combination (eql :custom))
      codegen target methods arg-names
      &key (retvar "sod_ret") (valvar "sod_val")
-         decls before each (first each) after)
+         decls before each (first each) after count)
   (let* ((type (c-type-subtype (sod-message-type message)))
         (not-void-p (not (eq type c-type-void))))
     (when not-void-p
       (ensure-var codegen retvar type)
       (ensure-var codegen valvar type))
+    (when count
+      (ensure-var codegen count c-type-int (length methods)))
     (when decls
       (emit-decl codegen decls))
     (labels ((maybe-emit (fragment)