(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.
(let ((wanted (aggregating-message-method-return-type
message (sod-message-combination message)))
(msgtype (sod-message-type message)))
- (unless (c-type-equal-p (c-type-subtype type) wanted)
- (error "Method return type ~A doesn't match message ~A"
- (c-type-subtype msgtype) (c-type-subtype type)))
- (unless (argument-lists-compatible-p (c-function-arguments msgtype)
- (c-function-arguments type))
- (error "Method arguments ~A don't match message ~A" type msgtype))))
+ (check-method-return-type type wanted)
+ (check-method-argument-lists type msgtype)))
;;;--------------------------------------------------------------------------
;;; Utilities.
(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)))
:methods (lambda (invoke)
(funcall invoke val)
(emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val)
- (make-set-inst acc val) nil))))
+ (make-set-inst acc val)))))
(define-aggregating-method-combination :max ((acc val) :codegen codegen)
:first-method (lambda (invoke)
:methods (lambda (invoke)
(funcall invoke val)
(emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val)
- (make-set-inst acc val) nil))))
+ (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)
:methods (lambda (invoke)
(funcall invoke ret)
(emit-inst codegen (make-if-inst (format nil "!~A" ret)
- (make-break-inst) nil))))
+ (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)
(make-do-while-inst (codegen-pop-block codegen) 0)))
:methods (lambda (invoke)
(funcall invoke ret)
- (emit-inst codegen (make-if-inst ret (make-break-inst) nil))))
+ (emit-inst codegen (make-if-inst ret (make-break-inst)))))
;;;--------------------------------------------------------------------------
;;; A customizable aggregating method combination.
'(: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 --------------------------------------------------
~mdw / sod / blobdiff