← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to oop/goops/composite-slot.scm

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

Lines of Context:
oop/goops/composite-slot.scm
 
1
;;; installed-scm-file
 
2
 
 
3
;;;;    Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
 
4
;;;; 
 
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.
 
9
;;;; 
 
10
;;;; This library 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 GNU
 
13
;;;; Lesser General Public License for more details.
 
14
;;;; 
 
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
 
17
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
18
;;;; 
 
19
 
 
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)
 
29
  :use-module (oop goops)
 
30
  :export (<composite-class>))
 
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
 
 
51
(define-method (compute-get-n-set (class <composite-class>) slot)
 
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))))))))