;;;----- 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
;;;--------------------------------------------------------------------------
;;; 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.
(:method (message combination type)
t))
-(export 'standard-effective-method)
+(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'."))
(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)))
(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
(: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.
(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))
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.
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
(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))
;;;--------------------------------------------------------------------------
;;; 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)
: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)
: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.
((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)
~mdw / sod / blobdiff