chiark / gitweb /
src/method-aggregate.lisp: Allow useful behaviour if no primary methods.
[sod] / src / method-aggregate.lisp
index cec6f14cdf8d6cf5ef8b89fc3c49b26b361db4df..dcafd8d17d29fddecc5b642179f21787314e4b72 100644 (file)
@@ -106,6 +106,20 @@ (export 'aggregating-effective-method)
 (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 @@ (defmacro define-aggregating-method-combination
           (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 @@ (defmacro define-aggregating-method-combination
    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 @@ (defmacro define-aggregating-method-combination
 
   (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 @@ (defmacro define-aggregating-method-combination
                             ,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 @@        (defmethod compute-aggregating-message-kernel
         ;; 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 @@        (defmethod compute-aggregating-message-kernel
 ;;; 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 @@ (define-aggregating-method-combination :sum ((acc val) :codegen codegen)
             (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 @@ (define-aggregating-method-combination :max ((acc val) :codegen codegen)
                                              (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 @@ (define-aggregating-method-combination :and ((ret) :codegen codegen)
                                              (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 @@ (defmethod aggregating-message-properties
   '(:retvar :id
     :valvar :id
     :methty :type
+    :empty :fragment
     :decls :fragment
     :before :fragment
     :first :fragment
@@ -427,20 +473,25 @@ (defmethod aggregating-message-method-return-type
   (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 @@ (defmethod compute-aggregating-message-kernel
                              (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 --------------------------------------------------