Classes for method delegation

[Pat Lasswell]

Here's a way to get an instance to delegate generics to other instances without knowing what generics may be delegated.  It requires a change to the initialize method of <generic>.  (For discussion, see my posting to bug-guile today, 2 Sep 2006.)

Updated version of (initialize (gf <generic>) . initargs):

(define-method (initialize (generic <generic>) initargs)
  (let ((previous-definition (get-keyword #:default initargs #f))
        (name (get-keyword #:name initargs #f)))
    (next-method)
    (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
                                    (list (make <method>
                                                #:specializers <top>
                                                #:procedure
                                                (lambda l
                                                  (apply previous-definition
                                                         l))))
                                    (list (make <method>
                                            #:specializers <top>
                                            #:procedure
                                            (lambda args
                                              (no-applicable-method generic args))))))
    (if name
        (set-procedure-property! generic 'name name))
    ))


... and here's the module:

(define-module (delegator)
  #:use-module (ice-9 optargs)
  #:use-module (oop goops)
  #:export (<delegator>
            delegates
            find-delegate
            add-delegate!
            remove-delegate!
            <hash-delegator>
            <list-delegator>))


(define-class <delegator> ()
  (delegates #:getter delegates #:init-keyword #:delegates))

(define-method (delegate method (mgr <delegator>) . args)
  (let ((emp (apply find-delegate (cons mgr args))))
    (and emp
         (apply method (cons emp args)))))

(define-method (no-applicable-method (gf <generic>) args)
  (cond ((or (null? args) (not (is-a? (car args) <delegator>)))
         (goops-error "No applicable method for ~S in call ~S"
                      gf (cons (generic-function-name gf) args)))
        (else (apply delegate (cons gf args)))))

(define-method (find-delegate (mgr <delegator>) . args)
  #f)


(define-generic add-delegate!)
(define-generic remove-delegate!)


(define-class <hash-delegator> (<delegator>)
  (delegates #:getter delegates #:init-keyword #:delegates #:init-form #()))

(define-method (initialize (mgr <hash-delegator>) . initargs)
  (next-method)
  (let-keywords initargs #t ((initial-size 31))
    (slot-set! mgr 'delegates (make-hash-table initial-size))))

(define-method (find-delegate (mgr <hash-delegator>) key . args)
  (hash-ref (delegates mgr) key))

(define-method (add-delegate! (mgr <hash-delegator>) key emp)
  (hash-set! (delegates mgr) key emp))

(define-method (remove-delegate! (mgr <hash-delegator>) key)
  (hash-remove! (delegates mgr) key))


(define-class <list-delegator> (<delegator>)
  (delegates #:getter delegates #:init-keyword #:delegates #:init-form '()))

(define-method (find-delegate (mgr <list-delegator>) . args)
  (and (not (null? (delegates mgr)))
       (car (delegates mgr))))

(define-method (delegate method (mgr <list-delegator>) . args)
  (or-map (lambda (emp)
            (apply method (cons emp args)))
          (delegates mgr)))

(define-method (add-delegate! (mgr <list-delegator>) emp)
  (slot-push! mgr 'delegates emp))

(define-method (remove-delegate! (mgr <list-delegator>) emp)
  (slot-set! mgr 'delegates (delete emp (delegates mgr))))