oop/goops/composite-slot.scm

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