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 / port.scm < prev    next >
Text File  |  2001-02-27  |  23KB  |  713 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: port.scm,v 1.20 2001/02/27 17:20:35 cph Exp $
  4.  
  5. Copyright (c) 1991-2001 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. ;;;; I/O Ports
  23. ;;; package: (runtime port)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-structure (port-type (type-descriptor port-type-rtd)
  28.                  (conc-name port-type/)
  29.                  (constructor %make-port-type (custom-operations)))
  30.   custom-operations
  31.   ;; input operations:
  32.   (char-ready? #f read-only #t)
  33.   (peek-char #f read-only #t)
  34.   (read-char #f read-only #t)
  35.   (discard-char #f read-only #t)
  36.   (read-string #f read-only #t)
  37.   (discard-chars #f read-only #t)
  38.   (read-substring #f read-only #t)
  39.   ;; output operations:
  40.   (write-char #f read-only #t)
  41.   (write-substring #f read-only #t)
  42.   (fresh-line #f read-only #t)
  43.   (flush-output #f read-only #t)
  44.   (discretionary-flush-output #f read-only #t))
  45.  
  46. (set-record-type-unparser-method! port-type-rtd
  47.   (lambda (state type)
  48.     ((standard-unparser-method
  49.       (if (port-type/supports-input? type)
  50.       (if (port-type/supports-output? type)
  51.           'I/O-PORT-TYPE
  52.           'INPUT-PORT-TYPE)
  53.       (if (port-type/supports-output? type)
  54.           'OUTPUT-PORT-TYPE
  55.           'PORT-TYPE))
  56.       #f)
  57.      state
  58.      type)))
  59.  
  60. (define (guarantee-port-type object procedure)
  61.   (if (not (port-type? object))
  62.       (error:wrong-type-argument object "port type" procedure))
  63.   object)
  64.  
  65. (define-integrable (port-type/supports-input? type)
  66.   (port-type/read-char type))
  67.  
  68. (define-integrable (port-type/supports-output? type)
  69.   (port-type/write-char type))
  70.  
  71. (define (input-port-type? object)
  72.   (and (port-type? object)
  73.        (port-type/supports-input? object)
  74.        #t))
  75.  
  76. (define (output-port-type? object)
  77.   (and (port-type? object)
  78.        (port-type/supports-output? object)
  79.        #t))
  80.  
  81. (define (i/o-port-type? object)
  82.   (and (port-type? object)
  83.        (port-type/supports-input? object)
  84.        (port-type/supports-output? object)
  85.        #t))
  86.  
  87. (define input-operation-names
  88.   '(CHAR-READY?
  89.     DISCARD-CHAR
  90.     DISCARD-CHARS
  91.     PEEK-CHAR
  92.     READ-CHAR
  93.     READ-STRING
  94.     READ-SUBSTRING))
  95.  
  96. (define input-operation-accessors
  97.   (map (lambda (name) (record-accessor port-type-rtd name))
  98.        input-operation-names))
  99.  
  100. (define input-operation-modifiers
  101.   (map (lambda (name) (record-modifier port-type-rtd name))
  102.        input-operation-names))
  103.  
  104. (define output-operation-names
  105.   '(DISCRETIONARY-FLUSH-OUTPUT
  106.     FLUSH-OUTPUT
  107.     FRESH-LINE
  108.     WRITE-CHAR
  109.     WRITE-SUBSTRING))
  110.  
  111. (define output-operation-accessors
  112.   (map (lambda (name) (record-accessor port-type-rtd name))
  113.        output-operation-names))
  114.  
  115. (define output-operation-modifiers
  116.   (map (lambda (name) (record-modifier port-type-rtd name))
  117.        output-operation-names))
  118.  
  119. (define (port-type/operation-names type)
  120.   (guarantee-port-type type 'PORT-TYPE/OPERATION-NAMES)
  121.   (append (if (port-type/supports-input? type) input-operation-names '())
  122.       (if (port-type/supports-output? type) output-operation-names '())
  123.       (map car (port-type/custom-operations type))))
  124.  
  125. (define (port-type/operations type)
  126.   (guarantee-port-type type 'PORT-TYPE/OPERATIONS)
  127.   (append (if (port-type/supports-input? type)
  128.           (map (lambda (name accessor)
  129.              (list name (accessor type)))
  130.            input-operation-names
  131.            input-operation-accessors)
  132.           '())
  133.       (if (port-type/supports-output? type)
  134.           (map (lambda (name accessor)
  135.              (list name (accessor type)))
  136.            output-operation-names
  137.            output-operation-accessors)
  138.           '())
  139.       (map (lambda (entry)
  140.          (list (car entry) (cdr entry)))
  141.            (port-type/custom-operations type))))
  142.  
  143. (define (port-type/operation type name)
  144.   (guarantee-port-type type 'PORT-TYPE/OPERATION)
  145.   ;; Optimized for custom operations, since standard operations will
  146.   ;; usually be accessed directly.
  147.   (let ((entry (assq name (port-type/custom-operations type))))
  148.     (if entry
  149.     (cdr entry)
  150.     (let ((accessor
  151.            (letrec ((loop
  152.              (lambda (names accessors)
  153.                (and (pair? names)
  154.                 (if (eq? name (car names))
  155.                     (car accessors)
  156.                     (loop (cdr names) (cdr accessors)))))))
  157.          (or (and (port-type/supports-input? type)
  158.               (loop input-operation-names
  159.                 input-operation-accessors))
  160.              (and (port-type/supports-output? type)
  161.               (loop output-operation-names
  162.                 output-operation-accessors))))))
  163.       (and accessor
  164.            (accessor type))))))
  165.  
  166. (define port-rtd (make-record-type "port" '(TYPE STATE THREAD-MUTEX)))
  167. (define %make-port (record-constructor port-rtd '(TYPE STATE THREAD-MUTEX)))
  168. (define port? (record-predicate port-rtd))
  169. (define port/type (record-accessor port-rtd 'TYPE))
  170. (define %port/state (record-accessor port-rtd 'STATE))
  171. (define port/thread-mutex (record-accessor port-rtd 'THREAD-MUTEX))
  172. (define set-port/thread-mutex! (record-modifier port-rtd 'THREAD-MUTEX))
  173.  
  174. (define (port/state port)
  175.   (%port/state (base-port port)))
  176.  
  177. (define set-port/state!
  178.   (let ((modifier (record-modifier port-rtd 'STATE)))
  179.     (lambda (port state)
  180.       (modifier (base-port port) state))))
  181.  
  182. (define (base-port port)
  183.   (let ((state (%port/state port)))
  184.     (if (encapsulated-port-state? state)
  185.     (base-port (encapsulated-port-state/port state))
  186.     port)))
  187.  
  188. (define (port/operation-names port)
  189.   (port-type/operation-names (port/type port)))
  190.  
  191. (let-syntax ((define-port-operation
  192.            (lambda (dir name)
  193.          `(DEFINE (,(symbol-append dir '-PORT/OPERATION/ name) PORT)
  194.             (,(symbol-append 'PORT-TYPE/ name) (PORT/TYPE PORT))))))
  195.   (define-port-operation input char-ready?)
  196.   (define-port-operation input peek-char)
  197.   (define-port-operation input read-char)
  198.   (define-port-operation input discard-char)
  199.   (define-port-operation input read-string)
  200.   (define-port-operation input discard-chars)
  201.   (define-port-operation input read-substring)
  202.   (define-port-operation output write-char)
  203.   (define-port-operation output write-substring)
  204.   (define-port-operation output fresh-line)
  205.   (define-port-operation output flush-output))
  206.  
  207. (define (output-port/operation/discretionary-flush port)
  208.   (port-type/discretionary-flush-output (port/type port)))
  209.  
  210. (set-record-type-unparser-method! port-rtd
  211.   (lambda (state port)
  212.     ((let ((name
  213.         (cond ((i/o-port? port) 'I/O-PORT)
  214.           ((input-port? port) 'INPUT-PORT)
  215.           ((output-port? port) 'OUTPUT-PORT)
  216.           (else 'PORT))))
  217.        (cond ((port/operation port 'WRITE-SELF)
  218.           => (lambda (operation)
  219.            (standard-unparser-method name operation)))
  220.          ((port/operation port 'PRINT-SELF)
  221.           => (lambda (operation)
  222.            (unparser/standard-method name operation)))
  223.          (else
  224.           (standard-unparser-method name #f))))
  225.      state
  226.      port)))
  227.  
  228. (define (port/copy port state)
  229.   (let ((port (record-copy port)))
  230.     (set-port/state! port state)
  231.     (set-port/thread-mutex! port (make-thread-mutex))
  232.     port))
  233.  
  234. (define (close-port port)
  235.   (let ((close (port/operation port 'CLOSE)))
  236.     (if close
  237.     (close port)
  238.     (begin
  239.       (close-output-port port)
  240.       (close-input-port port)))))
  241.  
  242. (define (close-input-port port)
  243.   (let ((close-input (port/operation port 'CLOSE-INPUT)))
  244.     (if close-input
  245.     (close-input port))))
  246.  
  247. (define (close-output-port port)
  248.   (let ((close-output (port/operation port 'CLOSE-OUTPUT)))
  249.     (if close-output
  250.     (close-output port))))
  251.  
  252. (define (port/input-channel port)
  253.   (let ((operation (port/operation port 'INPUT-CHANNEL)))
  254.     (and operation
  255.      (operation port))))
  256.  
  257. (define (port/output-channel port)
  258.   (let ((operation (port/operation port 'OUTPUT-CHANNEL)))
  259.     (and operation
  260.      (operation port))))
  261.  
  262. (define (port/operation port name)
  263.   (port-type/operation (port/type port) name))
  264.  
  265. (define (input-port/operation port name)
  266.   (port/operation port
  267.           (case name
  268.             ((BUFFER-SIZE) 'INPUT-BUFFER-SIZE)
  269.             ((SET-BUFFER-SIZE) 'SET-INPUT-BUFFER-SIZE)
  270.             ((BUFFERED-CHARS) 'BUFFERED-INPUT-CHARS)
  271.             ((CHANNEL) 'INPUT-CHANNEL)
  272.             (else name))))
  273.  
  274. (define (output-port/operation port name)
  275.   (port/operation port
  276.           (case name
  277.             ((BUFFER-SIZE) 'OUTPUT-BUFFER-SIZE)
  278.             ((SET-BUFFER-SIZE) 'SET-OUTPUT-BUFFER-SIZE)
  279.             ((BUFFERED-CHARS) 'BUFFERED-OUTPUT-CHARS)
  280.             ((CHANNEL) 'OUTPUT-CHANNEL)
  281.             (else name))))
  282.  
  283. (define (input-port? object)
  284.   (and (port? object)
  285.        (port-type/supports-input? (port/type object))))
  286.  
  287. (define (output-port? object)
  288.   (and (port? object)
  289.        (port-type/supports-output? (port/type object))))
  290.  
  291. (define (i/o-port? object)
  292.   (and (port? object)
  293.        (let ((type (port/type object)))
  294.      (and (port-type/supports-input? type)
  295.           (port-type/supports-output? type)))))
  296.  
  297. (define (guarantee-port port)
  298.   (if (not (port? port))
  299.       (error:wrong-type-argument port "port" #f))
  300.   port)
  301.  
  302. (define (guarantee-input-port port)
  303.   (if (not (input-port? port))
  304.       (error:wrong-type-argument port "input port" #f))
  305.   port)
  306.  
  307. (define (guarantee-output-port port)
  308.   (if (not (output-port? port))
  309.       (error:wrong-type-argument port "output port" #f))
  310.   port)
  311.  
  312. (define (guarantee-i/o-port port)
  313.   (if (not (i/o-port? port))
  314.       (error:wrong-type-argument port "I/O port" #f))
  315.   port)
  316.  
  317. ;;;; Encapsulation
  318.  
  319. (define-structure (encapsulated-port-state
  320.            (conc-name encapsulated-port-state/))
  321.   (port #f read-only #t)
  322.   state)
  323.  
  324. (define (encapsulated-port? object)
  325.   (and (port? object)
  326.        (encapsulated-port-state? (%port/state object))))
  327.  
  328. (define (guarantee-encapsulated-port object procedure)
  329.   (guarantee-port object)
  330.   (if (not (encapsulated-port-state? (%port/state object)))
  331.       (error:wrong-type-argument object "encapsulated port" procedure)))
  332.  
  333. (define (encapsulated-port/port port)
  334.   (guarantee-encapsulated-port port 'ENCAPSULATED-PORT/PORT)
  335.   (encapsulated-port-state/port (%port/state port)))
  336.  
  337. (define (encapsulated-port/state port)
  338.   (guarantee-encapsulated-port port 'ENCAPSULATED-PORT/STATE)
  339.   (encapsulated-port-state/state (%port/state port)))
  340.  
  341. (define (set-encapsulated-port/state! port state)
  342.   (guarantee-encapsulated-port port 'SET-ENCAPSULATED-PORT/STATE!)
  343.   (set-encapsulated-port-state/state! (%port/state port) state))
  344.  
  345. (define (make-encapsulated-port port state rewrite-operation)
  346.   (guarantee-port port)
  347.   (%make-port (let ((type (port/type port)))
  348.         (make-port-type
  349.          (append-map
  350.           (lambda (entry)
  351.             (let ((operation
  352.                (rewrite-operation (car entry) (cadr entry))))
  353.               (if operation
  354.               (list (list (car entry) operation))
  355.               '())))
  356.           (port-type/operations type))
  357.          #f))
  358.           (make-encapsulated-port-state port state)
  359.           (port/thread-mutex port)))
  360.  
  361. ;;;; Constructors
  362.  
  363. (define (make-port type state)
  364.   (guarantee-port-type type 'MAKE-PORT)
  365.   (%make-port type state (make-thread-mutex)))
  366.  
  367. (define (make-port-type operations type)
  368.   (let ((type
  369.      (parse-operations-list
  370.       (append operations
  371.           (if type
  372.               (list-transform-negative (port-type/operations type)
  373.             (let ((ignored
  374.                    (append
  375.                 (if (assq 'READ-CHAR operations)
  376.                     '(DISCARD-CHAR
  377.                       DISCARD-CHARS
  378.                       PEEK-CHAR
  379.                       READ-CHAR
  380.                       READ-STRING
  381.                       READ-SUBSTRING)
  382.                     '())
  383.                 (if (or (assq 'WRITE-CHAR operations)
  384.                     (assq 'WRITE-SUBSTRING operations))
  385.                     '(WRITE-CHAR
  386.                       WRITE-SUBSTRING)
  387.                     '()))))
  388.               (lambda (entry)
  389.                 (or (assq (car entry) operations)
  390.                 (memq (car entry) ignored)))))
  391.               '()))
  392.       'MAKE-PORT-TYPE)))
  393.     (let ((operations (port-type/operations type)))
  394.       (let ((input? (assq 'READ-CHAR operations))
  395.         (output?
  396.          (or (assq 'WRITE-CHAR operations)
  397.          (assq 'WRITE-SUBSTRING operations))))
  398.     (if (not (or input? output?))
  399.         (error "Port type must implement one of the following operations:"
  400.            '(READ-CHAR WRITE-CHAR WRITE-SUBSTRING)))
  401.     (install-operations! type input?
  402.                  input-operation-names
  403.                  input-operation-modifiers
  404.                  input-operation-defaults)
  405.     (install-operations! type output?
  406.                  output-operation-names
  407.                  output-operation-modifiers
  408.                  output-operation-defaults)))
  409.     type))
  410.  
  411. (define (parse-operations-list operations procedure)
  412.   (if (not (list? operations))
  413.       (error:wrong-type-argument operations "list" procedure))
  414.   (%make-port-type
  415.    (map (lambda (operation)
  416.       (if (not (and (pair? operation)
  417.             (symbol? (car operation))
  418.             (pair? (cdr operation))
  419.             (procedure? (cadr operation))
  420.             (null? (cddr operation))))
  421.           (error:wrong-type-argument operation "port operation" procedure))
  422.       (cons (car operation) (cadr operation)))
  423.     operations)))
  424.  
  425. (define (install-operations! type install? names modifiers defaults)
  426.   (if install?
  427.       (let* ((operations
  428.           (map (lambda (name)
  429.              (extract-operation! type name))
  430.            names))
  431.          (defaults (defaults names operations)))
  432.     (for-each (lambda (modifier operation name)
  433.             (modifier
  434.              type
  435.              (or operation
  436.              (let ((entry (assq name defaults)))
  437.                (if (not entry)
  438.                    (error "Must specify operation:" name))
  439.                (cadr entry)))))
  440.           modifiers
  441.           operations
  442.           names))
  443.       (begin
  444.     (for-each (lambda (name)
  445.             (if (extract-operation! type name)
  446.             (error "Illegal operation name:" name)))
  447.           names)
  448.     (for-each (lambda (modifier)
  449.             (modifier type #f))
  450.           modifiers))))
  451.  
  452. (define extract-operation!
  453.   (let ((set-port-type/custom-operations!
  454.      (record-modifier port-type-rtd 'CUSTOM-OPERATIONS)))
  455.     (lambda (type name)
  456.       (let ((operation (assq name (port-type/custom-operations type))))
  457.     (and operation
  458.          (begin
  459.            (set-port-type/custom-operations!
  460.         type
  461.         (delq! operation (port-type/custom-operations type)))
  462.            (cdr operation)))))))
  463.  
  464. (define (search-paired-lists key keys datums error?)
  465.   (if (pair? keys)
  466.       (if (eq? key (car keys))
  467.       (car datums)
  468.       (search-paired-lists key (cdr keys) (cdr datums) error?))
  469.       (and error?
  470.        (error "Unable to find key:" key))))
  471.  
  472. ;;;; Default Operations
  473.  
  474. (define (input-operation-defaults names operations)
  475.   `((CHAR-READY? ,default-operation/char-ready?)
  476.     (DISCARD-CHAR ,(search-paired-lists 'READ-CHAR names operations #t))
  477.     (DISCARD-CHARS ,default-operation/discard-chars)
  478.     (READ-STRING ,default-operation/read-string)
  479.     (READ-SUBSTRING ,default-operation/read-substring)))
  480.  
  481. (define (default-operation/char-ready? port interval)
  482.   port interval
  483.   #t)
  484.  
  485. (define (default-operation/read-string port delimiters)
  486.   (let ((peek-char
  487.      (lambda () (let loop () (or (input-port/peek-char port) (loop))))))
  488.     (let ((char (peek-char)))
  489.       (if (eof-object? char)
  490.       char
  491.       (list->string
  492.        (let loop ((char char))
  493.          (if (or (eof-object? char)
  494.              (char-set-member? delimiters char))
  495.          '()
  496.          (begin
  497.            (input-port/discard-char port)
  498.            (cons char (loop (peek-char)))))))))))
  499.  
  500. (define (default-operation/discard-chars port delimiters)
  501.   (let loop ()
  502.     (let ((char (let loop () (or (input-port/peek-char port) (loop)))))
  503.       (if (not (or (eof-object? char)
  504.            (char-set-member? delimiters char)))
  505.       (begin
  506.         (input-port/discard-char port)
  507.         (loop))))))
  508.  
  509. (define (default-operation/read-substring port string start end)
  510.   (let loop ((index start))
  511.     (if (fix:< index end)
  512.     (let ((char (input-port/read-char port)))
  513.       (cond ((not char)
  514.          (if (fix:= index start)
  515.              #f
  516.              (fix:- index start)))
  517.         ((eof-object? char)
  518.          (fix:- index start))
  519.         (else
  520.          (string-set! string index char)
  521.          (loop (fix:+ index 1)))))
  522.     (fix:- index start))))
  523.  
  524. (define (output-operation-defaults names operations)
  525.   (if (not (or (search-paired-lists 'WRITE-CHAR names operations #f)
  526.            (search-paired-lists 'WRITE-SUBSTRING names operations #f)))
  527.       (error "Must specify at least one of the following:"
  528.          '(WRITE-CHAR WRITE-SUBSTRING)))
  529.   `((DISCRETIONARY-FLUSH-OUTPUT ,default-operation/flush-output)
  530.     (FLUSH-OUTPUT ,default-operation/flush-output)
  531.     (FRESH-LINE ,default-operation/fresh-line)
  532.     (WRITE-CHAR ,default-operation/write-char)
  533.     (WRITE-SUBSTRING ,default-operation/write-substring)))
  534.  
  535. (define (default-operation/write-char port char)
  536.   (output-port/write-substring port (string char) 0 1))
  537.  
  538. (define (default-operation/write-substring port string start end)
  539.   (let loop ((index start))
  540.     (if (< index end)
  541.     (begin
  542.       (output-port/write-char port (string-ref string index))
  543.       (loop (+ index 1))))))
  544.  
  545. (define (default-operation/fresh-line port)
  546.   (output-port/write-char port #\newline))
  547.  
  548. (define (default-operation/flush-output port)
  549.   port
  550.   unspecific)
  551.  
  552. ;;;; Special Operations
  553.  
  554. (define (port/input-blocking-mode port)
  555.   (let ((operation (port/operation port 'INPUT-BLOCKING-MODE)))
  556.     (if operation
  557.     (operation port)
  558.     #f)))
  559.  
  560. (define (port/set-input-blocking-mode port mode)
  561.   (let ((operation (port/operation port 'SET-INPUT-BLOCKING-MODE)))
  562.     (if operation
  563.     (operation port mode))))
  564.  
  565. (define (port/with-input-blocking-mode port mode thunk)
  566.   (bind-mode port 'INPUT-BLOCKING-MODE 'SET-INPUT-BLOCKING-MODE mode thunk))
  567.  
  568. (define (port/output-blocking-mode port)
  569.   (let ((operation (port/operation port 'OUTPUT-BLOCKING-MODE)))
  570.     (if operation
  571.     (operation port)
  572.     #f)))
  573.  
  574. (define (port/set-output-blocking-mode port mode)
  575.   (let ((operation (port/operation port 'SET-OUTPUT-BLOCKING-MODE)))
  576.     (if operation
  577.     (operation port mode))))
  578.  
  579. (define (port/with-output-blocking-mode port mode thunk)
  580.   (bind-mode port 'OUTPUT-BLOCKING-MODE 'SET-OUTPUT-BLOCKING-MODE mode thunk))
  581.  
  582. (define (port/input-terminal-mode port)
  583.   (let ((operation (port/operation port 'INPUT-TERMINAL-MODE)))
  584.     (if operation
  585.     (operation port)
  586.     #f)))
  587.  
  588. (define (port/set-input-terminal-mode port mode)
  589.   (let ((operation (port/operation port 'SET-INPUT-TERMINAL-MODE)))
  590.     (if operation
  591.     (operation port mode))))
  592.  
  593. (define (port/with-input-terminal-mode port mode thunk)
  594.   (bind-mode port 'INPUT-TERMINAL-MODE 'SET-INPUT-TERMINAL-MODE mode thunk))
  595.  
  596. (define (port/output-terminal-mode port)
  597.   (let ((operation (port/operation port 'OUTPUT-TERMINAL-MODE)))
  598.     (if operation
  599.     (operation port)
  600.     #f)))
  601.  
  602. (define (port/set-output-terminal-mode port mode)
  603.   (let ((operation (port/operation port 'SET-OUTPUT-TERMINAL-MODE)))
  604.     (if operation
  605.     (operation port mode))))
  606.  
  607. (define (port/with-output-terminal-mode port mode thunk)
  608.   (bind-mode port 'OUTPUT-TERMINAL-MODE 'SET-OUTPUT-TERMINAL-MODE mode thunk))
  609.  
  610. (define (bind-mode port read-mode write-mode mode thunk)
  611.   (let ((read-mode (port/operation port read-mode))
  612.     (write-mode (port/operation port write-mode)))
  613.     (if (and read-mode write-mode (read-mode port))
  614.     (let ((outside-mode))
  615.       (dynamic-wind (lambda ()
  616.               (set! outside-mode (read-mode port))
  617.               (write-mode port mode))
  618.             thunk
  619.             (lambda ()
  620.               (set! mode (read-mode port))
  621.               (write-mode port outside-mode))))
  622.     (thunk))))
  623.  
  624. ;;;; Standard Ports
  625.  
  626. (define *current-input-port*)
  627. (define *current-output-port*)
  628. (define *notification-output-port* #f)
  629. (define *trace-output-port* #f)
  630. (define *interaction-i/o-port* #f)
  631.  
  632. (define (current-input-port)
  633.   (or *current-input-port* (nearest-cmdl/port)))
  634.  
  635. (define (set-current-input-port! port)
  636.   (set! *current-input-port* (guarantee-input-port port))
  637.   unspecific)
  638.  
  639. (define (with-input-from-port port thunk)
  640.   (fluid-let ((*current-input-port* (guarantee-input-port port)))
  641.     (thunk)))
  642.  
  643. (define (current-output-port)
  644.   (or *current-output-port* (nearest-cmdl/port)))
  645.  
  646. (define (set-current-output-port! port)
  647.   (set! *current-output-port* (guarantee-output-port port))
  648.   unspecific)
  649.  
  650. (define (with-output-to-port port thunk)
  651.   (fluid-let ((*current-output-port* (guarantee-output-port port)))
  652.     (thunk)))
  653.  
  654. (define (notification-output-port)
  655.   (or *notification-output-port* (nearest-cmdl/port)))
  656.  
  657. (define (set-notification-output-port! port)
  658.   (set! *notification-output-port* (guarantee-output-port port))
  659.   unspecific)
  660.  
  661. (define (with-notification-output-port port thunk)
  662.   (fluid-let ((*notification-output-port* (guarantee-output-port port)))
  663.     (thunk)))
  664.  
  665. (define (trace-output-port)
  666.   (or *trace-output-port* (nearest-cmdl/port)))
  667.  
  668. (define (set-trace-output-port! port)
  669.   (set! *trace-output-port* (guarantee-output-port port))
  670.   unspecific)
  671.  
  672. (define (with-trace-output-port port thunk)
  673.   (fluid-let ((*trace-output-port* (guarantee-output-port port)))
  674.     (thunk)))
  675.  
  676. (define (interaction-i/o-port)
  677.   (or *interaction-i/o-port* (nearest-cmdl/port)))
  678.  
  679. (define (set-interaction-i/o-port! port)
  680.   (set! *interaction-i/o-port* (guarantee-i/o-port port))
  681.   unspecific)
  682.  
  683. (define (with-interaction-i/o-port port thunk)
  684.   (fluid-let ((*interaction-i/o-port* (guarantee-i/o-port port)))
  685.     (thunk)))
  686.  
  687. (define standard-port-accessors
  688.   (list (cons current-input-port set-current-input-port!)
  689.     (cons current-output-port set-current-output-port!)
  690.     (cons notification-output-port set-notification-output-port!)
  691.     (cons trace-output-port set-trace-output-port!)
  692.     (cons interaction-i/o-port set-interaction-i/o-port!)))
  693.  
  694. ;;;; Upwards Compatibility
  695.  
  696. (define input-port/channel port/input-channel)
  697. (define input-port/copy port/copy)
  698. (define input-port/custom-operation input-port/operation)
  699. (define input-port/operation-names port/operation-names)
  700. (define input-port/state port/state)
  701. (define output-port/channel port/output-channel)
  702. (define output-port/copy port/copy)
  703. (define output-port/custom-operation output-port/operation)
  704. (define output-port/operation-names port/operation-names)
  705. (define output-port/state port/state)
  706. (define set-input-port/state! set-port/state!)
  707. (define set-output-port/state! set-port/state!)
  708.  
  709. (define (make-input-port type state)
  710.   (make-port (if (port-type? type) type (make-port-type type #f)) state))
  711.  
  712. (define make-output-port make-input-port)
  713. (define make-i/o-port make-input-port)