(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.
(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.
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.
(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.
,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))
;; 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)))
;;; 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)))
(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)))
(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)
(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)
'(:retvar :id
:valvar :id
:methty :type
+ :empty :fragment
:decls :fragment
:before :fragment
:first :fragment
(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)))
(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 --------------------------------------------------
[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; }
code c: tests {
prepare("aggregate, base");
{ 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_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);
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);
~mdw / sod / commitdiff