← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/runtime/tscript.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
Import upstream version 7.7.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/runtime/tscript.scm
 
1
#| -*-Scheme-*-
 
2
 
 
3
$Id: tscript.scm,v 1.4 1999/06/21 03:46:49 cph Exp $
 
4
 
 
5
Copyright (c) 1990, 1999 Massachusetts Institute of Technology
 
6
 
 
7
This program is free software; you can redistribute it and/or modify
 
8
it under the terms of the GNU General Public License as published by
 
9
the Free Software Foundation; either version 2 of the License, or (at
 
10
your option) any later version.
 
11
 
 
12
This program is distributed in the hope that it will be useful, but
 
13
WITHOUT ANY WARRANTY; without even the implied warranty of
 
14
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
15
General Public License for more details.
 
16
 
 
17
You should have received a copy of the GNU General Public License
 
18
along with this program; if not, write to the Free Software
 
19
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
20
|#
 
21
 
 
22
;;;; Transcript File
 
23
;;; package: (runtime transcript)
 
24
 
 
25
(declare (usual-integrations))
 
26
 
 
27
(define-structure (encap-state
 
28
                   (conc-name encap-state/)
 
29
                   (constructor make-encap-state ()))
 
30
  (transcript-port #f))
 
31
 
 
32
(define (transcriptable-port? object)
 
33
  (and (encapsulated-port? object)
 
34
       (encap-state? (encapsulated-port/state object))))
 
35
 
 
36
(define (encap/tport encap)
 
37
  (encap-state/transcript-port (encapsulated-port/state encap)))
 
38
 
 
39
(define (set-encap/tport! encap tport)
 
40
  (set-encap-state/transcript-port! (encapsulated-port/state encap) tport))
 
41
 
 
42
(define (make-transcriptable-port port)
 
43
  (make-encapsulated-port port (make-encap-state)
 
44
    (lambda (name operation)
 
45
      (let ((entry (assq name duplexed-operations)))
 
46
        (if entry
 
47
            (and (cadr entry)
 
48
                 ((cadr entry) operation))
 
49
            operation)))))
 
50
 
 
51
(define (transcript-on filename)
 
52
  (let ((encap (nearest-cmdl/port)))
 
53
    (if (not (transcriptable-port? encap))
 
54
        (error "Transcript not supported for this REPL."))
 
55
    (if (encap/tport encap)
 
56
        (error "transcript already turned on"))
 
57
    (set-encap/tport! encap (open-output-file filename))))
 
58
 
 
59
(define (transcript-off)
 
60
  (let ((encap (nearest-cmdl/port)))
 
61
    (if (not (transcriptable-port? encap))
 
62
        (error "Transcript not supported for this REPL."))
 
63
    (let ((tport (encap/tport encap)))
 
64
      (if tport
 
65
          (begin
 
66
            (set-encap/tport! encap #f)
 
67
            (close-port tport))))))
 
68
 
 
69
(define duplexed-operations)
 
70
 
 
71
(define (initialize-package!)
 
72
  (set! duplexed-operations
 
73
        (let ((input-char
 
74
               (lambda (operation)
 
75
                 (lambda (encap . arguments)
 
76
                   (let ((char (apply operation encap arguments))
 
77
                         (tport (encap/tport encap)))
 
78
                     (if (and tport (char? char))
 
79
                         (write-char char tport))
 
80
                     char))))
 
81
              (input-expr
 
82
               (lambda (operation)
 
83
                 (lambda (encap . arguments)
 
84
                   (let ((expr (apply operation encap arguments))
 
85
                         (tport (encap/tport encap)))
 
86
                     (if tport
 
87
                         (write expr tport))
 
88
                     expr))))
 
89
              (duplex
 
90
               (lambda (toperation)
 
91
                 (lambda (operation)
 
92
                   (lambda (encap . arguments)
 
93
                     (apply operation encap arguments)
 
94
                     (let ((tport (encap/tport encap)))
 
95
                       (if tport
 
96
                           (apply toperation tport arguments))))))))
 
97
          `((READ-CHAR ,input-char)
 
98
            (PROMPT-FOR-COMMAND-CHAR ,input-char)
 
99
            (PROMPT-FOR-EXPRESSION ,input-expr)
 
100
            (PROMPT-FOR-COMMAND-EXPRESSION ,input-expr)
 
101
            (READ ,input-expr)
 
102
            (DISCARD-CHAR #f)
 
103
            (DISCARD-CHARS #f)
 
104
            (READ-STRING #f)
 
105
            (READ-SUBSTRING #f)
 
106
            (WRITE-CHAR ,(duplex output-port/write-char))
 
107
            (WRITE-SUBSTRING ,(duplex output-port/write-substring))
 
108
            (FRESH-LINE ,(duplex output-port/fresh-line))
 
109
            (FLUSH-OUTPUT ,(duplex output-port/flush-output))
 
110
            (DISCRETIONARY-FLUSH-OUTPUT
 
111
             ,(duplex output-port/discretionary-flush)))))
 
112
  unspecific)
 
 
b'\\ No newline at end of file'