Help needed on metaclass problem

From: Andrew Dorrell <dorrell_at_ihf.uts.edu.au>
Date: Mon, 27 Jul 1998 23:39:03 +1000

Help :-!

I find myself writing composite widgets which contain lists of Tk
widgets.

These widgets share many properties so I thought I would use a
metaclass in order to reduce the complexity. I wanted two new
allocation schemes: shared and sequenced, I also wanted to retain
:propagated so I inherited it <composite-metaclass>. I have appended
an outline of the code to this email. (It is quite short)

The problem I am having is that the :propagated slot allocation gets
lost somewhere (the new slot allocations work fine). I have tried
many things, including playing around with module selection, all to no
avail. I am really stuck on this one and would really appreciate any
help that I can get.

Thanks in advance,

-- 
Mr Andrew Dorrell                                *
Faculty of Engineering             /---\  Whoo?      *
University of Technology, Sydney   (o o) /     *
AUSTRALIA                          ( : )            .
                                    ^ ^
                                                    *
--------------------------------------------------------------------------
list-slot.stklos :
--------------------------------------------------------------------------
(require "Tk-classes")
(require "stklos")
(require "Tk-meta")
(define-class <List-composite-metaclass> (<Composite-metaclass>)
  ())
(define-method compute-get-n-set ((class <List-composite-metaclass>)
slot)
  (cond ((memv (slot-definition-allocation slot) '(:sequenced))
	 (compute-sequenced-get-n-set slot (class-environment class)))
	((memv (slot-definition-allocation slot) '(:shared))
	 (compute-shared-get-n-set slot (class-environment class)))
	(else
	 (next-method))))
(define (compute-sequenced-get-n-set s env)
  (let ((prop	(get-keyword :items-in  (cdr s) #f))
	(s-name (slot-definition-name s))
	(reader (lambda(s default)
		  (unless (pair? s) (set! s (list s default)))
		  `(map (lambda(o) (slot-ref o ',(cadr s)))
			(slot-ref o ',(car s)))))
	(writer (lambda(s default)
		  (unless (pair? s) (set! s (list s default)))
		  `(for-each (lambda(o v) (slot-set! o ',(cadr s) v))
			     (slot-ref o ',(car s)) v)))
	)
    (unless prop (error "Propagation not specified for slot ~s"
s-name))
    (unless (pair? prop) (error "Bad propagation list for slot ~s"
s-name))
    
    (map eval `((lambda(o)   ,(reader (car prop) s-name))
		(lambda(o v) ,_at_(map (lambda(item)(writer item s-name)) prop))))
    ))
(define (compute-shared-get-n-set s env)
  (let ((prop	(get-keyword :items-in  (cdr s) #f))
	(s-name (slot-definition-name s))
	(reader (lambda(s default)
		  (unless (pair? s) (set! s (list s default)))
		  `(slot-ref (car (slot-ref o ',(car s))) ',(cadr s))))
	(writer (lambda(s default)
		  (unless (pair? s) (set! s (list s default)))
		  `(for-each (lambda(o) (slot-set! o ',(cadr s) v))
			     (slot-ref o ',(car s)))))
	)
    (unless prop (error "Propagation not specified for slot ~s"
s-name))
    (unless (pair? prop) (error "Bad propagation list for slot ~s"
s-name))
    
    (map eval `((lambda(o)   ,(reader (car prop) s-name))
		(lambda(o v) ,_at_(map (lambda(item)(writer item s-name)) prop))))
    ))
(define-class <Tk-list-composite-metaclass> (<Tk-metaclass>
<List-composite-metaclass>)
  ())
(define-class <Tk-list-composite-widget> (<Tk-composite-widget>)
  ((frame :accessor     frame-of)
   (class :accessor     class
	  :init-form    "List-composite"
	  :init-keyword :class))
  :metaclass <Tk-list-composite-metaclass>)
----------------------------------------------------------------------------
test.stk :
----------------------------------------------------------------------------
(load "list-slot")
(define-class <test> (<Tk-list-composite-widget>)
  ((label	:accessor	label-of)
   (buttons	:accessor	buttons-of)
;   (text	:accessor	text
;		:allocation	:propagated
;		:propagate-to	(label)
;		:initform	"foo")
   (variable	:accessor	variable
		:allocation	:shared
		:items-in	(buttons)
		:init-keyword	:variable)
   (options	:accessor	options
		:allocation	:sequenced
		:items-in	((buttons text))
		:init-keyword	:options)
   ))
;;
;; Can't even get this far with text slot uncommented
;;
(define-method initialize-composite-widget ((self <test>) args parent)
  (let ((l  (make <label> :parent parent :text "foo: "))
	(b  (map (lambda(n)
		   (make <radio-button> 
			 :parent parent :value n))
		 '(1 2 3 4 5))))
    (slot-set! self 'label l)
    (slot-set! self 'buttons b)
    (apply pack `(,l ,_at_b :side left))))
(define foo 1)
(define t (make <test> :variable 'foo :options '(a b c d e)))
(pack t)

Received on Mon Jul 27 1998 - 15:50:31 CEST