stk/STklos/composite-slot.stklos

52 lines
1.9 KiB
Plaintext

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