with-accessors macro

[Andy Wingo <wingo@pobox.com>]

Heya hackers,

Use GOOPS? Think slot-ref is ugly? Don't like the permeation of
accessors into the global namespace? `with-accessors' is for you!

Use example:

    (define (scale-opacity w ratio)
      (with-accessors (opacity)
        (set! (opacity w)
              (* (opacity w) ratio))))

Definition:

    (define-macro (with-accessors names . body)
      `(let (,@(map (lambda (name)
                      `(,name ,(make-procedure-with-setter
                                (lambda (x) (slot-ref x name))
                                (lambda (x y) (slot-set! x name y)))))
                    names))
         ,@body))

It would be nice to actually use accessors, so that we can get their
compilation characteristics. This version would probably work:

    (define (fetch-g-n-s name class)
      (assq name (slot-ref class 'getters-n-setters)))

    (define-class <lazy-getter> (<generic>))
    (define-method (no-applicable-method (gf <lazy-getter>) args)
      (if (= (length args) 1)
          (let* ((class (class-of (car args)))
                 (g-n-s (fetch-g-n-s (generic-function-name gf) class)))
            (if g-n-s
                (begin
                  (add-method! gf (compute-getter-method class g-n-s))
                  (gf (car args)))
                (next-method)))
          (next-method)))

    (define-class <lazy-setter> (<generic>)
      (slot-name #:init-keyword #:slot-name))
    (define-method (no-applicable-method (gf <lazy-setter>) args)
      (if (= (length args) 2)
          (let* ((class (class-of (car args)))
                 (g-n-s (fetch-g-n-s (slot-ref gf 'slot-name) class)))
            (if g-n-s
                (begin
                  (add-method! gf (compute-setter-method class g-n-s))
                  (gf (car args) (cadr args)))
                (next-method)))
          (next-method)))

    (define-class <lazy-accessor> (<accessor> <lazy-getter>))

    (define (make-lazy-accessor name)
      (make <lazy-accessor>
        #:name name
        #:setter (make <lazy-setter>
                   #:name (symbol-append 'setter: name)
                   #:slot-name name)))

    (define-macro (with-accessors names . body)
      `(let (,@(map (lambda (name)
                      `(,name ,(make-accessor name)))
                    names))
         ,@body))

But GOOPS doesn't do subclasses of <generic> yet. One day that code will
magically spring to utility.

Happy hacking,

Andy
-- 
http://wingolog.org/