Commit | Line | Data |
---|---|---|
6be07c52 | 1 | ;;; srfi-17.scm --- Generalized set! |
e1633bf3 | 2 | |
1b09b607 | 3 | ;; Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc. |
6be07c52 | 4 | ;; |
73be1d9e MV |
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, | |
6be07c52 TTN |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
73be1d9e MV |
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 | |
92205699 | 17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
6be07c52 TTN |
18 | |
19 | ;;; Author: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> | |
e1633bf3 MG |
20 | |
21 | ;;; Commentary: | |
22 | ||
23 | ;; This is an implementation of SRFI-17: Generalized set! | |
24 | ;; | |
25 | ;; It exports the Guile procedure `make-procedure-with-setter' under | |
26 | ;; the SRFI name `getter-with-setter' and exports the standard | |
27 | ;; procedures `car', `cdr', ..., `cdddr', `string-ref' and | |
28 | ;; `vector-ref' as procedures with setters, as required by the SRFI. | |
29 | ;; | |
30 | ;; SRFI-17 was heavily criticized during its discussion period but it | |
31 | ;; was finalized anyway. One issue was its concept of globally | |
32 | ;; associating setter "properties" with (procedure) values, which is | |
33 | ;; non-Schemy. For this reason, this implementation chooses not to | |
34 | ;; provide a way to set the setter of a procedure. In fact, (set! | |
35 | ;; (setter PROC) SETTER) signals an error. The only way to attach a | |
36 | ;; setter to a procedure is to create a new object (a "procedure with | |
37 | ;; setter") via the `getter-with-setter' procedure. This procedure is | |
38 | ;; also specified in the SRFI. Using it avoids the described | |
39 | ;; problems. | |
6be07c52 TTN |
40 | ;; |
41 | ;; This module is fully documented in the Guile Reference Manual. | |
e1633bf3 MG |
42 | |
43 | ;;; Code: | |
44 | ||
45 | (define-module (srfi srfi-17) | |
d57da08b MD |
46 | :export (getter-with-setter) |
47 | :replace (;; redefined standard procedures | |
48 | setter | |
49 | car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar | |
50 | cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr | |
51 | caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr | |
52 | cdddar cddddr string-ref vector-ref)) | |
e1633bf3 | 53 | |
1b2f40b9 MG |
54 | (cond-expand-provide (current-module) '(srfi-17)) |
55 | ||
e1633bf3 MG |
56 | ;;; Procedures |
57 | ||
58 | (define getter-with-setter make-procedure-with-setter) | |
59 | ||
60 | (define setter | |
61 | (getter-with-setter | |
6aef9d2b | 62 | (@ (guile) setter) |
e1633bf3 MG |
63 | (lambda args |
64 | (error "Setting setters is not supported for a good reason.")))) | |
65 | ||
66 | ;;; Redefine R5RS procedures to appropriate procedures with setters | |
67 | ||
68 | (define (compose-setter setter location) | |
69 | (lambda (obj value) | |
70 | (setter (location obj) value))) | |
71 | ||
6aef9d2b DH |
72 | (define car |
73 | (getter-with-setter (@ (guile) car) | |
74 | set-car!)) | |
75 | (define cdr | |
76 | (getter-with-setter (@ (guile) cdr) | |
77 | set-cdr!)) | |
78 | ||
79 | (define caar | |
80 | (getter-with-setter (@ (guile) caar) | |
81 | (compose-setter set-car! (@ (guile) car)))) | |
82 | (define cadr | |
83 | (getter-with-setter (@ (guile) cadr) | |
84 | (compose-setter set-car! (@ (guile) cdr)))) | |
85 | (define cdar | |
86 | (getter-with-setter (@ (guile) cdar) | |
87 | (compose-setter set-cdr! (@ (guile) car)))) | |
88 | (define cddr | |
89 | (getter-with-setter (@ (guile) cddr) | |
90 | (compose-setter set-cdr! (@ (guile) cdr)))) | |
91 | ||
92 | (define caaar | |
93 | (getter-with-setter (@ (guile) caaar) | |
94 | (compose-setter set-car! (@ (guile) caar)))) | |
95 | (define caadr | |
96 | (getter-with-setter (@ (guile) caadr) | |
97 | (compose-setter set-car! (@ (guile) cadr)))) | |
98 | (define cadar | |
99 | (getter-with-setter (@ (guile) cadar) | |
100 | (compose-setter set-car! (@ (guile) cdar)))) | |
101 | (define caddr | |
102 | (getter-with-setter (@ (guile) caddr) | |
103 | (compose-setter set-car! (@ (guile) cddr)))) | |
104 | (define cdaar | |
105 | (getter-with-setter (@ (guile) cdaar) | |
106 | (compose-setter set-cdr! (@ (guile) caar)))) | |
107 | (define cdadr | |
108 | (getter-with-setter (@ (guile) cdadr) | |
109 | (compose-setter set-cdr! (@ (guile) cadr)))) | |
110 | (define cddar | |
111 | (getter-with-setter (@ (guile) cddar) | |
112 | (compose-setter set-cdr! (@ (guile) cdar)))) | |
113 | (define cdddr | |
114 | (getter-with-setter (@ (guile) cdddr) | |
115 | (compose-setter set-cdr! (@ (guile) cddr)))) | |
116 | ||
117 | (define caaaar | |
118 | (getter-with-setter (@ (guile) caaaar) | |
119 | (compose-setter set-car! (@ (guile) caaar)))) | |
120 | (define caaadr | |
121 | (getter-with-setter (@ (guile) caaadr) | |
122 | (compose-setter set-car! (@ (guile) caadr)))) | |
123 | (define caadar | |
124 | (getter-with-setter (@ (guile) caadar) | |
125 | (compose-setter set-car! (@ (guile) cadar)))) | |
126 | (define caaddr | |
127 | (getter-with-setter (@ (guile) caaddr) | |
128 | (compose-setter set-car! (@ (guile) caddr)))) | |
129 | (define cadaar | |
130 | (getter-with-setter (@ (guile) cadaar) | |
131 | (compose-setter set-car! (@ (guile) cdaar)))) | |
132 | (define cadadr | |
133 | (getter-with-setter (@ (guile) cadadr) | |
134 | (compose-setter set-car! (@ (guile) cdadr)))) | |
135 | (define caddar | |
136 | (getter-with-setter (@ (guile) caddar) | |
137 | (compose-setter set-car! (@ (guile) cddar)))) | |
138 | (define cadddr | |
139 | (getter-with-setter (@ (guile) cadddr) | |
140 | (compose-setter set-car! (@ (guile) cdddr)))) | |
141 | (define cdaaar | |
142 | (getter-with-setter (@ (guile) cdaaar) | |
143 | (compose-setter set-cdr! (@ (guile) caaar)))) | |
144 | (define cdaadr | |
145 | (getter-with-setter (@ (guile) cdaadr) | |
146 | (compose-setter set-cdr! (@ (guile) caadr)))) | |
147 | (define cdadar | |
148 | (getter-with-setter (@ (guile) cdadar) | |
149 | (compose-setter set-cdr! (@ (guile) cadar)))) | |
150 | (define cdaddr | |
151 | (getter-with-setter (@ (guile) cdaddr) | |
152 | (compose-setter set-cdr! (@ (guile) caddr)))) | |
153 | (define cddaar | |
154 | (getter-with-setter (@ (guile) cddaar) | |
155 | (compose-setter set-cdr! (@ (guile) cdaar)))) | |
156 | (define cddadr | |
157 | (getter-with-setter (@ (guile) cddadr) | |
158 | (compose-setter set-cdr! (@ (guile) cdadr)))) | |
159 | (define cdddar | |
160 | (getter-with-setter (@ (guile) cdddar) | |
161 | (compose-setter set-cdr! (@ (guile) cddar)))) | |
162 | (define cddddr | |
163 | (getter-with-setter (@ (guile) cddddr) | |
164 | (compose-setter set-cdr! (@ (guile) cdddr)))) | |
165 | ||
166 | (define string-ref | |
167 | (getter-with-setter (@ (guile) string-ref) | |
168 | string-set!)) | |
169 | ||
170 | (define vector-ref | |
171 | (getter-with-setter (@ (guile) vector-ref) | |
172 | vector-set!)) | |
6be07c52 TTN |
173 | |
174 | ;;; srfi-17.scm ends here |