Commit | Line | Data |
---|---|---|
9ddacf86 KN |
1 | ; "withfile.scm", with-input-from-file and with-output-to-file for Scheme |
2 | ; Copyright (c) 1992, 1993 Aubrey Jaffer | |
3 | ;; | |
4 | ;Permission to copy this software, to redistribute it, and to use it | |
5 | ;for any purpose is granted, subject to the following restrictions and | |
6 | ;understandings. | |
7 | ; | |
8 | ;1. Any copy made of this software must include this copyright notice | |
9 | ;in full. | |
10 | ; | |
11 | ;2. I have made no warrantee or representation that the operation of | |
12 | ;this software will be error-free, and I am under no obligation to | |
13 | ;provide any services, by way of maintenance, update, or otherwise. | |
14 | ; | |
15 | ;3. In conjunction with products arising from the use of this | |
16 | ;material, there shall be no use of my name in any advertising, | |
17 | ;promotional, or sales literature without prior written consent in | |
18 | ;each case. | |
19 | ||
20 | (require 'dynamic-wind) | |
21 | ||
22 | (define withfile:current-input (current-input-port)) | |
23 | (define withfile:current-output (current-output-port)) | |
24 | ||
25 | (define (current-input-port) withfile:current-input) | |
26 | (define (current-output-port) withfile:current-output) | |
27 | ||
28 | (define (with-input-from-file file thunk) | |
29 | (define oport withfile:current-input) | |
30 | (define port (open-input-file file)) | |
31 | (dynamic-wind (lambda () (set! oport withfile:current-input) | |
32 | (set! withfile:current-input port)) | |
33 | (lambda() (let ((ans (thunk))) (close-input-port port) ans)) | |
34 | (lambda() (set! withfile:current-input oport)))) | |
35 | ||
36 | (define (with-output-from-file file thunk) | |
37 | (define oport withfile:current-output) | |
38 | (define port (open-output-file file)) | |
39 | (dynamic-wind (lambda() (set! oport withfile:current-output) | |
40 | (set! withfile:current-output port)) | |
41 | (lambda() (let ((ans (thunk))) (close-output-port port) ans)) | |
42 | (lambda() (set! withfile:current-output oport)))) | |
43 | ||
44 | (define peek-char | |
45 | (let ((peek-char peek-char)) | |
46 | (lambda opt | |
47 | (peek-char (if (null? opt) withfile:current-input (car opt)))))) | |
48 | ||
49 | (define read-char | |
50 | (let ((read-char read-char)) | |
51 | (lambda opt | |
52 | (read-char (if (null? opt) withfile:current-input (car opt)))))) | |
53 | ||
54 | (define read | |
55 | (let ((read read)) | |
56 | (lambda opt | |
57 | (read (if (null? opt) withfile:current-input (car opt)))))) | |
58 | ||
59 | (define write-char | |
60 | (let ((write-char write-char)) | |
61 | (lambda (obj . opt) | |
62 | (write-char obj (if (null? opt) withfile:current-output (car opt)))))) | |
63 | ||
64 | (define write | |
65 | (let ((write write)) | |
66 | (lambda (obj . opt) | |
67 | (write obj (if (null? opt) withfile:current-output (car opt)))))) | |
68 | ||
69 | (define display | |
70 | (let ((display display)) | |
71 | (lambda (obj . opt) | |
72 | (display obj (if (null? opt) withfile:current-output (car opt)))))) | |
73 | ||
74 | (define newline | |
75 | (let ((newline newline)) | |
76 | (lambda opt | |
77 | (newline (if (null? opt) withfile:current-output (car opt)))))) | |
78 | ||
79 | (define force-output | |
80 | (let ((force-output force-output)) | |
81 | (lambda opt | |
82 | (force-output (if (null? opt) withfile:current-output (car opt)))))) |