Commit | Line | Data |
---|---|---|
98c27b65 JB |
1 | ;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant |
2 | ;;;; Jim Blandy <jimb@cyclic.com> --- October 1996 | |
3 | ||
1fa0fde4 | 4 | ;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 2010, 2011, 2012 Free Software Foundation, Inc. |
98c27b65 | 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. |
98c27b65 | 10 | ;;;; |
73be1d9e | 11 | ;;;; This library is distributed in the hope that it will be useful, |
98c27b65 | 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. | |
98c27b65 | 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 |
98c27b65 | 19 | |
9c35c579 AW |
20 | (eval-when (compile) |
21 | (set-current-module (resolve-module '(guile)))) | |
22 | ||
98c27b65 JB |
23 | \f |
24 | ;;;; apply and call-with-current-continuation | |
25 | ||
d69531e2 AW |
26 | ;;; The deal with these is that they are the procedural wrappers around the |
27 | ;;; primitives of Guile's language. There are about 20 different kinds of | |
28 | ;;; expression in Guile, and e.g. @apply is one of them. (It has to be that way | |
29 | ;;; to preserve tail recursion.) | |
30 | ;;; | |
31 | ;;; Usually we recognize (apply foo bar) to be an instance of @apply, but in the | |
32 | ;;; case that apply is passed to apply, or we're bootstrapping, we need a | |
33 | ;;; trampoline -- and here they are. | |
34 | (define (apply fun . args) | |
35 | (@apply fun (apply:nconc2last args))) | |
98c27b65 JB |
36 | (define (call-with-current-continuation proc) |
37 | (@call-with-current-continuation proc)) | |
218da2b9 MV |
38 | (define (call-with-values producer consumer) |
39 | (@call-with-values producer consumer)) | |
d69531e2 AW |
40 | (define (dynamic-wind in thunk out) |
41 | "All three arguments must be 0-argument procedures. | |
91a214eb BT |
42 | Guard @var{in} is called, then @var{thunk}, then |
43 | guard @var{out}. | |
d69531e2 AW |
44 | |
45 | If, any time during the execution of @var{thunk}, the | |
46 | continuation of the @code{dynamic_wind} expression is escaped | |
91a214eb BT |
47 | non-locally, @var{out} is called. If the continuation of |
48 | the dynamic-wind is re-entered, @var{in} is called. Thus | |
49 | @var{in} and @var{out} may be called any number of | |
d69531e2 AW |
50 | times. |
51 | @lisp | |
52 | (define x 'normal-binding) | |
53 | @result{} x | |
54 | (define a-cont | |
55 | (call-with-current-continuation | |
56 | (lambda (escape) | |
57 | (let ((old-x x)) | |
58 | (dynamic-wind | |
59 | ;; in-guard: | |
60 | ;; | |
61 | (lambda () (set! x 'special-binding)) | |
62 | ||
63 | ;; thunk | |
64 | ;; | |
65 | (lambda () (display x) (newline) | |
66 | (call-with-current-continuation escape) | |
67 | (display x) (newline) | |
68 | x) | |
69 | ||
70 | ;; out-guard: | |
71 | ;; | |
72 | (lambda () (set! x old-x))))))) | |
73 | ||
74 | ;; Prints: | |
75 | special-binding | |
76 | ;; Evaluates to: | |
77 | @result{} a-cont | |
78 | x | |
79 | @result{} normal-binding | |
80 | (a-cont #f) | |
81 | ;; Prints: | |
82 | special-binding | |
83 | ;; Evaluates to: | |
84 | @result{} a-cont ;; the value of the (define a-cont...) | |
85 | x | |
86 | @result{} normal-binding | |
87 | a-cont | |
88 | @result{} special-binding | |
89 | @end lisp" | |
90 | (@dynamic-wind in (thunk) out)) | |
98c27b65 JB |
91 | |
92 | \f | |
93 | ;;;; Basic Port Code | |
94 | ||
95 | ;;; Specifically, the parts of the low-level port code that are written in | |
96 | ;;; Scheme rather than C. | |
97 | ;;; | |
98 | ;;; WARNING: the parts of this interface that refer to file ports | |
99 | ;;; are going away. It would be gone already except that it is used | |
100 | ;;; "internally" in a few places. | |
101 | ||
102 | ||
670600bd JB |
103 | ;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the |
104 | ;;; proper mode to open files in. | |
105 | ;;; | |
106 | ;;; If we want to support systems that do CRLF->LF translation, like | |
107 | ;;; Windows, then we should have a symbol in scmconfig.h made visible | |
108 | ;;; to the Scheme level that we can test here, and autoconf magic to | |
109 | ;;; #define it when appropriate. Windows will probably just have a | |
110 | ;;; hand-generated scmconfig.h file. | |
111 | (define OPEN_READ "r") | |
112 | (define OPEN_WRITE "w") | |
113 | (define OPEN_BOTH "r+") | |
98c27b65 JB |
114 | |
115 | (define *null-device* "/dev/null") | |
116 | ||
117 | (define (open-input-file str) | |
e3d8af60 GB |
118 | "Takes a string naming an existing file and returns an input port |
119 | capable of delivering characters from the file. If the file | |
120 | cannot be opened, an error is signalled." | |
98c27b65 JB |
121 | (open-file str OPEN_READ)) |
122 | ||
123 | (define (open-output-file str) | |
e3d8af60 GB |
124 | "Takes a string naming an output file to be created and returns an |
125 | output port capable of writing characters to a new file by that | |
126 | name. If the file cannot be opened, an error is signalled. If a | |
127 | file with the given name already exists, the effect is unspecified." | |
98c27b65 JB |
128 | (open-file str OPEN_WRITE)) |
129 | ||
e3d8af60 GB |
130 | (define (open-io-file str) |
131 | "Open file with name STR for both input and output." | |
132 | (open-file str OPEN_BOTH)) | |
133 | ||
98c27b65 | 134 | (define (call-with-input-file str proc) |
e3d8af60 GB |
135 | "PROC should be a procedure of one argument, and STR should be a |
136 | string naming a file. The file must | |
137 | already exist. These procedures call PROC | |
138 | with one argument: the port obtained by opening the named file for | |
139 | input or output. If the file cannot be opened, an error is | |
140 | signalled. If the procedure returns, then the port is closed | |
7ff0f239 | 141 | automatically and the values yielded by the procedure are returned. |
e3d8af60 GB |
142 | If the procedure does not return, then the port will not be closed |
143 | automatically unless it is possible to prove that the port will | |
144 | never again be used for a read or write operation." | |
7ff0f239 DL |
145 | (let ((p (open-input-file str))) |
146 | (call-with-values | |
147 | (lambda () (proc p)) | |
148 | (lambda vals | |
149 | (close-input-port p) | |
150 | (apply values vals))))) | |
98c27b65 JB |
151 | |
152 | (define (call-with-output-file str proc) | |
e3d8af60 GB |
153 | "PROC should be a procedure of one argument, and STR should be a |
154 | string naming a file. The behaviour is unspecified if the file | |
155 | already exists. These procedures call PROC | |
156 | with one argument: the port obtained by opening the named file for | |
157 | input or output. If the file cannot be opened, an error is | |
158 | signalled. If the procedure returns, then the port is closed | |
7ff0f239 | 159 | automatically and the values yielded by the procedure are returned. |
e3d8af60 GB |
160 | If the procedure does not return, then the port will not be closed |
161 | automatically unless it is possible to prove that the port will | |
162 | never again be used for a read or write operation." | |
7ff0f239 DL |
163 | (let ((p (open-output-file str))) |
164 | (call-with-values | |
165 | (lambda () (proc p)) | |
166 | (lambda vals | |
167 | (close-output-port p) | |
168 | (apply values vals))))) | |
98c27b65 JB |
169 | |
170 | (define (with-input-from-port port thunk) | |
171 | (let* ((swaports (lambda () (set! port (set-current-input-port port))))) | |
172 | (dynamic-wind swaports thunk swaports))) | |
173 | ||
174 | (define (with-output-to-port port thunk) | |
175 | (let* ((swaports (lambda () (set! port (set-current-output-port port))))) | |
176 | (dynamic-wind swaports thunk swaports))) | |
177 | ||
178 | (define (with-error-to-port port thunk) | |
179 | (let* ((swaports (lambda () (set! port (set-current-error-port port))))) | |
180 | (dynamic-wind swaports thunk swaports))) | |
181 | ||
182 | (define (with-input-from-file file thunk) | |
e3d8af60 GB |
183 | "THUNK must be a procedure of no arguments, and FILE must be a |
184 | string naming a file. The file must already exist. The file is opened for | |
185 | input, an input port connected to it is made | |
186 | the default value returned by `current-input-port', | |
187 | and the THUNK is called with no arguments. | |
188 | When the THUNK returns, the port is closed and the previous | |
7ff0f239 | 189 | default is restored. Returns the values yielded by THUNK. If an |
e3d8af60 GB |
190 | escape procedure is used to escape from the continuation of these |
191 | procedures, their behavior is implementation dependent." | |
7ff0f239 DL |
192 | (call-with-input-file file |
193 | (lambda (p) (with-input-from-port p thunk)))) | |
98c27b65 JB |
194 | |
195 | (define (with-output-to-file file thunk) | |
e3d8af60 GB |
196 | "THUNK must be a procedure of no arguments, and FILE must be a |
197 | string naming a file. The effect is unspecified if the file already exists. | |
198 | The file is opened for output, an output port connected to it is made | |
199 | the default value returned by `current-output-port', | |
200 | and the THUNK is called with no arguments. | |
201 | When the THUNK returns, the port is closed and the previous | |
7ff0f239 | 202 | default is restored. Returns the values yielded by THUNK. If an |
e3d8af60 GB |
203 | escape procedure is used to escape from the continuation of these |
204 | procedures, their behavior is implementation dependent." | |
7ff0f239 DL |
205 | (call-with-output-file file |
206 | (lambda (p) (with-output-to-port p thunk)))) | |
98c27b65 JB |
207 | |
208 | (define (with-error-to-file file thunk) | |
e3d8af60 GB |
209 | "THUNK must be a procedure of no arguments, and FILE must be a |
210 | string naming a file. The effect is unspecified if the file already exists. | |
211 | The file is opened for output, an output port connected to it is made | |
212 | the default value returned by `current-error-port', | |
213 | and the THUNK is called with no arguments. | |
214 | When the THUNK returns, the port is closed and the previous | |
7ff0f239 | 215 | default is restored. Returns the values yielded by THUNK. If an |
e3d8af60 GB |
216 | escape procedure is used to escape from the continuation of these |
217 | procedures, their behavior is implementation dependent." | |
7ff0f239 DL |
218 | (call-with-output-file file |
219 | (lambda (p) (with-error-to-port p thunk)))) | |
98c27b65 JB |
220 | |
221 | (define (with-input-from-string string thunk) | |
e3d8af60 GB |
222 | "THUNK must be a procedure of no arguments. |
223 | The test of STRING is opened for | |
224 | input, an input port connected to it is made, | |
225 | and the THUNK is called with no arguments. | |
226 | When the THUNK returns, the port is closed. | |
7ff0f239 | 227 | Returns the values yielded by THUNK. If an |
e3d8af60 GB |
228 | escape procedure is used to escape from the continuation of these |
229 | procedures, their behavior is implementation dependent." | |
98c27b65 JB |
230 | (call-with-input-string string |
231 | (lambda (p) (with-input-from-port p thunk)))) | |
232 | ||
233 | (define (with-output-to-string thunk) | |
e3d8af60 | 234 | "Calls THUNK and returns its output as a string." |
98c27b65 JB |
235 | (call-with-output-string |
236 | (lambda (p) (with-output-to-port p thunk)))) | |
237 | ||
238 | (define (with-error-to-string thunk) | |
e3d8af60 | 239 | "Calls THUNK and returns its error output as a string." |
98c27b65 JB |
240 | (call-with-output-string |
241 | (lambda (p) (with-error-to-port p thunk)))) | |
242 | ||
243 | (define the-eof-object (call-with-input-string "" (lambda (p) (read-char p)))) |