52 lines
1.9 KiB
Plaintext
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))))
|