X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/11e41ddf86b4ee793f44fc0e39cb4c1869335b14..3b2ec4790da6b3f64189a58896957ac63169dd5e:/src/method-aggregate.lisp diff --git a/src/method-aggregate.lisp b/src/method-aggregate.lisp index e9a889d..dcafd8d 100644 --- a/src/method-aggregate.lisp +++ b/src/method-aggregate.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible 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 @@ -28,11 +28,13 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- ;;; Classes and protocol. -(export '(aggregating-message message-combination)) +(export '(aggregating-message + sod-message-combination sod-message-kernel-function)) (defclass aggregating-message (simple-message) ((combination :initarg :combination :type keyword - :reader message-combination) - (kernel-function :type function :reader message-kernel-function)) + :reader sod-message-combination) + (plist :type list :accessor sod-message-plist) + (kernel-function :type function :reader sod-message-kernel-function)) (:documentation "Message class for aggregating method combinations. @@ -94,10 +96,30 @@ (defgeneric check-aggregating-message-type (message combination type) (:method (message combination type) t)) +(defgeneric aggregating-message-method-return-type (message combination) + (:documentation + "Return the primary method return type for this MESSAGE and COMBINATION.") + (:method ((message aggregating-message) (combination t)) + (c-type-subtype (sod-message-type message)))) + (export 'aggregating-effective-method) (defclass aggregating-effective-method (simple-effective-method) () (:documentation "Effective method counterpart to `aggregating-message'.")) +(defgeneric aggregating-message-always-live-p (message combination) + (:documentation + "Return whether the method combination can work without primary methods. + + Return non-nil if the corresponding effective method should be considered + live even if it doesn't have any methods.") + (:method ((message aggregating-message) (combination t)) nil)) + +(defmethod effective-method-live-p ((method aggregating-effective-method)) + (or (let* ((message (effective-method-message method)) + (comb (sod-message-combination message))) + (aggregating-message-always-live-p message comb)) + (call-next-method))) + ;;;-------------------------------------------------------------------------- ;;; Implementation. @@ -105,20 +127,20 @@ (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)) +(defmethod sod-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)) + (funcall (sod-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 + (with-slots (combination plist kernel-function) message (let ((most-specific (get-property pset :most-specific :keyword :first)) (comb (get-property pset :combination :keyword))) @@ -157,6 +179,7 @@ (defmethod shared-initialize :before (prop (get-property pset name type magic))) (unless (eq prop magic) (setf keys (list* name prop keys))))) + (setf plist keys) ;; Set the kernel function for later. (setf kernel-function @@ -168,7 +191,16 @@ (defmethod shared-initialize :before (:first methods) (:last (setf methods (reverse methods)))) arg-names - keys))))))) + plist))))))) + +(defmethod check-method-type + ((method sod-method) (message aggregating-message) + (type c-function-type)) + (let ((wanted (aggregating-message-method-return-type + message (sod-message-combination message))) + (msgtype (sod-message-type message))) + (check-method-return-type type wanted) + (check-method-argument-lists type msgtype))) ;;;-------------------------------------------------------------------------- ;;; Utilities. @@ -181,6 +213,7 @@ (defmacro define-aggregating-method-combination (methods (gensym "METHODS-"))) &key properties return-type ((:around around-func) '#'funcall) + ((:empty empty-func) nil emptyp) ((:first-method first-method-func) nil firstp) ((:methods methods-func) '#'funcall)) "Utility macro for definining aggregating method combinations. @@ -215,6 +248,11 @@ (defmacro define-aggregating-method-combination on `check-aggregating-message-type' to check the that the message's return type matches RETURN-TYPE. + If an EMPTY function is given, then (a) it's OK if there are no primary + methods, because (b) the EMPTY function is called to set the return + value variable in this case. Note that EMPTY is only called when there + are no primary methods. + The AROUND, FIRST-METHOD, and METHODS are function designators (probably `lambda' forms) providing pieces of the aggregating behaviour. @@ -239,7 +277,7 @@ (defmacro define-aggregating-method-combination (with-gensyms (type msg combvar target arg-names args want-type meth targ func call-methfunc - aroundfunc fmethfunc methfunc) + aroundfunc fmethfunc methfunc bodyfunc) `(progn ;; If properties are listed, arrange for them to be collected. @@ -269,6 +307,14 @@ (defmacro define-aggregating-method-combination ,combvar ,want-type))) (call-next-method)))) + ;; If there is an EMPTY function then the effective method is always + ;; live. + ,@(and emptyp + `((defmethod aggregating-message-always-live-p + ((,msg aggregating-message) + (,combvar (eql ',comb))) + t))) + ;; Define the main kernel-compuation method. (defmethod compute-aggregating-message-kernel ((,msg aggregating-message) (,combvar (eql ',comb)) @@ -280,51 +326,63 @@ (defmethod compute-aggregating-message-kernel ;; 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))))) + `((,type (c-type-subtype (sod-message-type ,msg))) + (,(car vars) (temporary-var ,codegen ,type)))) ,@(mapcar (lambda (var) - (list var `(temporary-var ,codegen ,type))) - vars) + (list var `(and ,methods + (temporary-var ,codegen ,type)))) + (cdr 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))))) + (flet ((,bodyfunc () + (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))))))) + + ;; Arrange to release the temporaries when we're finished with + ;; them. + (unwind-protect + (progn + + ;; If there are no direct methods, then just do the + ;; empty-effective-method thing to set the return + ;; variable. Otherwise, wrap AROUND round the main body. + ,(if emptyp + `(if (null ,methods) + (funcall ,empty-func) + (,bodyfunc)) + `(,bodyfunc)) ;; 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)))) + ;; Finally, release the temporary variables. + ,@(mapcar (lambda (var) + `(when ,var (setf (var-in-use-p ,var) nil))) + vars))))) ',comb))) @@ -332,9 +390,11 @@ (defmethod compute-aggregating-message-kernel ;;; Fixed aggregating method combinations. (define-aggregating-method-combination :progn (nil) - :return-type void) + :return-type void + :empty (lambda () nil)) (define-aggregating-method-combination :sum ((acc val) :codegen codegen) + :empty (lambda () (emit-inst codegen (make-set-inst acc 0))) :first-method (lambda (invoke) (funcall invoke val) (emit-inst codegen (make-set-inst acc val))) @@ -343,6 +403,7 @@ (define-aggregating-method-combination :sum ((acc val) :codegen codegen) (emit-inst codegen (make-update-inst acc #\+ val)))) (define-aggregating-method-combination :product ((acc val) :codegen codegen) + :empty (lambda () (emit-inst codegen (make-set-inst acc 1))) :first-method (lambda (invoke) (funcall invoke val) (emit-inst codegen (make-set-inst acc val))) @@ -357,7 +418,7 @@ (define-aggregating-method-combination :min ((acc val) :codegen codegen) :methods (lambda (invoke) (funcall invoke val) (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val) - (make-set-inst acc val) nil)))) + (make-set-inst acc val))))) (define-aggregating-method-combination :max ((acc val) :codegen codegen) :first-method (lambda (invoke) @@ -366,34 +427,30 @@ (define-aggregating-method-combination :max ((acc val) :codegen codegen) :methods (lambda (invoke) (funcall invoke val) (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val) - (make-set-inst acc val) nil)))) + (make-set-inst acc val))))) -(define-aggregating-method-combination :and ((ret val) :codegen codegen) - :return-type int +(define-aggregating-method-combination :and ((ret) :codegen codegen) + :empty (lambda () (emit-inst codegen (make-set-inst ret 1))) :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)))) + (funcall invoke ret) + (emit-inst codegen (make-if-inst (format nil "!~A" ret) + (make-break-inst))))) -(define-aggregating-method-combination :or ((ret val) :codegen codegen) - :return-type int +(define-aggregating-method-combination :or ((ret) :codegen codegen) + :empty (lambda () (emit-inst codegen (make-set-inst ret 0))) :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)))) + (funcall invoke ret) + (emit-inst codegen (make-if-inst ret (make-break-inst))))) ;;;-------------------------------------------------------------------------- ;;; A customizable aggregating method combination. @@ -402,6 +459,8 @@ (defmethod aggregating-message-properties ((message aggregating-message) (combination (eql :custom))) '(:retvar :id :valvar :id + :methty :type + :empty :fragment :decls :fragment :before :fragment :first :fragment @@ -409,30 +468,45 @@ (defmethod aggregating-message-properties :after :fragment :count :id)) +(defmethod aggregating-message-method-return-type + ((message aggregating-message) (combination (eql :custom))) + (getf (sod-message-plist message) :methty + (c-type-subtype (sod-message-type message)))) + +(defmethod aggregating-message-always-live-p + ((message aggregating-message) (combination (eql :custom))) + (getf (sod-message-plist message) :empty)) + (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 count) + &key (retvar "sod_ret") (valvar "sod_val") (methty nil methtyp) + empty decls before each (first each) after count) (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 count - (ensure-var codegen count c-type-int (length methods))) - (when decls + (methty (if methtyp methty type))) + (unless (eq type c-type-void) + (ensure-var codegen retvar type)) + (unless (or (null methods) + (eq methty c-type-void)) + (ensure-var codegen valvar methty)) + (when (and methods count) + (ensure-var codegen count c-type-size-t (length methods))) + (when (and methods 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) + (invoke-method codegen + (if (eq methty c-type-void) :void valvar) arg-names method) (maybe-emit fragment))) - (maybe-emit before) - (invoke (car methods) first) - (dolist (method (cdr methods)) (invoke method each)) - (maybe-emit after) + (cond ((and empty (null methods)) + (emit-inst codegen empty)) + (t + (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 --------------------------------------------------