From b07535d86a625c99240d8fdc46d589f5cc03a29c Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 2 Aug 2017 11:00:39 +0100
Subject: [PATCH] src/method-aggregate.lisp: Allow useful behaviour if no
 primary methods.

Many aggregating combinations have obvious things to do even if they
have no primary methods; e.g., `progn' should do nothing, and
combinations based on operators with identity should return that
identity.  This actually covers all of them except `min' and `max'.
---
 doc/SYMBOLS               |   1 +
 doc/syntax.tex            |   4 ++
 src/method-aggregate.lisp | 144 +++++++++++++++++++++++++++++++---------------
 test/test.sod             |  43 +++++++++++---
 4 files changed, 138 insertions(+), 54 deletions(-)

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 0d41e6b..63f081c 100644
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -927,6 +927,7 @@ effective-method-function-name
 effective-method-keywords
   effective-method
 effective-method-live-p
+  aggregating-effective-method
   sod::lifecycle-effective-method
   simple-effective-method
 effective-method-message
diff --git a/doc/syntax.tex b/doc/syntax.tex
index 0e14e17..a1b650c 100644
--- a/doc/syntax.tex
+++ b/doc/syntax.tex
@@ -743,6 +743,10 @@ Properties for the @|custom| aggregating method combination:
 \item[@"before"] A code fragment containing initialization to be performed at
   the beginning of the effective method body.  The default is to insert
   nothing.
+\item[@"empty"] A code fragment executed if there are no primary methods;
+  it should usually store a suitable (identity) value in @<retvar>.  The
+  default is not to emit an effective method at all if there are no primary
+  methods.
 \item[@"first"] A code fragment to set the return value after calling the
   first applicable direct method.  The default is to use the @"each"
   fragment.
diff --git a/src/method-aggregate.lisp b/src/method-aggregate.lisp
index cec6f14..dcafd8d 100644
--- a/src/method-aggregate.lisp
+++ b/src/method-aggregate.lisp
@@ -106,6 +106,20 @@
 (defclass aggregating-effective-method (simple-effective-method) ()
   (:documentation "Effective method counterpart to `aggregating-message'."))
 
+(defgeneric aggregating-message-always-live-p (message combination)
+  (:documentation
+   "Return whether the method combination can work without primary methods.
+
+   Return non-nil if the corresponding effective method should be considered
+   live even if it doesn't have any methods.")
+  (:method ((message aggregating-message) (combination t)) nil))
+
+(defmethod effective-method-live-p ((method aggregating-effective-method))
+  (or (let* ((message (effective-method-message method))
+	     (comb (sod-message-combination message)))
+	(aggregating-message-always-live-p message comb))
+      (call-next-method)))
+
 ;;;--------------------------------------------------------------------------
 ;;; Implementation.
 
@@ -199,6 +213,7 @@
 	   (methods (gensym "METHODS-")))
      &key properties return-type
 	  ((:around around-func) '#'funcall)
+	  ((:empty empty-func) nil emptyp)
 	  ((:first-method first-method-func) nil firstp)
 	  ((:methods methods-func) '#'funcall))
   "Utility macro for definining aggregating method combinations.
@@ -233,6 +248,11 @@
    on `check-aggregating-message-type' to check the that the message's return
    type matches RETURN-TYPE.
 
+   If an EMPTY function is given, then (a) it's OK if there are no primary
+   methods, because (b) the EMPTY function is called to set the return
+   value variable in this case.  Note that EMPTY is only called when there
+   are no primary methods.
+
    The AROUND, FIRST-METHOD, and METHODS are function designators (probably
    `lambda' forms) providing pieces of the aggregating behaviour.
 
@@ -257,7 +277,7 @@
 
   (with-gensyms (type msg combvar target arg-names args want-type
 		 meth targ func call-methfunc
-		 aroundfunc fmethfunc methfunc)
+		 aroundfunc fmethfunc methfunc bodyfunc)
     `(progn
 
        ;; If properties are listed, arrange for them to be collected.
@@ -287,6 +307,14 @@
 			     ,combvar ,want-type)))
 		  (call-next-method))))
 
+       ;; If there is an EMPTY function then the effective method is always
+       ;; live.
+       ,@(and emptyp
+	      `((defmethod aggregating-message-always-live-p
+		    ((,msg aggregating-message)
+		     (,combvar (eql ',comb)))
+		  t)))
+
        ;; Define the main kernel-compuation method.
        (defmethod compute-aggregating-message-kernel
 	   ((,msg aggregating-message) (,combvar (eql ',comb))
@@ -298,51 +326,63 @@
 	 ;; Declare the necessary variables and give names to the functions
 	 ;; supplied by the caller.
 	 (let* (,@(and vars
-		       `((,type (c-type-subtype (sod-message-type ,msg)))))
+		       `((,type (c-type-subtype (sod-message-type ,msg)))
+			 (,(car vars) (temporary-var ,codegen ,type))))
 		,@(mapcar (lambda (var)
-			    (list var `(temporary-var ,codegen ,type)))
-			  vars)
+			    (list var `(and ,methods
+					    (temporary-var ,codegen ,type))))
+			  (cdr vars))
 		(,aroundfunc ,around-func)
 		(,methfunc ,methods-func)
 		(,fmethfunc ,(if firstp first-method-func methfunc)))
 
-	   ;; Arrange to release the temporaries when we're finished with
-	   ;; them.
-	   (unwind-protect
-		(progn
-
-		  ;; Wrap the AROUND function around most of the work.
-		  (funcall ,aroundfunc
-			   (lambda (&rest ,args)
-			     (flet ((,call-methfunc (,func ,meth)
-				      ;; Call FUNC, passing it an INVOKE
-				      ;; function which will generate a call
-				      ;; to METH.
-				      (apply ,func
-					     (lambda
-						 (&optional (,targ :void))
-					       (invoke-method ,codegen
-							      ,targ
-							      ,arg-names
-							      ,meth))
-					     ,args)))
-
-			       ;; The first method might need special
-			       ;; handling.
-			       (,call-methfunc ,fmethfunc (car ,methods))
-
-			       ;; Call the remaining methods in the right
-			       ;; order.
-			       (dolist (,meth (cdr ,methods))
-				 (,call-methfunc ,methfunc ,meth)))))
+	   (flet ((,bodyfunc ()
+		    (funcall ,aroundfunc
+			     (lambda (&rest ,args)
+			       (flet ((,call-methfunc (,func ,meth)
+					;; Call FUNC, passing it an INVOKE
+					;; function which will generate a
+					;; call to METH.
+					(apply ,func
+					       (lambda
+						   (&optional (,targ :void))
+						 (invoke-method ,codegen
+								,targ
+								,arg-names
+								,meth))
+					       ,args)))
+
+				 ;; The first method might need special
+				 ;; handling.
+				 (,call-methfunc ,fmethfunc (car ,methods))
+
+				 ;; Call the remaining methods in the right
+				 ;; order.
+				 (dolist (,meth (cdr ,methods))
+				   (,call-methfunc ,methfunc ,meth)))))))
+
+	     ;; Arrange to release the temporaries when we're finished with
+	     ;; them.
+	     (unwind-protect
+		  (progn
+
+		    ;; If there are no direct methods, then just do the
+		    ;; empty-effective-method thing to set the return
+		    ;; variable.  Otherwise, wrap AROUND round the main body.
+		    ,(if emptyp
+			 `(if (null ,methods)
+			      (funcall ,empty-func)
+			      (,bodyfunc))
+			 `(,bodyfunc))
 
 		  ;; Outside the AROUND function now, deliver the final
 		  ;; result to the right place.
 		  (deliver-expr ,codegen ,target ,(car vars)))
 
-	     ;; Finally, release the temporary variables.
-	     ,@(mapcar (lambda (var) `(setf (var-in-use-p ,var) nil))
-		       vars))))
+	       ;; Finally, release the temporary variables.
+	       ,@(mapcar (lambda (var)
+			   `(when ,var (setf (var-in-use-p ,var) nil)))
+			 vars)))))
 
        ',comb)))
 
@@ -350,9 +390,11 @@
 ;;; Fixed aggregating method combinations.
 
 (define-aggregating-method-combination :progn (nil)
-  :return-type void)
+  :return-type void
+  :empty (lambda () nil))
 
 (define-aggregating-method-combination :sum ((acc val) :codegen codegen)
+  :empty (lambda () (emit-inst codegen (make-set-inst acc 0)))
   :first-method (lambda (invoke)
 		  (funcall invoke val)
 		  (emit-inst codegen (make-set-inst acc val)))
@@ -361,6 +403,7 @@
 	     (emit-inst codegen (make-update-inst acc #\+ val))))
 
 (define-aggregating-method-combination :product ((acc val) :codegen codegen)
+  :empty (lambda () (emit-inst codegen (make-set-inst acc 1)))
   :first-method (lambda (invoke)
 		  (funcall invoke val)
 		  (emit-inst codegen (make-set-inst acc val)))
@@ -387,6 +430,7 @@
 					      (make-set-inst acc val)))))
 
 (define-aggregating-method-combination :and ((ret) :codegen codegen)
+  :empty (lambda () (emit-inst codegen (make-set-inst ret 1)))
   :around (lambda (body)
 	    (codegen-push codegen)
 	    (funcall body)
@@ -398,6 +442,7 @@
 					      (make-break-inst)))))
 
 (define-aggregating-method-combination :or ((ret) :codegen codegen)
+  :empty (lambda () (emit-inst codegen (make-set-inst ret 0)))
   :around (lambda (body)
 	    (codegen-push codegen)
 	    (funcall body)
@@ -415,6 +460,7 @@
   '(:retvar :id
     :valvar :id
     :methty :type
+    :empty :fragment
     :decls :fragment
     :before :fragment
     :first :fragment
@@ -427,20 +473,25 @@
   (getf (sod-message-plist message) :methty
 	(c-type-subtype (sod-message-type message))))
 
+(defmethod aggregating-message-always-live-p
+    ((message aggregating-message) (combination (eql :custom)))
+  (getf (sod-message-plist message) :empty))
+
 (defmethod compute-aggregating-message-kernel
     ((message aggregating-message) (combination (eql :custom))
      codegen target methods arg-names
      &key (retvar "sod_ret") (valvar "sod_val") (methty nil methtyp)
-	  decls before each (first each) after count)
+	  empty decls before each (first each) after count)
   (let* ((type (c-type-subtype (sod-message-type message)))
 	 (methty (if methtyp methty type)))
     (unless (eq type c-type-void)
       (ensure-var codegen retvar type))
-    (unless (eq methty c-type-void)
+    (unless (or (null methods)
+		(eq methty c-type-void))
       (ensure-var codegen valvar methty))
-    (when count
+    (when (and methods count)
       (ensure-var codegen count c-type-size-t (length methods)))
-    (when decls
+    (when (and methods decls)
       (emit-decl codegen decls))
     (labels ((maybe-emit (fragment)
 	       (when fragment (emit-inst codegen fragment)))
@@ -449,10 +500,13 @@
 			      (if (eq methty c-type-void) :void valvar)
 			      arg-names method)
 	       (maybe-emit fragment)))
-      (maybe-emit before)
-      (invoke (car methods) first)
-      (dolist (method (cdr methods)) (invoke method each))
-      (maybe-emit after)
+      (cond ((and empty (null methods))
+	     (emit-inst codegen empty))
+	    (t
+	     (maybe-emit before)
+	     (invoke (car methods) first)
+	     (dolist (method (cdr methods)) (invoke method each))
+	     (maybe-emit after)))
       (deliver-expr codegen target retvar))))
 
 ;;;----- That's all, folks --------------------------------------------------
diff --git a/test/test.sod b/test/test.sod
index 192f631..f794c76 100644
--- a/test/test.sod
+++ b/test/test.sod
@@ -137,28 +137,39 @@ static int check_vec(struct vec *v, ...)
 
 [link = SodObject, nick = t1base]
 class T1Base: SodObject {
-  [combination = progn] void aprogn() { STEP(1); }
-  [combination = sum] int asum() { return 1; }
-  [combination = and] int aand() { return 8; }
-  [combination = max] int amax() { return 12; }
+  [combination = progn] void aprogn();
+  [combination = sum] int asum();
+  [combination = and] int aand();
+  [combination = max] int amax();
 
   [combination = custom,
+   empty = { sod_ret = 0; },
    decls = { struct item **head = &sod_ret; },
    each = { *head = sod_val; head = &sod_val->next; },
    after = { *head = 0; }]
-  struct item *alist() { return make_item("base"); }
+  struct item *alist();
 
   [combination = custom,
    decls = { int *v; size_t i = 0; }, methty = <int>, count = n,
+   empty = { sod_ret.v = 0; sod_ret.n = 0; },
    before = { v = xmalloc(n*sizeof(int)); },
    each = { v[i++] = sod_val; },
    after = { sod_ret.v = v; sod_ret.n = n; }]
   struct vec avec();
+}
+
+[link = T1Base, nick = t1mid]
+class T1Mid: T1Base {
+  void t1base.aprogn() { STEP(1); }
+  int t1base.asum() { return 1; }
+  int t1base.aand() { return 8; }
+  int t1base.amax() { return 12; }
+  struct item *t1base.alist() { return make_item("mid"); }
   int t1base.avec() { return 19; }
 }
 
-[link = T1Base, nick = t1sub]
-class T1Sub: T1Base {
+[link = T1Mid, nick = t1sub]
+class T1Sub: T1Mid {
   void t1base.aprogn() { STEP(0); }
   int t1base.asum() { return 2; }
   int t1base.aand() { return 6; }
@@ -172,12 +183,26 @@ code c: tests {
   { SOD_DECL(T1Base, t1, NO_KWARGS);
     struct item *l;
     struct vec v;
+    STEP(0); T1Base_aprogn(t1); STEP(1);
+    if (T1Base_asum(t1) == 0) STEP(2);
+    if (T1Base_aand(t1) == 1) STEP(3);
+    if (!t1->_vt->t1base.amax) STEP(4);
+    l = T1Base_alist(t1);
+    if (!l) STEP(5);
+    v = T1Base_avec(t1);
+    if (!v.n) STEP(6);
+    DONE(7);
+  }
+  prepare("aggregate, mid");
+  { SOD_DECL(T1Mid, t1, NO_KWARGS);
+    struct item *l;
+    struct vec v;
     STEP(0); T1Base_aprogn(t1); /* 1 */
     if (T1Base_asum(t1) == 1) STEP(2);
     if (T1Base_aand(t1) == 8) STEP(3);
     if (T1Base_amax(t1) == 12) STEP(4);
     l = T1Base_alist(t1);
-    if (!check_list(l, "base", (const char *)0)) STEP(5);
+    if (!check_list(l, "mid", (const char *)0)) STEP(5);
     free_list(l);
     v = T1Base_avec(t1);
     if (!check_vec(&v, 19, -1)) STEP(6);
@@ -193,7 +218,7 @@ code c: tests {
     if (T1Base_aand(t1) == 8) STEP(3);
     if (T1Base_amax(t1) == 17) STEP(4);
     l = T1Base_alist(t1);
-    if (!check_list(l, "sub", "base", (const char *)0)) STEP(5);
+    if (!check_list(l, "sub", "mid", (const char *)0)) STEP(5);
     free_list(l);
     v = T1Base_avec(t1);
     if (!check_vec(&v, 4, 19, -1)) STEP(6);
-- 
2.11.0

