home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / tscript.scm < prev    next >
Text File  |  1999-06-20  |  4KB  |  112 lines
  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)