Commit | Line | Data |
---|---|---|
6e7d5622 | 1 | ;;;; Copyright (C) 1999, 2000, 2005, 2006 Free Software Foundation, Inc. |
f12de0a1 MD |
2 | ;;;; |
3 | ;;;; This program is free software; you can redistribute it and/or modify | |
4 | ;;;; it under the terms of the GNU General Public License as published by | |
5 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
6 | ;;;; any later version. | |
7 | ;;;; | |
8 | ;;;; This program is distributed in the hope that it will be useful, | |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | ;;;; GNU General Public License for more details. | |
12 | ;;;; | |
13 | ;;;; You should have received a copy of the GNU General Public License | |
14 | ;;;; along with this software; see the file COPYING. If not, write to | |
92205699 MV |
15 | ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
16 | ;;;; Boston, MA 02110-1301 USA | |
f12de0a1 MD |
17 | ;;;; |
18 | \f | |
19 | ||
20 | (define-module (oop goops accessors) | |
21 | :use-module (oop goops) | |
22 | :re-export (standard-define-class) | |
23 | :export (define-class-with-accessors | |
24 | define-class-with-accessors-keywords)) | |
25 | ||
ae9ce4b7 AW |
26 | (define-macro (define-class-with-accessors name supers . slots) |
27 | (let ((eat? #f)) | |
28 | `(standard-define-class | |
29 | ,name ,supers | |
30 | ,@(map-in-order | |
31 | (lambda (slot) | |
32 | (cond (eat? | |
33 | (set! eat? #f) | |
34 | slot) | |
35 | ((keyword? slot) | |
36 | (set! eat? #t) | |
37 | slot) | |
38 | ((pair? slot) | |
39 | (if (get-keyword #:accessor (cdr slot) #f) | |
40 | slot | |
41 | (let ((name (car slot))) | |
42 | `(,name #:accessor ,name ,@(cdr slot))))) | |
43 | (else | |
44 | `(,slot #:accessor ,slot)))) | |
45 | slots)))) | |
f12de0a1 | 46 | |
ae9ce4b7 AW |
47 | (define-macro (define-class-with-accessors-keywords name supers . slots) |
48 | (let ((eat? #f)) | |
49 | `(standard-define-class | |
50 | ,name ,supers | |
51 | ,@(map-in-order | |
52 | (lambda (slot) | |
53 | (cond (eat? | |
54 | (set! eat? #f) | |
55 | slot) | |
56 | ((keyword? slot) | |
57 | (set! eat? #t) | |
58 | slot) | |
59 | ((pair? slot) | |
60 | (let ((slot | |
61 | (if (get-keyword #:accessor (cdr slot) #f) | |
62 | slot | |
63 | (let ((name (car slot))) | |
64 | `(,name #:accessor ,name ,@(cdr slot)))))) | |
65 | (if (get-keyword #:init-keyword (cdr slot) #f) | |
66 | slot | |
67 | (let* ((name (car slot)) | |
68 | (keyword (symbol->keyword name))) | |
69 | `(,name #:init-keyword ,keyword ,@(cdr slot)))))) | |
70 | (else | |
71 | `(,slot #:accessor ,slot | |
72 | #:init-keyword ,(symbol->keyword slot))))) | |
73 | slots)))) |