3 ;;;; Copyright (C) 1999, 2000, 2001, 2006, 2015 Free Software Foundation, Inc.
4 ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
23 ;;;; This file was based upon composite-slot.stklos from the STk distribution
24 ;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>.
27 (define-module (oop goops composite-slot)
28 :use-module (oop goops)
29 :export (<composite-class>))
32 ;;; (define-class CLASS SUPERS
36 ;;; (SLOT #:allocation #:propagated
37 ;;; #:propagate-to '(PROPAGATION ...))
39 ;;; #:metaclass <composite-class>)
41 ;;; PROPAGATION ::= OBJECT | (OBJECT TARGETSLOT)
43 ;;; The slot SLOT will be propagated to the slot TARGETSLOT in the object
44 ;;; stored in slot OBJECT. If TARGETSLOT is omitted, assume that the target
45 ;;; slot is named SLOT.
48 (define-class <composite-class> (<class>))
50 (define-method (compute-get-n-set (class <composite-class>) slot)
51 (if (eq? (slot-definition-allocation slot) #:propagated)
52 (compute-propagated-get-n-set slot)
55 (define (compute-propagated-get-n-set s)
56 (let ((prop (get-keyword #:propagate-to
57 (slot-definition-options s)
59 (s-name (slot-definition-name s)))
62 (goops-error "Propagation not specified for slot ~S" s-name))
63 (if (not (pair? prop))
64 (goops-error "Bad propagation list for slot ~S" s-name))
66 (let ((objects (map (lambda (p) (if (pair? p) (car p) p)) prop))
67 (slots (map (lambda (p) (if (pair? p) (cadr p) s-name)) prop)))
68 (let ((first-object (car objects))
69 (first-slot (car slots)))
73 (slot-ref (slot-ref o first-object) first-slot))
76 (if (null? (cdr objects))
78 (slot-set! (slot-ref o first-object) first-slot v))
80 (for-each (lambda (object slot)
81 (slot-set! (slot-ref o object) slot v))