X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3f7e339fba1979da20bb44cac256c5d776ced9fa..e75eb63d81df077c02c6c74439fb14a34d4fb93e:/src/method-impl.lisp

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