← Back to branch summary

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

« back to all changes in this revision

Viewing changes to oop/goops/active-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/active-slot.scm
 
1
;;; installed-scm-file
 
2
 
 
3
;;;;    Copyright (C) 1999, 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 active-slot.stklos from the STk
 
25
;;;; distribution by Erick Gallesio <eg@unice.fr>.
 
26
;;;;
 
27
 
 
28
(define-module (oop goops active-slot)
 
29
  :use-module (oop goops internal)
 
30
  :export (<active-class>))
 
31
 
 
32
(define-class <active-class> (<class>))
 
33
 
 
34
(define-method (compute-get-n-set (class <active-class>) slot)
 
35
  (if (eq? (slot-definition-allocation slot) #:active)
 
36
      (let* ((index       (slot-ref class 'nfields))
 
37
             (name        (car slot))
 
38
             (s           (cdr slot))
 
39
             (env         (class-environment class))
 
40
             (before-ref  (get-keyword #:before-slot-ref  s #f))
 
41
             (after-ref   (get-keyword #:after-slot-ref   s #f))
 
42
             (before-set! (get-keyword #:before-slot-set! s #f))
 
43
             (after-set!  (get-keyword #:after-slot-set!  s #f))
 
44
             (unbound     (make-unbound)))
 
45
        (slot-set! class 'nfields (+ index 1))
 
46
        (list (lambda (o)
 
47
                (if before-ref
 
48
                    (if (before-ref o)
 
49
                        (let ((res (%fast-slot-ref o index)))
 
50
                          (and after-ref (not (eqv? res unbound)) (after-ref o))
 
51
                          res)
 
52
                        (make-unbound))
 
53
                    (let ((res (%fast-slot-ref o index)))
 
54
                      (and after-ref (not (eqv? res unbound)) (after-ref o))
 
55
                      res)))
 
56
 
 
57
              (lambda (o v) 
 
58
                (if before-set!
 
59
                    (if (before-set! o v)
 
60
                        (begin
 
61
                          (%fast-slot-set! o index v)
 
62
                          (and after-set! (after-set! o v))))
 
63
                    (begin
 
64
                      (%fast-slot-set! o index v)
 
65
                      (and after-set! (after-set! o v)))))))
 
66
      (next-method)))