Commit | Line | Data |
---|---|---|
14f1d9fe MD |
1 | ;;; installed-scm-file |
2 | ||
8906f23d | 3 | ;;;; Copyright (C) 1999, 2001, 2006, 2009, 2015 Free Software Foundation, Inc. |
4ff2133a LC |
4 | ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> |
5 | ;;;; | |
73be1d9e MV |
6 | ;;;; This library is free software; you can redistribute it and/or |
7 | ;;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 9 | ;;;; version 3 of the License, or (at your option) any later version. |
4ff2133a | 10 | ;;;; |
73be1d9e | 11 | ;;;; This library is distributed in the hope that it will be useful, |
14f1d9fe | 12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
14 | ;;;; Lesser General Public License for more details. | |
4ff2133a | 15 | ;;;; |
73be1d9e MV |
16 | ;;;; You should have received a copy of the GNU Lesser General Public |
17 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 18 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
4ff2133a | 19 | ;;;; |
14f1d9fe | 20 | |
4ff2133a | 21 | \f |
14f1d9fe | 22 | ;;;; |
4ff2133a LC |
23 | ;;;; This file was based upon active-slot.stklos from the STk distribution |
24 | ;;;; version 4.0.1 by Erick Gallesio <eg@unice.fr>. | |
14f1d9fe MD |
25 | ;;;; |
26 | ||
27 | (define-module (oop goops active-slot) | |
1a179b03 MD |
28 | :use-module (oop goops internal) |
29 | :export (<active-class>)) | |
14f1d9fe MD |
30 | |
31 | (define-class <active-class> (<class>)) | |
32 | ||
71d540f7 | 33 | (define-method (compute-get-n-set (class <active-class>) slot) |
14f1d9fe MD |
34 | (if (eq? (slot-definition-allocation slot) #:active) |
35 | (let* ((index (slot-ref class 'nfields)) | |
568174d1 | 36 | (s (slot-definition-options slot)) |
14f1d9fe MD |
37 | (before-ref (get-keyword #:before-slot-ref s #f)) |
38 | (after-ref (get-keyword #:after-slot-ref s #f)) | |
39 | (before-set! (get-keyword #:before-slot-set! s #f)) | |
40 | (after-set! (get-keyword #:after-slot-set! s #f)) | |
567a6d1e | 41 | (unbound *unbound*)) |
14f1d9fe MD |
42 | (slot-set! class 'nfields (+ index 1)) |
43 | (list (lambda (o) | |
44 | (if before-ref | |
45 | (if (before-ref o) | |
8906f23d | 46 | (let ((res (struct-ref o index))) |
14f1d9fe MD |
47 | (and after-ref (not (eqv? res unbound)) (after-ref o)) |
48 | res) | |
567a6d1e | 49 | *unbound*) |
8906f23d | 50 | (let ((res (struct-ref o index))) |
14f1d9fe MD |
51 | (and after-ref (not (eqv? res unbound)) (after-ref o)) |
52 | res))) | |
53 | ||
54 | (lambda (o v) | |
55 | (if before-set! | |
56 | (if (before-set! o v) | |
57 | (begin | |
8906f23d | 58 | (struct-set! o index v) |
14f1d9fe MD |
59 | (and after-set! (after-set! o v)))) |
60 | (begin | |
8906f23d | 61 | (struct-set! o index v) |
14f1d9fe MD |
62 | (and after-set! (after-set! o v))))))) |
63 | (next-method))) |