From e75eb63d81df077c02c6c74439fb14a34d4fb93e Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 30 Aug 2015 10:58:38 +0100 Subject: [PATCH] src/method-aggregate.lisp: Give aggregating combinations their own file. The code has been reordered a little too, but there are no substantive changes. --- src/Makefile.am | 1 + src/method-aggregate.lisp | 437 ++++++++++++++++++++++++++++++++++++++++++++++ src/method-impl.lisp | 397 ----------------------------------------- src/sod.asd | 1 + 4 files changed, 439 insertions(+), 397 deletions(-) create mode 100644 src/method-aggregate.lisp diff --git a/src/Makefile.am b/src/Makefile.am index fd70ab3..20878a5 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -82,6 +82,7 @@ dist_pkglispsrc_DATA += class-output.lisp ## Method generation. dist_pkglispsrc_DATA += method-proto.lisp method-impl.lisp +dist_pkglispsrc_DATA += method-aggregate.lisp ## User interface. dist_pkglispsrc_DATA += sod-frontend.asd diff --git a/src/method-aggregate.lisp b/src/method-aggregate.lisp new file mode 100644 index 0000000..6e5d278 --- /dev/null +++ b/src/method-aggregate.lisp @@ -0,0 +1,437 @@ +;;; -*-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 -------------------------------------------------- diff --git a/src/method-impl.lisp b/src/method-impl.lisp index e1b4980..49c6676 100644 --- a/src/method-impl.lisp +++ b/src/method-impl.lisp @@ -558,401 +558,4 @@ (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 -------------------------------------------------- diff --git a/src/sod.asd b/src/sod.asd index 3de24eb..0504ce4 100644 --- a/src/sod.asd +++ b/src/sod.asd @@ -158,6 +158,7 @@ ;; Method generation. (:file "method-proto" :depends-on ("class-make-proto")) (:file "method-impl" :depends-on ("method-proto")) + (:file "method-aggregate" :depends-on ("method-impl")) ;; Class output. (:file "class-output" :depends-on -- 2.11.0