Useful code - perhaps worth modifying base distribution?

From: Moises Lejter <mlm_at_cs.brown.edu>
Date: Wed, 26 Jul 1995 01:54:33 -0400

While creating some STKlos classes of my own, and it connection with
the suggestion made earlier that a proliferation of global functions
is very un-Scheme ;-), I decided it would be nice to be able to create
functions local to a class.

Class <MIA:list> is a subtype of <Listbox> that allows you to query and
set all entries in the listbox as a list (`values' is the pseudo-slot
that stands for the list of values as a whole):

  (MIA:define-class <MIA:list> (<Listbox>)
    ((get-all
      (lambda (listW)
        (do ((index 0 (+ 1 index))
             (num-values (slot-ref listW 'num-values))
             (values () (cons (get listW index) values)))
            ((= index num-values) (reverse values)))))
     (set-all
      (lambda (listW values)
        (do ((index 0 (+ 1 index))
             (vals values (cdr vals)))
            ((null? vals) (slot-set! listW 'num-values index) values)
          (insert listW index (car vals))))))
    ((values :accessor values
                  :init-keyword :values
                  :allocation :virtual
                  :slot-ref get-all
                  :slot-set! set-all)
     (num-values :getter num-values
                  :initform 0)))

#'MIA:define-class is like the #'define-class in STklos, except that
it accepts an optional argument, *before* the list of slots, which
will be a list of local functions to make available in creating the
slots, as in a #'letrec. Notice how I use #'get-all and #'set-all as
the getter and setter methods for my `values' slot.

This is my definition for MIA:define-class:

  (define-macro (MIA:define-class name parents vals . rest)
    (let ((functions ())
          (slots ())
          (options ()))
      (if (null? rest)
          (set! slots vals)
          (if (keyword? (car rest))
              (begin (set! options rest)
                     (set! slots vals))
              (begin (set! functions vals)
                     (set! slots (car rest))
                     (set! options (cdr rest)))))
      `(begin
         ;; cannot let #'define-class expand to #'define, since that would
         ;; put the newly create class in the scope of the letrec, and we
         ;; need it to be in the scope outside the letrec. So:
         ;; - add class name to correct environment, so it is found below;
         (define ,name #f)
         ;; create class definition within captured scope, replacing
         ;; #'define with #'set! inside the #'letrec.
         (letrec ,(append functions '((define set!)))
           (define-class ,name ,parents ,slots ,_at_options)))))

(Perhaps a tad more verbose than it needs to be, but legibility
seemed more important ;-) .)

Notice the contorsions in the body of the macro expansion, in order to
create the new class inside the letrec, yet have its name added to the
scope outside the letrec.

This seems to me to be a valuable thing to be able to do - but I am not
sure whether it belongs as a replacement for define-class...

Moises

P.S> If there was an easier way to get here, do let me know... ;-)

-----------------------------------------------------------------------------
Internet/CSnet: Moises_Lejter_at_brown.edu BITNET: mlm_at_browncs.BITNET
UUCP: ...!uunet!cs.brown.edu!mlm Phone: (401)863-7671
USmail: Moises Lejter, Box 1910 Brown University, Providence RI 02912
Received on Wed Jul 26 1995 - 07:57:58 CEST