----
Just as a somewhat more motivating example: In the library's implementation
of Tk widgets as STklos objects, there's a method `tk-constructor', which
must be defined for each simple widget class, and just returns a function
that can be called to create the appropriate kind of Tk command.
Now, this works; but to me, it feels a little heavy-handed to create a new
method for what is essentially just a data slot (with unchanging data)
of the Tk widget class. If I were designing from scratch, I would be trying
to use a class slot. And this is the kind of situation I _do_ design
from scratch, a lot.
So this is all I'm saying: I'd like _this_ kind of thing to be easy to
do. Both "define a method for each class" and "define the slot on each
class" seem like more than it should require just to set a value. It's
not a great hardship--I'll probably drop the subject soon. But it does
seem to me like a small flaw, and probably easily correctable.
--Erik
P.S. Here's another solution, mostly untested:
;;; given the following function and redefinition of define-class,
;;; class slots can be set as keyword arguments on the end of a
;;; class definition. the implementation is gross, but the end
;;; result is reasonably straightforward. an example follows
;;; the code.
(define-method set-class-slots ((class <class>) initargs)
(let ((getters-n-setters (slot-ref class 'getters-n-setters)))
(map (lambda (slot)
(if (eq? (get-slot-allocation slot) :class)
(let* ((init-keyword (get-keyword :init-keyword (cdr slot) #f))
(initform #f)
(has-initform (not (catch
(set! initform
(get-keyword :initform
(cdr slot))))))
(setter (lambda (quoted-value)
((caddr (assq (car slot) getters-n-setters))
"it doesn't matter what this argument is"
(eval quoted-value)))))
(cond ((and init-keyword has-initform)
(setter (get-keyword init-keyword initargs
initform)))
(initform
(setter initform))
(init-keyword
(catch
(setter (get-keyword init-keyword
initargs))))))))
(slot-ref class 'slots))))
(define-macro (define-class name supers slots . options)
`(define ,name
(let ((class (make (or ,(get-keyword :metaclass options #f)
,(ensure-metaclass (map eval supers)))
:dsupers ,(if (null? supers)
`(list <object>)
`(list ,_at_supers))
:slots ',slots
:name ',name)))
(set-class-slots class ',options)
class)))
;;; STk> (define-class <Whatever2> ()
;;; [(shared-counter :allocation :class
;;; :initform 0
;;; :init-keyword :shared-counter)])
;;; #[undefined]
;;; STk> (define-class <whatever3> (<whatever2>) ())
;;; #[undefined]
;;; STk> (define-class <whatever4> (<whatever2>) () :shared-counter 5)
;;; #[undefined]
;;; STk> (slot-ref (make <whatever2>) 'shared-counter)
;;; 0
;;; STk> (slot-ref (make <whatever3>) 'shared-counter)
;;; 0
;;; STk> (slot-ref (make <whatever4>) 'shared-counter)
;;; 5
Received on Fri Sep 06 1996 - 01:11:00 CEST
This archive was generated by hypermail 2.3.0 : Mon Jul 21 2014 - 19:38:59 CEST