;; Check that we've been given a method combination and make sure it
;; actually exists.
(unless comb
- (error "The `combination' property is required."))
+ (error "The `combination' property is required"))
(unless (some (lambda (method)
(let* ((specs (method-specializers method))
(message-spec (car specs))
comb))))
(generic-function-methods
#'compute-aggregating-message-kernel))
- (error "Unknown method combination `~(~A~)'." comb))
+ (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'."))
+ (error "The `most_specific' property must be `first' or `last'"))
;; Set up the function which will compute the kernel.
(let ((magic (cons nil nil))
(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))))
+ (check-method-return-type type wanted)
+ (check-method-argument-lists type msgtype)))
;;;--------------------------------------------------------------------------
;;; Utilities.
(unless (c-type-equal-p (c-type-subtype ,type)
,want-type)
(error "Messages with `~(~A~)' combination ~
- must return `~A'."
+ must return `~A'"
,combvar ,want-type)))
(call-next-method))))
: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)
- :return-type int
+(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)
- :return-type int
+(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
: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")
+ &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
(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)