diff options
Diffstat (limited to 'oop/goops/composite-slot.scm')
-rw-r--r-- | oop/goops/composite-slot.scm | 84 |
1 files changed, 84 insertions, 0 deletions
diff --git a/oop/goops/composite-slot.scm b/oop/goops/composite-slot.scm new file mode 100644 index 000000000..4f44f0619 --- /dev/null +++ b/oop/goops/composite-slot.scm @@ -0,0 +1,84 @@ +;;; installed-scm-file + +;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA +;;;; + + +;;;; This software is a derivative work of other copyrighted softwares; the +;;;; copyright notices of these softwares are placed in the file COPYRIGHTS +;;;; +;;;; This file is based upon composite-slot.stklos from the STk +;;;; distribution by Erick Gallesio <eg@unice.fr>. +;;;; + +(define-module (oop goops composite-slot) + :use-module (oop goops)) + +(export <composite-class>) + +;;; +;;; (define-class CLASS SUPERS +;;; ... +;;; (OBJECT ...) +;;; ... +;;; (SLOT #:allocation #:propagated +;;; #:propagate-to '(PROPAGATION ...)) +;;; ... +;;; #:metaclass <composite-class>) +;;; +;;; PROPAGATION ::= OBJECT | (OBJECT TARGETSLOT) +;;; +;;; The slot SLOT will be propagated to the slot TARGETSLOT in the object +;;; stored in slot OBJECT. If TARGETSLOT is omitted, assume that the target +;;; slot is named SLOT. +;;; + +(define-class <composite-class> (<class>)) + +(define-method compute-get-n-set ((class <composite-class>) slot) + (if (eq? (slot-definition-allocation slot) #:propagated) + (compute-propagated-get-n-set slot) + (next-method))) + +(define (compute-propagated-get-n-set s) + (let ((prop (get-keyword #:propagate-to (cdr s) #f)) + (s-name (slot-definition-name s))) + + (if (not prop) + (goops-error "Propagation not specified for slot ~S" s-name)) + (if (not (pair? prop)) + (goops-error "Bad propagation list for slot ~S" s-name)) + + (let ((objects (map (lambda (p) (if (pair? p) (car p) p)) prop)) + (slots (map (lambda (p) (if (pair? p) (cadr p) s-name)) prop))) + (let ((first-object (car objects)) + (first-slot (car slots))) + (list + ;; The getter + (lambda (o) + (slot-ref (slot-ref o first-object) first-slot)) + + ;; The setter + (if (null? (cdr objects)) + (lambda (o v) + (slot-set! (slot-ref o first-object) first-slot v)) + (lambda (o v) + (for-each (lambda (object slot) + (slot-set! (slot-ref o object) slot v)) + objects + slots)))))))) |