Improved delegation macro

From: David Fox <>
Date: Mon, 6 Jan 1997 09:46:36 -0500 (EST)

Some time back I posted a macro that builds a class that implements
delegation rather than conventional inheritance. I don't know if
anyone is using it, but I've just made a small improvement that
improves the handling of initialization. The only restriction now is
that if you define your own initialize method for such a class,
instead of calling (next-method) you must call (%initialize-object
self args). Here is the new version of the define-filtered macro:

(If anyone is using this I'd *love* to hear about it. But I know
you're not...)

----------- Cut Here ------------------
; delegation.scm
; Copyright (c) 1996,1997 - David Fox.

(define-macro (define-filtered name supers slots . options)
     (define-class ,name ()
         (list '(super :init-keyword :super))
          (lambda (slot)
            `(,(car slot)
              :allocation :virtual
              :slot-ref (lambda (self)
                         (slot-ref (slot-ref self 'super) ',(car slot)))
              :slot-set! (lambda (self v)
                          (slot-set! (slot-ref self 'super) ',(car slot) v))))
          (slot-ref (eval (car supers)) 'slots))))
     (slot-set! ,name 'direct-supers (list ,(car supers)))
     (slot-set! ,name 'cpl (compute-cpl ,name))
     (define-method initialize ((self ,name) args)
       (%initialize-object self args))))

(provide "delegation")
------------ Cut Here -----------------

Here is an example of its use:
------------ Cut Here -----------------
(require "delegation")

(define-class <point> ()
  ((x :init-keyword :x :accessor x)
   (y :init-keyword :y :accessor y)))

(define-filtered <3d-point> (<point>)
  ((z :init-keyword :z :accessor z)))

(define p (make <point> :x 3. :y 4.))
(define p3 (make <3d-point> :super p :z 5.))

(slot-set! p 'x 1.)
(format (current-output-port) "p3.x = ~s (should be 1.)\n" (slot-ref p3 'x))
------------ Cut Here -----------------

David Fox              xoF divaD
NYU Media Research Lab    baL hcraeseR aideM UYN
Received on Mon Jan 06 1997 - 15:44:15 CET

This archive was generated by hypermail 2.3.0 : Mon Jul 21 2014 - 19:38:59 CEST