---- 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) ;;; 5Received 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