X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/d7887906f573f1cbfa9f04ade2df7966bed57b07..167524b5890cdbf4a832b1766a328f6d8a1f8f04:/src/method-aggregate.lisp diff --git a/src/method-aggregate.lisp b/src/method-aggregate.lisp index 1332e10..ec0a119 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 @@ ;;;-------------------------------------------------------------------------- ;;; Classes and protocol. -(export 'aggregating-message) +(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,6 +96,12 @@ (: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'.")) @@ -105,20 +113,20 @@ (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 +165,7 @@ (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 +177,20 @@ (: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))) + (unless (c-type-equal-p (c-type-subtype type) wanted) + (error "Method return type ~A doesn't match message ~A" + (c-type-subtype msgtype) (c-type-subtype type))) + (unless (argument-lists-compatible-p (c-function-arguments msgtype) + (c-function-arguments type)) + (error "Method arguments ~A don't match message ~A" type msgtype)))) ;;;-------------------------------------------------------------------------- ;;; Utilities. @@ -179,7 +201,7 @@ (vars &key (codegen (gensym "CODEGEN-")) (methods (gensym "METHODS-"))) - &key properties + &key properties return-type ((:around around-func) '#'funcall) ((:first-method first-method-func) nil firstp) ((:methods methods-func) '#'funcall)) @@ -211,6 +233,10 @@ All of these variables, and the VARS, are available in the functions described below. + If a RETURN-TYPE is given, it's a C-type S-expression: a method is defined + on `check-aggregating-message-type' to check the that the message's return + type matches RETURN-TYPE. + The AROUND, FIRST-METHOD, and METHODS are function designators (probably `lambda' forms) providing pieces of the aggregating behaviour. @@ -233,7 +259,7 @@ the appropriate direct method and deliver its return value to TARGET, which defaults to `:void'." - (with-gensyms (type msg combvar target arg-names args + (with-gensyms (type msg combvar target arg-names args want-type meth targ func call-methfunc aroundfunc fmethfunc methfunc) `(progn @@ -251,6 +277,20 @@ (cadr prop))) properties)))) + ;; If a particular return type is wanted, check that. + ,@(and return-type + `((defmethod check-aggregating-message-type + ((,msg aggregating-message) + (,combvar (eql ',comb)) + (,type c-function-type)) + (let ((,want-type (c-type ,return-type))) + (unless (c-type-equal-p (c-type-subtype ,type) + ,want-type) + (error "Messages with `~(~A~)' combination ~ + must return `~A'." + ,combvar ,want-type))) + (call-next-method)))) + ;; Define the main kernel-compuation method. (defmethod compute-aggregating-message-kernel ((,msg aggregating-message) (,combvar (eql ',comb)) @@ -313,30 +353,8 @@ ;;;-------------------------------------------------------------------------- ;;; 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 :progn (nil) + :return-type void) (define-aggregating-method-combination :sum ((acc val) :codegen codegen) :first-method (lambda (invoke) @@ -361,7 +379,7 @@ :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) @@ -370,32 +388,28 @@ :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) +(define-aggregating-method-combination :and ((ret) :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)))) + (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) +(define-aggregating-method-combination :or ((ret) :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)))) + (funcall invoke ret) + (emit-inst codegen (make-if-inst ret (make-break-inst))))) ;;;-------------------------------------------------------------------------- ;;; A customizable aggregating method combination. @@ -404,28 +418,39 @@ ((message aggregating-message) (combination (eql :custom))) '(:retvar :id :valvar :id + :methty :type :decls :fragment :before :fragment :first :fragment :each :fragment - :after :fragment)) + :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 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) + &key (retvar "sod_ret") (valvar "sod_val") (methty nil methtyp) + 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)) + (methty (if methtyp methty type))) + (unless (eq type c-type-void) + (ensure-var codegen retvar type)) + (unless (eq methty c-type-void) + (ensure-var codegen valvar methty)) + (when count + (ensure-var codegen count c-type-size-t (length methods))) (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) + (invoke-method codegen + (if (eq methty c-type-void) :void valvar) arg-names method) (maybe-emit fragment))) (maybe-emit before)