Commit | Line | Data |
---|---|---|
9ddacf86 KN |
1 | ; "trnscrpt.scm", transcript functions for Scheme. |
2 | ; Copyright (c) 1992, 1993, 1995 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 | (define transcript:port #f) | |
21 | ||
22 | (define (transcript-on filename) | |
23 | (set! transcript:port (open-output-file filename))) | |
24 | ||
25 | (define (transcript-off) | |
26 | (if (output-port? transcript:port) | |
27 | (close-output-port transcript:port)) | |
28 | (set! transcript:port #f)) | |
29 | ||
30 | (define read-char | |
31 | (let ((read-char read-char) (write-char write-char)) | |
32 | (lambda opt | |
33 | (let ((ans (apply read-char opt))) | |
34 | (cond ((eof-object? ans)) | |
35 | ((output-port? transcript:port) | |
36 | (write-char ans transcript:port))) | |
37 | ans)))) | |
38 | ||
39 | (define read | |
40 | (let ((read read) (write write) (newline newline)) | |
41 | (lambda opt | |
42 | (let ((ans (apply read opt))) | |
43 | (cond ((eof-object? ans)) | |
44 | ((output-port? transcript:port) | |
45 | (write ans transcript:port) | |
46 | (if (eqv? #\newline (apply peek-char opt)) | |
47 | (newline transcript:port)))) | |
48 | ans)))) | |
49 | ||
50 | (define write-char | |
51 | (let ((write-char write-char)) | |
52 | (lambda (obj . opt) | |
53 | (apply write-char obj opt) | |
54 | (if (output-port? transcript:port) | |
55 | (write-char obj transcript:port))))) | |
56 | ||
57 | (define write | |
58 | (let ((write write)) | |
59 | (lambda (obj . opt) | |
60 | (apply write obj opt) | |
61 | (if (output-port? transcript:port) | |
62 | (write obj transcript:port))))) | |
63 | ||
64 | (define display | |
65 | (let ((display display)) | |
66 | (lambda (obj . opt) | |
67 | (apply display obj opt) | |
68 | (if (output-port? transcript:port) | |
69 | (display obj transcript:port))))) | |
70 | ||
71 | (define newline | |
72 | (let ((newline newline)) | |
73 | (lambda opt | |
74 | (apply newline opt) | |
75 | (if (output-port? transcript:port) | |
76 | (newline transcript:port))))) |