doc/sod.sty: Adjust the default dash pattern.

[sod] / src / method-aggregate.lisp

diff --git a/src/method-aggregate.lisp b/src/method-aggregate.lisp
index 6e5d278..82ff2ca 100644 (file)
--- a/src/method-aggregate.lisp
+++ b/src/method-aggregate.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
 
 ;;;----- 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
 ;;;
 ;;; 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.
 
 ;;;--------------------------------------------------------------------------
 ;;; 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
 (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.
 
   (:documentation
    "Message class for aggregating method combinations.
 


@@ -94,10 +96,30 @@
   (:method (message combination type)
     t))
 
   (: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'."))
 
 (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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Implementation.
 


@@ -105,27 +127,27 @@
   (with-slots (combination) message
     (check-aggregating-message-type message combination 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)))
   '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))
             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)))
 
       ;; Check that we've been given a method combination and make sure it
       ;; actually exists.
       (unless comb
     (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."))
+       (error "The `combination' property is required"))

       (unless (some (lambda (method)
                      (let* ((specs (method-specializers method))
                             (message-spec (car specs))
       (unless (some (lambda (method)
                      (let* ((specs (method-specializers method))
                             (message-spec (car specs))


@@ -137,12 +159,12 @@
                                 comb))))
                    (generic-function-methods
                     #'compute-aggregating-message-kernel))
                                 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))
       (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))
 
       ;; Set up the function which will compute the kernel.
       (let ((magic (cons nil nil))


@@ -157,6 +179,7 @@
                 (prop (get-property pset name type magic)))
            (unless (eq prop magic)
              (setf keys (list* name prop keys)))))
                 (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
 
        ;; Set the kernel function for later.
        (setf kernel-function


@@ -168,7 +191,16 @@
                         (:first methods)
                         (:last (setf methods (reverse methods))))
                       arg-names
                         (: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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Utilities.


@@ -179,8 +211,9 @@
      (vars
       &key (codegen (gensym "CODEGEN-"))
           (methods (gensym "METHODS-")))
      (vars
       &key (codegen (gensym "CODEGEN-"))
           (methods (gensym "METHODS-")))

-     &key properties
+     &key properties return-type

          ((:around around-func) '#'funcall)
          ((: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.
          ((:first-method first-method-func) nil firstp)
          ((:methods methods-func) '#'funcall))
   "Utility macro for definining aggregating method combinations.


@@ -211,6 +244,15 @@
    All of these variables, and the VARS, are available in the functions
    described below.
 
    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.
+
+   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.
 
    The AROUND, FIRST-METHOD, and METHODS are function designators (probably
    `lambda' forms) providing pieces of the aggregating behaviour.
 


@@ -233,9 +275,9 @@
    the appropriate direct method and deliver its return value to TARGET,
    which defaults to `:void'."
 
    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
                 meth targ func call-methfunc

-                aroundfunc fmethfunc methfunc)
+                aroundfunc fmethfunc methfunc bodyfunc)

     `(progn
 
        ;; If properties are listed, arrange for them to be collected.
     `(progn
 
        ;; If properties are listed, arrange for them to be collected.


@@ -251,6 +293,28 @@
                                    (cadr prop)))
                            properties))))
 
                                    (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))))
+
+       ;; 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))
        ;; Define the main kernel-compuation method.
        (defmethod compute-aggregating-message-kernel
           ((,msg aggregating-message) (,combvar (eql ',comb))


@@ -262,83 +326,75 @@
         ;; Declare the necessary variables and give names to the functions
         ;; supplied by the caller.
         (let* (,@(and vars
         ;; 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)
                ,@(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)))
 
                (,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)))
 
 
                  ;; 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)))
 
 ;;;--------------------------------------------------------------------------
 ;;; Fixed aggregating method combinations.
 
 
        ',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
+  :empty (lambda () nil))

 
 (define-aggregating-method-combination :sum ((acc val) :codegen codegen)
 
 (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)))
   :first-method (lambda (invoke)
                  (funcall invoke val)
                  (emit-inst codegen (make-set-inst acc val)))


@@ -347,6 +403,7 @@
             (emit-inst codegen (make-update-inst acc #\+ val))))
 
 (define-aggregating-method-combination :product ((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)))
   :first-method (lambda (invoke)
                  (funcall invoke val)
                  (emit-inst codegen (make-set-inst acc val)))


@@ -361,7 +418,7 @@
   :methods (lambda (invoke)
             (funcall invoke val)
             (emit-inst codegen (make-if-inst (format nil "~A > ~A" 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))))
+                                             (make-set-inst acc val)))))

 
 (define-aggregating-method-combination :max ((acc val) :codegen codegen)
   :first-method (lambda (invoke)
 
 (define-aggregating-method-combination :max ((acc val) :codegen codegen)
   :first-method (lambda (invoke)


@@ -370,32 +427,30 @@
   :methods (lambda (invoke)
             (funcall invoke val)
             (emit-inst codegen (make-if-inst (format nil "~A < ~A" 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))))
+                                             (make-set-inst acc val)))))

 
 

-(define-aggregating-method-combination :and ((ret val) :codegen codegen)
+(define-aggregating-method-combination :and ((ret) :codegen codegen)
+  :empty (lambda () (emit-inst codegen (make-set-inst ret 1)))

   :around (lambda (body)
            (codegen-push codegen)
   :around (lambda (body)
            (codegen-push codegen)

-           (deliver-expr codegen ret 0)

            (funcall body)
            (funcall body)

-           (deliver-expr codegen ret 1)

            (emit-inst codegen
                       (make-do-while-inst (codegen-pop-block codegen) 0)))
   :methods (lambda (invoke)
            (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)
+  :empty (lambda () (emit-inst codegen (make-set-inst ret 0)))

   :around (lambda (body)
            (codegen-push codegen)
   :around (lambda (body)
            (codegen-push codegen)

-           (deliver-expr codegen ret 1)

            (funcall body)
            (funcall body)

-           (deliver-expr codegen ret 0)

            (emit-inst codegen
                       (make-do-while-inst (codegen-pop-block codegen) 0)))
   :methods (lambda (invoke)
            (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.
 
 ;;;--------------------------------------------------------------------------
 ;;; A customizable aggregating method combination.


@@ -404,34 +459,54 @@
     ((message aggregating-message) (combination (eql :custom)))
   '(:retvar :id
     :valvar :id
     ((message aggregating-message) (combination (eql :custom)))
   '(:retvar :id
     :valvar :id

+    :methty :type
+    :empty :fragment

     :decls :fragment
     :before :fragment
     :first :fragment
     :each :fragment
     :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 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
 
 (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)
+         empty decls before each (first each) after count)

   (let* ((type (c-type-subtype (sod-message-type message)))
   (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
+        (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)
       (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)))
                              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 --------------------------------------------------
       (deliver-expr codegen target retvar))))
 
 ;;;----- That's all, folks --------------------------------------------------