;;;;
;;;; c o m p o s i t e - s l o t . s t k l o s 	  --  Composite slots metaclass
;;;;
;;;; Copyright © 1996-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions.  No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 17-Oct-1996 18:16
;;;; Last file update:  3-Sep-1999 20:05 (eg)

(select-module STklos)

(define-class <Composite-metaclass> (<class>)
  ())

(define-method compute-get-n-set ((class <Composite-metaclass>) slot)
  (if (memv (slot-definition-allocation slot) '(:propagated :special))
      (compute-propagated-get-n-set slot (class-environment class))
      (next-method)))

(define (compute-propagated-get-n-set s env)
  (let ((prop   	(or (get-keyword :propagate-to  (cdr s) #f)
			    (get-keyword :propagate     (cdr s) #f)))
	(s-name   	(slot-definition-name s))
	(build-reader   (lambda (s default)
			  (unless (pair? s) (set! s (list s default)))
			  `(slot-ref (slot-ref o ',(car s)) ',(cadr s))))
	(build-writer	(lambda (s default)
			  (unless (pair? s) (set! s (list s default)))
			  `(slot-set! (slot-ref o ',(car s)) ',(cadr 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))

    (list 
       ;; The getter
       (make-closure `(lambda (o) 
			,(build-reader (car prop) s-name))
		     env)
       ;; The setter
       (make-closure `(lambda (o v)
			,@(map (lambda (item) (build-writer item s-name)) prop))
		     env))))