(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 --------------------------------------------------