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 / genio.scm < prev    next >
Text File  |  1999-02-24  |  11KB  |  293 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: genio.scm,v 1.15 1999/02/24 21:36:33 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. ;;;; Generic I/O Ports
  23. ;;; package: (runtime generic-i/o-port)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (let ((input-operations
  29.      `((BUFFERED-INPUT-CHARS ,operation/buffered-input-chars)
  30.        (CHAR-READY? ,operation/char-ready?)
  31.        (CHARS-REMAINING ,operation/chars-remaining)
  32.        (CLOSE-INPUT ,operation/close-input)
  33.        (DISCARD-CHAR ,operation/discard-char)
  34.        (DISCARD-CHARS ,operation/discard-chars)
  35.        (EOF? ,operation/eof?)
  36.        (INPUT-BLOCKING-MODE ,operation/input-blocking-mode)
  37.        (INPUT-BUFFER-SIZE ,operation/input-buffer-size)
  38.        (INPUT-CHANNEL ,operation/input-channel)
  39.        (INPUT-OPEN? ,operation/input-open?)
  40.        (INPUT-TERMINAL-MODE ,operation/input-terminal-mode)
  41.        (PEEK-CHAR ,operation/peek-char)
  42.        (READ-CHAR ,operation/read-char)
  43.        (READ-STRING ,operation/read-string)
  44.        (READ-SUBSTRING ,operation/read-substring)
  45.        (SET-INPUT-BLOCKING-MODE ,operation/set-input-blocking-mode)
  46.        (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size)
  47.        (SET-INPUT-TERMINAL-MODE ,operation/set-input-terminal-mode)))
  48.     (output-operations
  49.      `((BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars)
  50.        (CLOSE-OUTPUT ,operation/close-output)
  51.        (FLUSH-OUTPUT ,operation/flush-output)
  52.        (FRESH-LINE ,operation/fresh-line)
  53.        (OUTPUT-BLOCKING-MODE ,operation/output-blocking-mode)
  54.        (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size)
  55.        (OUTPUT-CHANNEL ,operation/output-channel)
  56.        (OUTPUT-OPEN? ,operation/output-open?)
  57.        (OUTPUT-TERMINAL-MODE ,operation/output-terminal-mode)
  58.        (SET-OUTPUT-BLOCKING-MODE ,operation/set-output-blocking-mode)
  59.        (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size)
  60.        (SET-OUTPUT-TERMINAL-MODE ,operation/set-output-terminal-mode)
  61.        (WRITE-CHAR ,operation/write-char)
  62.        (WRITE-SUBSTRING ,operation/write-substring)))
  63.     (other-operations
  64.      `((CLOSE ,operation/close)
  65.        (WRITE-SELF ,operation/write-self))))
  66.     (set! generic-input-type
  67.       (make-port-type (append input-operations
  68.                   other-operations)
  69.               #f))
  70.     (set! generic-output-type
  71.       (make-port-type (append output-operations
  72.                   other-operations)
  73.               #f))
  74.     (set! generic-i/o-type
  75.       (make-port-type (append input-operations
  76.                   output-operations
  77.                   other-operations)
  78.               #f)))
  79.   unspecific)
  80.  
  81. (define generic-input-type)
  82. (define generic-output-type)
  83. (define generic-i/o-type)
  84.  
  85. (define (make-generic-input-port input-channel input-buffer-size
  86.                  #!optional line-translation)
  87.   (let ((line-translation
  88.      (if (default-object? line-translation)
  89.          'DEFAULT
  90.          line-translation)))
  91.     (make-generic-port generic-input-type
  92.                (make-input-buffer input-channel
  93.                       input-buffer-size
  94.                       line-translation)
  95.                #f)))
  96.  
  97. (define (make-generic-output-port output-channel output-buffer-size
  98.                   #!optional line-translation)
  99.   (let ((line-translation
  100.      (if (default-object? line-translation)
  101.          'DEFAULT
  102.          line-translation)))
  103.     (make-generic-port generic-output-type
  104.                #f
  105.                (make-output-buffer output-channel
  106.                        output-buffer-size
  107.                        line-translation))))
  108.  
  109. (define (make-generic-i/o-port input-channel output-channel
  110.                    input-buffer-size output-buffer-size
  111.                    #!optional input-line-translation
  112.                    output-line-translation)
  113.   (let ((input-line-translation
  114.      (if (default-object? input-line-translation)
  115.          'DEFAULT
  116.          input-line-translation)))
  117.     (let ((output-line-translation
  118.        (if (default-object? output-line-translation)
  119.            input-line-translation
  120.            output-line-translation)))
  121.       (make-generic-port generic-i/o-type
  122.              (make-input-buffer input-channel
  123.                         input-buffer-size
  124.                         input-line-translation)
  125.              (make-output-buffer output-channel
  126.                          output-buffer-size
  127.                          output-line-translation)))))
  128.  
  129. (define (make-generic-port type input-buffer output-buffer)
  130.   (let ((port (make-port type (vector input-buffer output-buffer))))
  131.     (if input-buffer
  132.     (set-channel-port! (input-buffer/channel input-buffer) port))
  133.     (if output-buffer
  134.     (set-channel-port! (output-buffer/channel output-buffer) port))
  135.     port))
  136.  
  137. (define-integrable (port/input-buffer port)
  138.   (vector-ref (port/state port) 0))
  139.  
  140. (define-integrable (port/output-buffer port)
  141.   (vector-ref (port/state port) 1))
  142.  
  143. (define (operation/write-self port output-port)
  144.   (cond ((i/o-port? port)
  145.      (write-string " for channels: " output-port)
  146.      (write (operation/input-channel port) output-port)
  147.      (write-string " " output-port)
  148.      (write (operation/output-channel port) output-port))
  149.     ((input-port? port)
  150.      (write-string " for channel: " output-port)
  151.      (write (operation/input-channel port) output-port))
  152.     ((output-port? port)
  153.      (write-string " for channel: " output-port)
  154.      (write (operation/output-channel port) output-port))
  155.     (else
  156.      (write-string " for channel" output-port))))
  157.  
  158. (define (operation/char-ready? port interval)
  159.   (input-buffer/char-ready? (port/input-buffer port) interval))
  160.  
  161. (define (operation/chars-remaining port)
  162.   (input-buffer/chars-remaining (port/input-buffer port)))
  163.  
  164. (define (operation/discard-char port)
  165.   (input-buffer/discard-char (port/input-buffer port)))
  166.  
  167. (define (operation/discard-chars port delimiters)
  168.   (input-buffer/discard-until-delimiter (port/input-buffer port) delimiters))
  169.  
  170. (define (operation/eof? port)
  171.   (input-buffer/eof? (port/input-buffer port)))
  172.  
  173. (define (operation/peek-char port)
  174.   (input-buffer/peek-char (port/input-buffer port)))
  175.  
  176. (define (operation/read-char port)
  177.   (input-buffer/read-char (port/input-buffer port)))
  178.  
  179. (define (operation/read-substring port string start end)
  180.   (input-buffer/read-substring (port/input-buffer port) string start end))
  181.  
  182. (define (operation/read-string port delimiters)
  183.   (input-buffer/read-until-delimiter (port/input-buffer port) delimiters))
  184.  
  185. (define (operation/input-buffer-size port)
  186.   (input-buffer/size (port/input-buffer port)))
  187.  
  188. (define (operation/buffered-input-chars port)
  189.   (input-buffer/buffered-chars (port/input-buffer port)))
  190.  
  191. (define (operation/set-input-buffer-size port buffer-size)
  192.   (input-buffer/set-size (port/input-buffer port) buffer-size))
  193.  
  194. (define (operation/input-channel port)
  195.   (input-buffer/channel (port/input-buffer port)))
  196.  
  197. (define (operation/input-blocking-mode port)
  198.   (if (channel-blocking? (operation/input-channel port))
  199.       'BLOCKING
  200.       'NONBLOCKING))
  201.  
  202. (define (operation/set-input-blocking-mode port mode)
  203.   (case mode
  204.     ((BLOCKING) (channel-blocking (operation/input-channel port)))
  205.     ((NONBLOCKING) (channel-nonblocking (operation/input-channel port)))
  206.     (else (error:wrong-type-datum mode "blocking mode"))))
  207.  
  208. (define (operation/input-terminal-mode port)
  209.   (let ((channel (operation/input-channel port)))
  210.     (cond ((not (channel-type=terminal? channel)) #f)
  211.       ((terminal-cooked-input? channel) 'COOKED)
  212.       (else 'RAW))))
  213.  
  214. (define (operation/set-input-terminal-mode port mode)
  215.   (case mode
  216.     ((COOKED) (terminal-cooked-input (operation/input-channel port)))
  217.     ((RAW) (terminal-raw-input (operation/input-channel port)))
  218.     ((#F) unspecific)
  219.     (else (error:wrong-type-datum mode "terminal mode"))))
  220.  
  221. (define (operation/flush-output port)
  222.   (output-buffer/drain-block (port/output-buffer port)))
  223.  
  224. (define (operation/write-char port char)
  225.   (output-buffer/write-char-block (port/output-buffer port) char))
  226.  
  227. (define (operation/write-substring port string start end)
  228.   (output-buffer/write-substring-block (port/output-buffer port)
  229.                        string start end))
  230.  
  231. (define (operation/fresh-line port)
  232.   (if (not (output-buffer/line-start? (port/output-buffer port)))
  233.       (operation/write-char port #\newline)))
  234.  
  235. (define (operation/output-buffer-size port)
  236.   (output-buffer/size (port/output-buffer port)))
  237.  
  238. (define (operation/buffered-output-chars port)
  239.   (output-buffer/buffered-chars (port/output-buffer port)))
  240.  
  241. (define (operation/set-output-buffer-size port buffer-size)
  242.   (output-buffer/set-size (port/output-buffer port) buffer-size))
  243.  
  244. (define (operation/output-channel port)
  245.   (output-buffer/channel (port/output-buffer port)))
  246.  
  247. (define (operation/output-blocking-mode port)
  248.   (if (channel-blocking? (operation/output-channel port))
  249.       'BLOCKING
  250.       'NONBLOCKING))
  251.  
  252. (define (operation/set-output-blocking-mode port mode)
  253.   (case mode
  254.     ((BLOCKING) (channel-blocking (operation/output-channel port)))
  255.     ((NONBLOCKING) (channel-nonblocking (operation/output-channel port)))
  256.     (else (error:wrong-type-datum mode "blocking mode"))))
  257.  
  258. (define (operation/output-terminal-mode port)
  259.   (let ((channel (operation/output-channel port)))
  260.     (cond ((not (channel-type=terminal? channel)) #f)
  261.       ((terminal-cooked-output? channel) 'COOKED)
  262.       (else 'RAW))))
  263.  
  264. (define (operation/set-output-terminal-mode port mode)
  265.   (case mode
  266.     ((COOKED) (terminal-cooked-output (operation/output-channel port)))
  267.     ((RAW) (terminal-raw-output (operation/output-channel port)))
  268.     ((#F) unspecific)
  269.     (else (error:wrong-type-datum mode "terminal mode"))))
  270.  
  271. (define (operation/close port)
  272.   (operation/close-input port)
  273.   (operation/close-output port))
  274.  
  275. (define (operation/close-output port)
  276.   (let ((output-buffer (port/output-buffer port)))
  277.     (if output-buffer
  278.     (output-buffer/close output-buffer (port/input-buffer port)))))
  279.  
  280. (define (operation/close-input port)
  281.   (let ((input-buffer (port/input-buffer port)))
  282.     (if input-buffer
  283.     (input-buffer/close input-buffer (port/output-buffer port)))))
  284.  
  285. (define (operation/output-open? port)
  286.   (let ((output-buffer (port/output-buffer port)))
  287.     (and output-buffer
  288.      (output-buffer/open? output-buffer))))
  289.  
  290. (define (operation/input-open? port)
  291.   (let ((input-buffer (port/input-buffer port)))
  292.     (and input-buffer
  293.      (input-buffer/open? input-buffer))))