From: Mark Wooding Date: Wed, 2 Aug 2017 10:00:39 +0000 (+0100) Subject: src/method-aggregate.lisp: Allow useful behaviour if no primary methods. X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/commitdiff_plain/b07535d86a625c99240d8fdc46d589f5cc03a29c 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'. --- 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 @. 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 @@ (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 -------------------------------------------------- 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 = , 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; } @@ -170,6 +181,20 @@ class T1Sub: T1Base { 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 */ @@ -177,7 +202,7 @@ code c: tests { 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);