(effective-method-primary-methods method)
nil))
+;;;--------------------------------------------------------------------------
+;;; Aggregate method combinations.
+
+(export 'aggregating-message)
+(defclass aggregating-message (simple-message)
+ ((combination :initarg :combination :type keyword
+ :reader message-combination)
+ (kernel-function :type function :reader message-kernel-function))
+ (:documentation
+ "Message class for aggregating method combinations.
+
+ An aggregating method combination invokes the primary methods in order,
+ most-specific first, collecting their return values, and combining them
+ together in some way to produce a result for the effective method as a
+ whole.
+
+ Mostly, this is done by initializing an accumulator to some appropriate
+ value, updating it with the result of each primary method in turn, and
+ finally returning some appropriate output function of it. The order is
+ determined by the `:most-specific' property, which may have the value
+ `:first' or `:last'.
+
+ The `progn' method combination is implemented as a slightly weird special
+ case of an aggregating method combination with a trivial state. More
+ typical combinations are `:sum', `:product', `:min', `:max', `:and', and
+ `:or'. Finally, there's a `custom' combination which uses user-supplied
+ code fragments to stitch everything together."))
+
+(export 'aggregating-message-properties)
+(defgeneric aggregating-message-properties (message combination)
+ (:documentation
+ "Return a description of the properties needed by the method COMBINATION.
+
+ The description should be a plist of alternating property name and type
+ keywords. The named properties will be looked up in the pset supplied at
+ initialization time, and supplied to `compute-aggregating-message-kernel'
+ as keyword arguments. Defaults can be supplied in method BVLs.
+
+ The default is not to capture any property values.
+
+ The reason for this is as not to retain the pset beyond message object
+ initialization.")
+ (:method (message combination) nil))
+
+(export 'compute-aggregating-message-kernel)
+(defgeneric compute-aggregating-message-kernel
+ (message combination codegen target methods arg-names &key)
+ (:documentation
+ "Determine how to aggregate the direct methods for an aggregating message.
+
+ The return value is a function taking arguments (CODEGEN TARGET ARG-NAMES
+ METHODS): it should emit, to CODEGEN, an appropriate effective-method
+ kernel which invokes the listed direct METHODS, in the appropriate order,
+ collects and aggregates their values, and delivers to TARGET the final
+ result of the method kernel.
+
+ The easy way to implement this method is to use the macro
+ `define-aggregating-method-combination'."))
+
+(defmethod shared-initialize :before
+ ((message aggregating-message) slot-names &key pset)
+ (declare (ignore slot-names))
+ (with-slots (combination kernel-function) message
+ (let ((most-specific (get-property pset :most-specific :keyword :first))
+ (comb (get-property pset :combination :keyword)))
+
+ ;; Check that we've been given a method combination and make sure it
+ ;; actually exists.
+ (unless comb
+ (error "The `combination' property is required."))
+ (unless (some (lambda (method)
+ (let* ((specs (method-specializers method))
+ (message-spec (car specs))
+ (combination-spec (cadr specs)))
+ (and (typep message-spec 'class)
+ (typep message message-spec)
+ (typep combination-spec 'eql-specializer)
+ (eq (eql-specializer-object combination-spec)
+ comb))))
+ (generic-function-methods
+ #'compute-aggregating-message-kernel))
+ (error "Unknown method combination `~(~A~)'." comb))
+ (setf combination comb)
+
+ ;; Make sure the ordering is actually valid.
+ (unless (member most-specific '(:first :last))
+ (error "The `most_specific' property must be `first' or `last'."))
+
+ ;; Set up the function which will compute the kernel.
+ (let ((magic (cons nil nil))
+ (keys nil))
+
+ ;; Collect the property values wanted by the method combination.
+ (do ((want (aggregating-message-properties message comb)
+ (cddr want)))
+ ((endp want))
+ (let* ((name (car want))
+ (type (cadr want))
+ (prop (get-property pset name type magic)))
+ (unless (eq prop magic)
+ (setf keys (list* name prop keys)))))
+
+ ;; Set the kernel function for later.
+ (setf kernel-function
+ (lambda (codegen target arg-names methods)
+ (apply #'compute-aggregating-message-kernel
+ message comb
+ codegen target
+ (ecase most-specific
+ (:first methods)
+ (:last (setf methods (reverse methods))))
+ arg-names
+ keys)))))))
+
+(export 'check-aggregating-message-type)
+(defgeneric check-aggregating-message-type (message combination type)
+ (:documentation
+ "Check that TYPE is an acceptable function TYPE for the COMBINATION.
+
+ For example, `progn' messages must return `void', while `and' and `or'
+ messages must return `int'.")
+ (:method (message combination type)
+ t))
+
+(defmethod check-message-type ((message aggregating-message) type)
+ (with-slots (combination) message
+ (check-aggregating-message-type message combination type)))
+
+(flet ((check (comb want type)
+ (unless (eq (c-type-subtype type) want)
+ (error "Messages with `~A' combination must return `~A'."
+ (string-downcase comb) want))))
+ (defmethod check-aggregating-message-type
+ ((message aggregating-message)
+ (combination (eql :progn))
+ (type c-function-type))
+ (check combination c-type-void type)
+ (call-next-method))
+ (defmethod check-aggregating-message-type
+ ((message aggregating-message)
+ (combination (eql :and))
+ (type c-function-type))
+ (check combination c-type-int type)
+ (call-next-method))
+ (defmethod check-aggregating-message-type
+ ((message aggregating-message)
+ (combination (eql :or))
+ (type c-function-type))
+ (check combination c-type-int type)
+ (call-next-method)))
+
+(export 'define-aggregating-method-combination)
+(defmacro define-aggregating-method-combination
+ (comb
+ (vars
+ &key (codegen (gensym "CODEGEN-"))
+ (methods (gensym "METHODS-")))
+ &key properties
+ ((:around around-func) '#'funcall)
+ ((:first-method first-method-func) nil firstp)
+ ((:methods methods-func) '#'funcall))
+ "Utility macro for definining aggregating method combinations.
+
+ The VARS are a list of variable names to be bound to temporary variable
+ objects of the method's return type. Additional keyword arguments define
+ variables names to be bound to other possibly interesting values:
+
+ * CODEGEN is the `codegen' object passed at effective-method computation
+ time; and
+
+ * METHODS is the list of primary methods, in the order in which they
+ should be invoked. Note that this list must be non-empty, since
+ otherwise the method on `compute-effective-method-body' specialized to
+ `simple-effective-method' will suppress the method entirely.
+
+ The PROPERTIES, if specified, are a list of properties to be collected
+ during message-object initialization; items in the list have the form
+
+ (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP])
+
+ similar to a `&key' BVL entry, except for the additional TYPE entry. In
+ particular, a symbolic NAME may be written in place of a singleton list.
+ The KEYWORD names the property as it should be looked up in the pset,
+ while the NAME names a variable to which the property value or default is
+ bound.
+
+ All of these variables, and the VARS, are available in the functions
+ described below.
+
+ The AROUND, FIRST-METHOD, and METHODS are function designators (probably
+ `lambda' forms) providing pieces of the aggregating behaviour.
+
+ The AROUND function is called first, with a single argument BODY, though
+ the variables above are also in scope. It is expected to emit code to
+ CODEGEN which invokes the METHODS in the appropriate order, and arranges
+ to store the aggregated return value in the first of the VARS.
+
+ It may call BODY as a function in order to assist with this; let ARGS be
+ the list of arguments supplied to it. The default behaviour is to call
+ BODY with no arguments. The BODY function first calls FIRST-METHOD,
+ passing it as arguments a function INVOKE and the ARGS which were passed
+ to BODY, and then calls METHODS once for each remaining method, again
+ passing an INVOKE function and the ARGS. If FIRST-METHOD is not
+ specified, then the METHODS function is used for all of the methods. If
+ METHODS is not specified, then the behaviour is simply to call INVOKE
+ immediately. (See the definition of the `:progn' method combination.)
+
+ Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call
+ the appropriate direct method and deliver its return value to TARGET,
+ which defaults to `:void'."
+
+ (with-gensyms (type msg combvar target arg-names args
+ meth targ func call-methfunc
+ aroundfunc fmethfunc methfunc)
+ `(progn
+
+ ;; If properties are listed, arrange for them to be collected.
+ ,@(and properties
+ `((defmethod aggregating-message-properties
+ ((,msg aggregating-message) (,combvar (eql ',comb)))
+ ',(mapcan (lambda (prop)
+ (list (let* ((name (car prop))
+ (names (if (listp name) name
+ (list name))))
+ (if (cddr names) (car names)
+ (intern (car names) :keyword)))
+ (cadr prop)))
+ properties))))
+
+ ;; Define the main kernel-compuation method.
+ (defmethod compute-aggregating-message-kernel
+ ((,msg aggregating-message) (,combvar (eql ',comb))
+ ,codegen ,target ,methods ,arg-names
+ &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop)))
+ properties))
+ (declare (ignore ,combvar))
+
+ ;; 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)))))
+ ,@(mapcar (lambda (var)
+ (list var `(temporary-var ,codegen ,type)))
+ 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)))))
+
+ ;; 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))))
+
+ ',comb)))
+
+(define-aggregating-method-combination :progn (nil))
+
+(define-aggregating-method-combination :sum ((acc val) :codegen codegen)
+ :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-update-inst acc #\+ val))))
+
+(define-aggregating-method-combination :product ((acc val) :codegen codegen)
+ :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-update-inst acc #\* val))))
+
+(define-aggregating-method-combination :min ((acc val) :codegen codegen)
+ :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))))
+
+(define-aggregating-method-combination :max ((acc val) :codegen codegen)
+ :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))))
+
+(define-aggregating-method-combination :and ((ret val) :codegen codegen)
+ :around (lambda (body)
+ (codegen-push codegen)
+ (deliver-expr codegen ret 0)
+ (funcall body)
+ (deliver-expr codegen ret 1)
+ (emit-inst codegen
+ (make-do-while-inst (codegen-pop-block codegen) 0)))
+ :methods (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-if-inst (format nil "!~A" val)
+ (make-break-inst) nil))))
+
+(define-aggregating-method-combination :or ((ret val) :codegen codegen)
+ :around (lambda (body)
+ (codegen-push codegen)
+ (deliver-expr codegen ret 1)
+ (funcall body)
+ (deliver-expr codegen ret 0)
+ (emit-inst codegen
+ (make-do-while-inst (codegen-pop-block codegen) 0)))
+ :methods (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-if-inst val (make-break-inst) nil))))
+
+(defmethod aggregating-message-properties
+ ((message aggregating-message) (combination (eql :custom)))
+ '(:retvar :id
+ :valvar :id
+ :decls :fragment
+ :before :fragment
+ :first :fragment
+ :each :fragment
+ :after :fragment))
+
+(defmethod compute-aggregating-message-kernel
+ ((message aggregating-message) (combination (eql :custom))
+ codegen target methods arg-names
+ &key (retvar "sod_ret") (valvar "sod_val")
+ decls before each (first each) after)
+ (let* ((type (c-type-subtype (sod-message-type message)))
+ (not-void-p (not (eq type c-type-void))))
+ (when not-void-p
+ (ensure-var codegen retvar type)
+ (ensure-var codegen valvar type))
+ (when decls
+ (emit-decl codegen decls))
+ (labels ((maybe-emit (fragment)
+ (when fragment (emit-inst codegen fragment)))
+ (invoke (method fragment)
+ (invoke-method codegen (if not-void-p valvar :void)
+ arg-names method)
+ (maybe-emit fragment)))
+ (maybe-emit before)
+ (invoke (car methods) first)
+ (dolist (method (cdr methods)) (invoke method each))
+ (maybe-emit after)
+ (deliver-expr codegen target retvar))))
+
+(export 'standard-effective-method)
+(defclass aggregating-effective-method (simple-effective-method) ()
+ (:documentation "Effective method counterpart to `aggregating-message'."))
+
+(defmethod message-effective-method-class ((message aggregating-message))
+ 'aggregating-effective-method)
+
+(defmethod simple-method-body
+ ((method aggregating-effective-method) codegen target)
+ (let ((argument-names (effective-method-basic-argument-names method))
+ (primary-methods (effective-method-primary-methods method)))
+ (funcall (message-kernel-function (effective-method-message method))
+ codegen target argument-names primary-methods)))
+
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / commitdiff