--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Aggregating method combinations
+;;;
+;;; (c) 2015 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Classes and protocol.
+
+(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'."))
+
+(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))
+
+(export 'standard-effective-method)
+(defclass aggregating-effective-method (simple-effective-method) ()
+ (:documentation "Effective method counterpart to `aggregating-message'."))
+
+;;;--------------------------------------------------------------------------
+;;; Implementation.
+
+(defmethod check-message-type ((message aggregating-message) type)
+ (with-slots (combination) message
+ (check-aggregating-message-type message combination type)))
+
+(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)))
+
+(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)))))))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(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)))
+
+;;;--------------------------------------------------------------------------
+;;; Fixed aggregating method combinations.
+
+(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)))
+
+(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))))
+
+;;;--------------------------------------------------------------------------
+;;; A customizable aggregating method combination.
+
+(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))))
+
+;;;----- That's all, folks --------------------------------------------------
(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