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 / ttyio.scm < prev    next >
Text File  |  1999-02-24  |  6KB  |  166 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: ttyio.scm,v 1.12 1999/02/24 21:36:08 cph Exp $
  4.  
  5. Copyright (c) 1991-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. ;;;; Console I/O Ports
  23. ;;; package: (runtime console-i/o-port)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define hook/read-char)
  28. (define hook/peek-char)
  29.  
  30. (define (initialize-package!)
  31.   (let ((input-channel (tty-input-channel))
  32.     (output-channel (tty-output-channel)))
  33.     (set! hook/read-char operation/read-char)
  34.     (set! hook/peek-char operation/peek-char)
  35.     (set! the-console-port-type
  36.       (make-port-type
  37.        `((BEEP ,operation/beep)
  38.          (CLEAR ,operation/clear)
  39.          (DISCRETIONARY-FLUSH-OUTPUT ,operation/flush-output)
  40.          (PEEK-CHAR ,(lambda (port) (hook/peek-char port)))
  41.          (READ-CHAR ,(lambda (port) (hook/read-char port)))
  42.          (READ-FINISH ,operation/read-finish)
  43.          (WRITE-SELF ,operation/write-self)
  44.          (X-SIZE ,operation/x-size)
  45.          (Y-SIZE ,operation/y-size))
  46.        generic-i/o-type))
  47.     (set! the-console-port
  48.       (make-port the-console-port-type
  49.              (make-console-port-state
  50.               (make-input-buffer input-channel input-buffer-size)
  51.               (make-output-buffer output-channel output-buffer-size)
  52.               (channel-type=file? input-channel))))
  53.     (set-channel-port! input-channel the-console-port)
  54.     (set-channel-port! output-channel the-console-port))
  55.   (add-event-receiver! event:before-exit save-console-input)
  56.   (add-event-receiver! event:after-restore reset-console)
  57.   (set-console-i/o-port! the-console-port)
  58.   (set-current-input-port! the-console-port)
  59.   (set-current-output-port! the-console-port))
  60.  
  61. (define the-console-port-type)
  62. (define the-console-port)
  63. (define input-buffer-size 512)
  64. (define output-buffer-size 512)
  65.  
  66. (define (save-console-input)
  67.   ((ucode-primitive reload-save-string 1)
  68.    (input-buffer/buffer-contents (port/input-buffer console-input-port))))
  69.  
  70. (define (reset-console)
  71.   (let ((input-channel (tty-input-channel))
  72.     (output-channel (tty-output-channel))
  73.     (state (port/state the-console-port)))
  74.     (set-channel-port! input-channel the-console-port)
  75.     (set-channel-port! output-channel the-console-port)
  76.     (set-console-port-state/input-buffer!
  77.      state
  78.      (let ((buffer
  79.         (make-input-buffer
  80.          input-channel
  81.          (input-buffer/size (console-port-state/input-buffer state)))))
  82.        (let ((contents ((ucode-primitive reload-retrieve-string 0))))
  83.      (if contents
  84.          (input-buffer/set-buffer-contents buffer contents)))
  85.        buffer))
  86.     (set-console-port-state/output-buffer!
  87.      state
  88.      (make-output-buffer
  89.       output-channel
  90.       (output-buffer/size (console-port-state/output-buffer state))))
  91.     (set-console-port-state/echo-input?! state
  92.                      (channel-type=file? input-channel))))
  93.  
  94. (define (set-console-i/o-port! port)
  95.   (if (not (i/o-port? port))
  96.       (error:wrong-type-argument port "I/O port" 'SET-CONSOLE-I/O-PORT!))
  97.   (set! console-i/o-port port)
  98.   (set! console-input-port port)
  99.   (set! console-output-port port)
  100.   unspecific)
  101.  
  102. (define console-i/o-port)
  103. (define console-input-port)
  104. (define console-output-port)
  105.  
  106. (define-structure (console-port-state (type vector)
  107.                       (conc-name console-port-state/))
  108.   ;; First two elements of this vector are required by the generic
  109.   ;; I/O port operations.
  110.   input-buffer
  111.   output-buffer
  112.   echo-input?)
  113.  
  114. (define-integrable (port/input-buffer port)
  115.   (console-port-state/input-buffer (port/state port)))
  116.  
  117. (define-integrable (port/output-buffer port)
  118.   (console-port-state/output-buffer (port/state port)))
  119.  
  120. (define (operation/peek-char port)
  121.   (let ((char (input-buffer/peek-char (port/input-buffer port))))
  122.     (if (eof-object? char)
  123.     (signal-end-of-input port))
  124.     char))
  125.  
  126. (define (operation/read-char port)
  127.   (let ((char (input-buffer/read-char (port/input-buffer port))))
  128.     (if (eof-object? char)
  129.     (signal-end-of-input port))
  130.     (if (and char (console-port-state/echo-input? (port/state port)))
  131.     (output-port/write-char port char))
  132.     char))
  133.  
  134. (define (signal-end-of-input port)
  135.   (fresh-line port)
  136.   (write-string "End of input stream reached" port)
  137.   (%exit))
  138.  
  139. (define (operation/read-finish port)
  140.   (let ((buffer (port/input-buffer port)))
  141.     (let loop ()
  142.       (if (input-buffer/char-ready? buffer 0)
  143.       (let ((char (input-buffer/peek-char buffer)))
  144.         (if (char-whitespace? char)
  145.         (begin
  146.           (operation/read-char port)
  147.           (loop)))))))
  148.   (output-port/discretionary-flush port))
  149.  
  150. (define (operation/clear port)
  151.   (output-port/write-string port ((ucode-primitive tty-command-clear 0))))
  152.  
  153. (define (operation/beep port)
  154.   (output-port/write-string port ((ucode-primitive tty-command-beep 0))))
  155.  
  156. (define (operation/x-size port)
  157.   port
  158.   ((ucode-primitive tty-x-size 0)))
  159.  
  160. (define (operation/y-size port)
  161.   port
  162.   ((ucode-primitive tty-y-size 0)))
  163.  
  164. (define (operation/write-self port output-port)
  165.   port
  166.   (write-string " for console" output-port))