Commit | Line | Data |
---|---|---|
6be07c52 | 1 | ;;; srfi-17.scm --- Generalized set! |
e1633bf3 | 2 | |
d57da08b | 3 | ;; Copyright (C) 2001, 2002, 2003 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 | |
17 | ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 | |
62 | setter | |
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 | ||
72 | (define car (getter-with-setter car set-car!)) | |
73 | (define cdr (getter-with-setter cdr set-cdr!)) | |
74 | (define caar (getter-with-setter caar (compose-setter set-car! car))) | |
75 | (define cadr (getter-with-setter cadr (compose-setter set-car! cdr))) | |
76 | (define cdar (getter-with-setter cdar (compose-setter set-cdr! car))) | |
77 | (define cddr (getter-with-setter cddr (compose-setter set-cdr! cdr))) | |
78 | (define caaar (getter-with-setter caaar (compose-setter set-car! caar))) | |
79 | (define caadr (getter-with-setter caadr (compose-setter set-car! cadr))) | |
80 | (define cadar (getter-with-setter cadar (compose-setter set-car! cdar))) | |
81 | (define caddr (getter-with-setter caddr (compose-setter set-car! cddr))) | |
82 | (define cdaar (getter-with-setter cdaar (compose-setter set-cdr! caar))) | |
83 | (define cdadr (getter-with-setter cdadr (compose-setter set-cdr! cadr))) | |
84 | (define cddar (getter-with-setter cddar (compose-setter set-cdr! cdar))) | |
85 | (define cdddr (getter-with-setter cdddr (compose-setter set-cdr! cddr))) | |
86 | (define caaaar (getter-with-setter caaaar (compose-setter set-car! caaar))) | |
87 | (define caaadr (getter-with-setter caaadr (compose-setter set-car! caadr))) | |
88 | (define caadar (getter-with-setter caadar (compose-setter set-car! cadar))) | |
89 | (define caaddr (getter-with-setter caaddr (compose-setter set-car! caddr))) | |
90 | (define cadaar (getter-with-setter cadaar (compose-setter set-car! cdaar))) | |
91 | (define cadadr (getter-with-setter cadadr (compose-setter set-car! cdadr))) | |
92 | (define caddar (getter-with-setter caddar (compose-setter set-car! cddar))) | |
93 | (define cadddr (getter-with-setter cadddr (compose-setter set-car! cdddr))) | |
94 | (define cdaaar (getter-with-setter cdaaar (compose-setter set-cdr! caaar))) | |
95 | (define cdaadr (getter-with-setter cdaadr (compose-setter set-cdr! caadr))) | |
96 | (define cdadar (getter-with-setter cdadar (compose-setter set-cdr! cadar))) | |
97 | (define cdaddr (getter-with-setter cdaddr (compose-setter set-cdr! caddr))) | |
98 | (define cddaar (getter-with-setter cddaar (compose-setter set-cdr! cdaar))) | |
99 | (define cddadr (getter-with-setter cddadr (compose-setter set-cdr! cdadr))) | |
100 | (define cdddar (getter-with-setter cdddar (compose-setter set-cdr! cddar))) | |
101 | (define cddddr (getter-with-setter cddddr (compose-setter set-cdr! cdddr))) | |
102 | (define string-ref (getter-with-setter string-ref string-set!)) | |
103 | (define vector-ref (getter-with-setter vector-ref vector-set!)) | |
6be07c52 TTN |
104 | |
105 | ;;; srfi-17.scm ends here |