Commit | Line | Data |
---|---|---|
6be07c52 | 1 | ;;; srfi-17.scm --- Generalized set! |
e1633bf3 | 2 | |
6be07c52 TTN |
3 | ;; Copyright (C) 2001, 2002 Free Software Foundation, Inc. |
4 | ;; | |
5 | ;; This program is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU General Public License as | |
7 | ;; published by the Free Software Foundation; either version 2, or | |
8 | ;; (at your option) any later version. | |
9 | ;; | |
10 | ;; This program 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 | ;; General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this software; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
18 | ;; Boston, MA 02111-1307 USA | |
19 | ;; | |
20 | ;; As a special exception, the Free Software Foundation gives permission | |
21 | ;; for additional uses of the text contained in its release of GUILE. | |
22 | ;; | |
23 | ;; The exception is that, if you link the GUILE library with other files | |
24 | ;; to produce an executable, this does not by itself cause the | |
25 | ;; resulting executable to be covered by the GNU General Public License. | |
26 | ;; Your use of that executable is in no way restricted on account of | |
27 | ;; linking the GUILE library code into it. | |
28 | ;; | |
29 | ;; This exception does not however invalidate any other reasons why | |
30 | ;; the executable file might be covered by the GNU General Public License. | |
31 | ;; | |
32 | ;; This exception applies only to the code released by the | |
33 | ;; Free Software Foundation under the name GUILE. If you copy | |
34 | ;; code from other Free Software Foundation releases into a copy of | |
35 | ;; GUILE, as the General Public License permits, the exception does | |
36 | ;; not apply to the code that you add in this way. To avoid misleading | |
37 | ;; anyone as to the status of such modified files, you must delete | |
38 | ;; this exception notice from them. | |
39 | ;; | |
40 | ;; If you write modifications of your own for GUILE, it is your choice | |
41 | ;; whether to permit this exception to apply to your modifications. | |
42 | ;; If you do not wish that, delete this exception notice. | |
43 | ||
44 | ;;; Author: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> | |
e1633bf3 MG |
45 | |
46 | ;;; Commentary: | |
47 | ||
48 | ;; This is an implementation of SRFI-17: Generalized set! | |
49 | ;; | |
50 | ;; It exports the Guile procedure `make-procedure-with-setter' under | |
51 | ;; the SRFI name `getter-with-setter' and exports the standard | |
52 | ;; procedures `car', `cdr', ..., `cdddr', `string-ref' and | |
53 | ;; `vector-ref' as procedures with setters, as required by the SRFI. | |
54 | ;; | |
55 | ;; SRFI-17 was heavily criticized during its discussion period but it | |
56 | ;; was finalized anyway. One issue was its concept of globally | |
57 | ;; associating setter "properties" with (procedure) values, which is | |
58 | ;; non-Schemy. For this reason, this implementation chooses not to | |
59 | ;; provide a way to set the setter of a procedure. In fact, (set! | |
60 | ;; (setter PROC) SETTER) signals an error. The only way to attach a | |
61 | ;; setter to a procedure is to create a new object (a "procedure with | |
62 | ;; setter") via the `getter-with-setter' procedure. This procedure is | |
63 | ;; also specified in the SRFI. Using it avoids the described | |
64 | ;; problems. | |
6be07c52 TTN |
65 | ;; |
66 | ;; This module is fully documented in the Guile Reference Manual. | |
e1633bf3 MG |
67 | |
68 | ;;; Code: | |
69 | ||
70 | (define-module (srfi srfi-17) | |
71 | :export (getter-with-setter | |
72 | setter | |
73 | ;; redefined standard procedures | |
74 | car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar | |
75 | cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr | |
76 | caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr | |
77 | cdddar cddddr string-ref vector-ref)) | |
78 | ||
1b2f40b9 MG |
79 | (cond-expand-provide (current-module) '(srfi-17)) |
80 | ||
e1633bf3 MG |
81 | ;;; Procedures |
82 | ||
83 | (define getter-with-setter make-procedure-with-setter) | |
84 | ||
85 | (define setter | |
86 | (getter-with-setter | |
87 | setter | |
88 | (lambda args | |
89 | (error "Setting setters is not supported for a good reason.")))) | |
90 | ||
91 | ;;; Redefine R5RS procedures to appropriate procedures with setters | |
92 | ||
93 | (define (compose-setter setter location) | |
94 | (lambda (obj value) | |
95 | (setter (location obj) value))) | |
96 | ||
97 | (define car (getter-with-setter car set-car!)) | |
98 | (define cdr (getter-with-setter cdr set-cdr!)) | |
99 | (define caar (getter-with-setter caar (compose-setter set-car! car))) | |
100 | (define cadr (getter-with-setter cadr (compose-setter set-car! cdr))) | |
101 | (define cdar (getter-with-setter cdar (compose-setter set-cdr! car))) | |
102 | (define cddr (getter-with-setter cddr (compose-setter set-cdr! cdr))) | |
103 | (define caaar (getter-with-setter caaar (compose-setter set-car! caar))) | |
104 | (define caadr (getter-with-setter caadr (compose-setter set-car! cadr))) | |
105 | (define cadar (getter-with-setter cadar (compose-setter set-car! cdar))) | |
106 | (define caddr (getter-with-setter caddr (compose-setter set-car! cddr))) | |
107 | (define cdaar (getter-with-setter cdaar (compose-setter set-cdr! caar))) | |
108 | (define cdadr (getter-with-setter cdadr (compose-setter set-cdr! cadr))) | |
109 | (define cddar (getter-with-setter cddar (compose-setter set-cdr! cdar))) | |
110 | (define cdddr (getter-with-setter cdddr (compose-setter set-cdr! cddr))) | |
111 | (define caaaar (getter-with-setter caaaar (compose-setter set-car! caaar))) | |
112 | (define caaadr (getter-with-setter caaadr (compose-setter set-car! caadr))) | |
113 | (define caadar (getter-with-setter caadar (compose-setter set-car! cadar))) | |
114 | (define caaddr (getter-with-setter caaddr (compose-setter set-car! caddr))) | |
115 | (define cadaar (getter-with-setter cadaar (compose-setter set-car! cdaar))) | |
116 | (define cadadr (getter-with-setter cadadr (compose-setter set-car! cdadr))) | |
117 | (define caddar (getter-with-setter caddar (compose-setter set-car! cddar))) | |
118 | (define cadddr (getter-with-setter cadddr (compose-setter set-car! cdddr))) | |
119 | (define cdaaar (getter-with-setter cdaaar (compose-setter set-cdr! caaar))) | |
120 | (define cdaadr (getter-with-setter cdaadr (compose-setter set-cdr! caadr))) | |
121 | (define cdadar (getter-with-setter cdadar (compose-setter set-cdr! cadar))) | |
122 | (define cdaddr (getter-with-setter cdaddr (compose-setter set-cdr! caddr))) | |
123 | (define cddaar (getter-with-setter cddaar (compose-setter set-cdr! cdaar))) | |
124 | (define cddadr (getter-with-setter cddadr (compose-setter set-cdr! cdadr))) | |
125 | (define cdddar (getter-with-setter cdddar (compose-setter set-cdr! cddar))) | |
126 | (define cddddr (getter-with-setter cddddr (compose-setter set-cdr! cdddr))) | |
127 | (define string-ref (getter-with-setter string-ref string-set!)) | |
128 | (define vector-ref (getter-with-setter vector-ref vector-set!)) | |
6be07c52 TTN |
129 | |
130 | ;;; srfi-17.scm ends here |