Commit | Line | Data |
---|---|---|
14f1d9fe MD |
1 | ;;; installed-scm-file |
2 | ||
71d540f7 | 3 | ;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. |
14f1d9fe | 4 | ;;;; |
73be1d9e MV |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 2.1 of the License, or (at your option) any later version. | |
14f1d9fe | 9 | ;;;; |
73be1d9e | 10 | ;;;; This library is distributed in the hope that it will be useful, |
14f1d9fe | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;;; Lesser General Public License for more details. | |
14f1d9fe | 14 | ;;;; |
73be1d9e MV |
15 | ;;;; You should have received a copy of the GNU Lesser General Public |
16 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
14f1d9fe MD |
18 | ;;;; |
19 | \f | |
20 | ||
21 | ;;;; This software is a derivative work of other copyrighted softwares; the | |
22 | ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS | |
23 | ;;;; | |
24 | ;;;; This file is based upon composite-slot.stklos from the STk | |
25 | ;;;; distribution by Erick Gallesio <eg@unice.fr>. | |
26 | ;;;; | |
27 | ||
28 | (define-module (oop goops composite-slot) | |
1a179b03 MD |
29 | :use-module (oop goops) |
30 | :export (<composite-class>)) | |
14f1d9fe MD |
31 | |
32 | ;;; | |
33 | ;;; (define-class CLASS SUPERS | |
34 | ;;; ... | |
35 | ;;; (OBJECT ...) | |
36 | ;;; ... | |
37 | ;;; (SLOT #:allocation #:propagated | |
38 | ;;; #:propagate-to '(PROPAGATION ...)) | |
39 | ;;; ... | |
40 | ;;; #:metaclass <composite-class>) | |
41 | ;;; | |
42 | ;;; PROPAGATION ::= OBJECT | (OBJECT TARGETSLOT) | |
43 | ;;; | |
44 | ;;; The slot SLOT will be propagated to the slot TARGETSLOT in the object | |
45 | ;;; stored in slot OBJECT. If TARGETSLOT is omitted, assume that the target | |
46 | ;;; slot is named SLOT. | |
47 | ;;; | |
48 | ||
49 | (define-class <composite-class> (<class>)) | |
50 | ||
71d540f7 | 51 | (define-method (compute-get-n-set (class <composite-class>) slot) |
14f1d9fe MD |
52 | (if (eq? (slot-definition-allocation slot) #:propagated) |
53 | (compute-propagated-get-n-set slot) | |
54 | (next-method))) | |
55 | ||
56 | (define (compute-propagated-get-n-set s) | |
57 | (let ((prop (get-keyword #:propagate-to (cdr s) #f)) | |
58 | (s-name (slot-definition-name s))) | |
59 | ||
60 | (if (not prop) | |
61 | (goops-error "Propagation not specified for slot ~S" s-name)) | |
62 | (if (not (pair? prop)) | |
63 | (goops-error "Bad propagation list for slot ~S" s-name)) | |
64 | ||
65 | (let ((objects (map (lambda (p) (if (pair? p) (car p) p)) prop)) | |
66 | (slots (map (lambda (p) (if (pair? p) (cadr p) s-name)) prop))) | |
67 | (let ((first-object (car objects)) | |
68 | (first-slot (car slots))) | |
69 | (list | |
70 | ;; The getter | |
71 | (lambda (o) | |
72 | (slot-ref (slot-ref o first-object) first-slot)) | |
73 | ||
74 | ;; The setter | |
75 | (if (null? (cdr objects)) | |
76 | (lambda (o v) | |
77 | (slot-set! (slot-ref o first-object) first-slot v)) | |
78 | (lambda (o v) | |
79 | (for-each (lambda (object slot) | |
80 | (slot-set! (slot-ref o object) slot v)) | |
81 | objects | |
82 | slots)))))))) |