#| -*-Scheme-*-

$Id: port.scm,v 1.50 2007/01/09 06:16:53 cph Exp $

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; I/O Ports
;;; package: (runtime port)

(declare (usual-integrations))

;;;; Port type

(define-structure (port-type (type-descriptor <port-type>)
			     (conc-name port-type/)
			     (constructor %make-port-type))
  standard-operations
  custom-operations
  ;; input operations:
  (char-ready? #f read-only #t)
  (read-char #f read-only #t)
  (unread-char #f read-only #t)
  (peek-char #f read-only #t)
  (read-substring #f read-only #t)
  (read-wide-substring #f read-only #t)
  (read-external-substring #f read-only #t)
  ;; output operations:
  (write-char #f read-only #t)
  (write-substring #f read-only #t)
  (write-wide-substring #f read-only #t)
  (write-external-substring #f read-only #t)
  (fresh-line #f read-only #t)
  (line-start? #f read-only #t)
  (flush-output #f read-only #t)
  (discretionary-flush-output #f read-only #t))

(set-record-type-unparser-method! <port-type>
  (lambda (state type)
    ((standard-unparser-method
      (if (port-type/supports-input? type)
	  (if (port-type/supports-output? type)
	      'I/O-PORT-TYPE
	      'INPUT-PORT-TYPE)
	  (if (port-type/supports-output? type)
	      'OUTPUT-PORT-TYPE
	      'PORT-TYPE))
      #f)
     state
     type)))

(define (guarantee-port-type object procedure)
  (if (not (port-type? object))
      (error:wrong-type-argument object "port type" procedure))
  object)

(define-integrable (port-type/supports-input? type)
  (port-type/read-char type))

(define-integrable (port-type/supports-output? type)
  (port-type/write-char type))

(define (input-port-type? object)
  (and (port-type? object)
       (port-type/supports-input? object)
       #t))

(define (output-port-type? object)
  (and (port-type? object)
       (port-type/supports-output? object)
       #t))

(define (i/o-port-type? object)
  (and (port-type? object)
       (port-type/supports-input? object)
       (port-type/supports-output? object)
       #t))

(define (port-type/operation-names type)
  (guarantee-port-type type 'PORT-TYPE/OPERATION-NAMES)
  (append (map car (port-type/standard-operations type))
	  (map car (port-type/custom-operations type))))

(define (port-type/operations type)
  (guarantee-port-type type 'PORT-TYPE/OPERATIONS)
  (append! (map (lambda (entry)
		  (list (car entry) (cdr entry)))
		(port-type/standard-operations type))
	   (map (lambda (entry)
		  (list (car entry) (cdr entry)))
		(port-type/custom-operations type))))

(define (port-type/operation type name)
  (guarantee-port-type type 'PORT-TYPE/OPERATION)
  (let ((entry
	 (or (assq name (port-type/custom-operations type))
	     (assq name (port-type/standard-operations type)))))
    (and entry
	 (cdr entry))))

;;;; Constructors

(define (make-port-type operations type)
  (if (not (list-of-type? operations
	     (lambda (elt)
	       (and (pair? elt)
		    (symbol? (car elt))
		    (pair? (cdr elt))
		    (procedure? (cadr elt))
		    (null? (cddr elt))))))
      (error:wrong-type-argument operations "operations list" 'MAKE-PORT-TYPE))
  (receive (standard-operations custom-operations)
      (parse-operations-list operations type)
    (let ((op
	   (let ((input? (assq 'READ-CHAR standard-operations))
		 (output? (assq 'WRITE-CHAR standard-operations))
		 (cond-op
		  (lambda (flag mapper)
		    (if flag
			mapper
			(lambda (op) op)))))
	     ((cond-op output? provide-output-features)
	      ((cond-op input? provide-input-features)
	       ((cond-op output? provide-default-output-operations)
		((cond-op input? provide-default-input-operations)
		 (lambda (name)
		   (let ((p (assq name standard-operations)))
		     (and p
			  (cdr p)))))))))))
      (%make-port-type standard-operations
		       custom-operations
		       (op 'CHAR-READY?)
		       (op 'READ-CHAR)
		       (op 'UNREAD-CHAR)
		       (op 'PEEK-CHAR)
		       (op 'READ-SUBSTRING)
		       (op 'READ-WIDE-SUBSTRING)
		       (op 'READ-EXTERNAL-SUBSTRING)
		       (op 'WRITE-CHAR)
		       (op 'WRITE-SUBSTRING)
		       (op 'WRITE-WIDE-SUBSTRING)
		       (op 'WRITE-EXTERNAL-SUBSTRING)
		       (op 'FRESH-LINE)
		       (op 'LINE-START?)
		       (op 'FLUSH-OUTPUT)
		       (op 'DISCRETIONARY-FLUSH-OUTPUT)))))

(define (parse-operations-list operations type)
  (parse-operations-list-1
   (if type
       (append operations
	       (delete-matching-items (port-type/operations type)
		 (let ((excluded
			(append
			 (if (assq 'READ-CHAR operations)
			     standard-input-operation-names
			     '())
			 (if (assq 'WRITE-CHAR operations)
			     standard-output-operation-names
			     '()))))
		   (lambda (p)
		     (or (assq (car p) operations)
			 (memq (car p) excluded))))))
       operations)))

(define (parse-operations-list-1 operations)
  (let loop ((operations operations) (standard '()) (custom '()))
    (if (pair? operations)
	(let ((p (cons (caar operations) (cadar operations))))
	  (if (or (memq (caar operations) standard-input-operation-names)
		  (memq (caar operations) standard-output-operation-names))
	      (loop (cdr operations) (cons p standard) custom)
	      (loop (cdr operations) standard (cons p custom))))
	(values (reverse! standard) (reverse! custom)))))

(define standard-input-operation-names
  '(CHAR-READY?
    READ-CHAR
    READ-SUBSTRING
    READ-WIDE-SUBSTRING
    READ-EXTERNAL-SUBSTRING))

(define standard-output-operation-names
  '(WRITE-CHAR
    WRITE-SUBSTRING
    WRITE-WIDE-SUBSTRING
    WRITE-EXTERNAL-SUBSTRING
    FLUSH-OUTPUT
    DISCRETIONARY-FLUSH-OUTPUT))

;;;; Default input operations

(define (provide-default-input-operations op)
  (let ((char-ready? (or (op 'CHAR-READY?) (lambda (port) port #t)))
	(read-char (op 'READ-CHAR)))
    (let ((read-substring
	   (or (op 'READ-SUBSTRING)
	       (lambda (port string start end)
		 (let ((char (read-char port)))
		   (cond ((not char) #f)
			 ((eof-object? char) 0)
			 (else
			  (guarantee-8-bit-char char)
			  (string-set! string start char)
			  (let loop ((index (fix:+ start 1)))
			    (if (and (fix:< index end)
				     (char-ready? port))
				(let ((char (read-char port)))
				  (cond ((or (not char)
					     (eof-object? char))
					 (fix:- index start))
					(else
					 (guarantee-8-bit-char char)
					 (string-set! string index char)
					 (loop (fix:+ index 1)))))
				(fix:- index start)))))))))
	  (read-wide-substring
	   (or (op 'READ-WIDE-SUBSTRING)
	       (lambda (port string start end)
		 (let ((char (read-char port)))
		   (cond ((not char) #f)
			 ((eof-object? char) 0)
			 (else
			  (wide-string-set! string start char)
			  (let loop ((index (fix:+ start 1)))
			    (if (and (fix:< index end)
				     (char-ready? port))
				(let ((char (read-char port)))
				  (if (or (not char) (eof-object? char))
				      (fix:- index start)
				      (begin
					(wide-string-set! string
							  index
							  char)
					(loop (fix:+ index 1)))))
				(fix:- index start))))))))))
      (let ((read-external-substring
	     (or (op 'READ-EXTERNAL-SUBSTRING)
		 (lambda (port string start end)
		   (let ((l (min (- end start) #x1000)))
		     (let ((bounce (make-string l)))
		       (let ((n (read-substring port bounce 0 l)))
			 (if (and n (fix:> n 0))
			     (xsubstring-move! bounce 0 n string start))
			 n)))))))
	(lambda (name)
	  (case name
	    ((CHAR-READY?) char-ready?)
	    ((READ-CHAR) read-char)
	    ((READ-SUBSTRING) read-substring)
	    ((READ-WIDE-SUBSTRING) read-wide-substring)
	    ((READ-EXTERNAL-SUBSTRING) read-external-substring)
	    (else (op name))))))))

;;;; Default output operations

(define (provide-default-output-operations op)
  (let ((write-char (op 'WRITE-CHAR))
	(no-flush (lambda (port) port unspecific)))
    (let ((write-substring
	   (or (op 'WRITE-SUBSTRING)
	       (lambda (port string start end)
		 (let loop ((i start))
		   (if (fix:< i end)
		       (let ((n (write-char port (string-ref string i))))
			 (cond ((not n)
				(and (fix:> i start)
				     (fix:- i start)))
			       ((fix:> n 0) (loop (fix:+ i 1)))
			       (else (fix:- i start))))
		       (fix:- i start))))))
	  (write-wide-substring
	   (or (op 'WRITE-WIDE-SUBSTRING)
	       (lambda (port string start end)
		 (let loop ((i start))
		   (if (fix:< i end)
		       (let ((n
			      (write-char port
					  (wide-string-ref string i))))
			 (cond ((not n)
				(and (fix:> i start)
				     (fix:- i start)))
			       ((fix:> n 0) (loop (fix:+ i 1)))
			       (else (fix:- i start))))
		       (fix:- i start))))))
	  (flush-output (or (op 'FLUSH-OUTPUT) no-flush))
	  (discretionary-flush-output
	   (or (op 'DISCRETIONARY-FLUSH-OUTPUT) no-flush)))
      (let ((write-external-substring
	     (or (op 'WRITE-EXTERNAL-SUBSTRING)
		 (lambda (port string start end)
		   (let ((bounce (make-string #x1000)))
		     (let loop ((i start))
		       (if (< i end)
			   (let ((m (min (- end i) #x1000)))
			     (xsubstring-move! string i (+ i m) bounce 0)
			     (let ((n (write-substring port bounce 0 m)))
			       (cond ((not n) (and (> i start) (- i start)))
				     ((fix:> n 0) (loop (+ i n)))
				     (else (- i start)))))
			   (- end start))))))))
	(lambda (name)
	  (case name
	    ((WRITE-CHAR) write-char)
	    ((WRITE-SUBSTRING) write-substring)
	    ((WRITE-WIDE-SUBSTRING) write-wide-substring)
	    ((WRITE-EXTERNAL-SUBSTRING) write-external-substring)
	    ((FLUSH-OUTPUT) flush-output)
	    ((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output)
	    (else (op name))))))))

;;;; Input features

(define (provide-input-features op)
  (let ((char-ready?
	 (let ((defer (op 'CHAR-READY?)))
	   (lambda (port)
	     (if (port/unread port)
		 #t
		 (defer port)))))
	(read-char
	 (let ((defer (op 'READ-CHAR)))
	   (lambda (port)
	     (let ((char (port/unread port)))
	       (if char
		   (begin
		     (set-port/unread! port #f)
		     char)
		   (let ((char (defer port)))
		     (if (char? char)
			 (transcribe-char char port))
		     char))))))
	(unread-char
	 (lambda (port char)
	   (if (port/unread port)
	       (error "Can't unread second character:" char port))
	   (set-port/unread! port char)
	   unspecific))
	(peek-char
	 (let ((defer (op 'READ-CHAR)))
	   (lambda (port)
	     (or (port/unread port)
		 (let ((char (defer port)))
		   (if (char? char)
		       (begin
			 (set-port/unread! port char)
			 (transcribe-char char port)))
		   char)))))
	(read-substring
	 (let ((defer (op 'READ-SUBSTRING)))
	   (lambda (port string start end)
	     (if (port/unread port)
		 (begin
		   (guarantee-8-bit-char (port/unread port))
		   (string-set! string start (port/unread port))
		   (set-port/unread! port #f)
		   1)
		 (let ((n (defer port string start end)))
		   (if (and n (fix:> n 0))
		       (transcribe-substring string start (fix:+ start n)
					     port))
		   n)))))
	(read-wide-substring
	 (let ((defer (op 'READ-WIDE-SUBSTRING)))
	   (lambda (port string start end)
	     (if (port/unread port)
		 (begin
		   (wide-string-set! string start (port/unread port))
		   (set-port/unread! port #f)
		   1)
		 (let ((n (defer port string start end)))
		   (if (and n (fix:> n 0))
		       (transcribe-substring string start (fix:+ start n)
					     port))
		   n)))))
	(read-external-substring
	 (let ((defer (op 'READ-EXTERNAL-SUBSTRING)))
	   (lambda (port string start end)
	     (if (port/unread port)
		 (begin
		   (guarantee-8-bit-char (port/unread port))
		   (xsubstring-move! (make-string 1 (port/unread port)) 0 1
				     string start)
		   (set-port/unread! port #f)
		   1)
		 (let ((n (defer port string start end)))
		   (if (and n (fix:> n 0))
		       (transcribe-substring string start (+ start n) port))
		   n))))))
    (lambda (name)
      (case name
	((CHAR-READY?) char-ready?)
	((READ-CHAR) read-char)
	((UNREAD-CHAR) unread-char)
	((PEEK-CHAR) peek-char)
	((READ-SUBSTRING) read-substring)
	((READ-WIDE-SUBSTRING) read-wide-substring)
	((READ-EXTERNAL-SUBSTRING) read-external-substring)
	(else (op name))))))

;;;; Output features

(define (provide-output-features op)
  (let ((write-char
	 (let ((defer (op 'WRITE-CHAR)))
	   (lambda (port char)
	     (let ((n (defer port char)))
	       (if (and n (fix:> n 0))
		   (begin
		     (set-port/previous! port char)
		     (transcribe-char char port)))
	       n))))
	(write-substring
	 (let ((defer (op 'WRITE-SUBSTRING)))
	   (lambda (port string start end)
	     (let ((n (defer port string start end)))
	       (if (and n (fix:> n 0))
		   (begin
		     (set-port/previous!
		      port
		      (string-ref string (fix:+ start (fix:- n 1))))
		     (transcribe-substring string start (fix:+ start n) port)))
	       n))))
	(write-wide-substring
	 (let ((defer (op 'WRITE-WIDE-SUBSTRING)))
	   (lambda (port string start end)
	     (let ((n (defer port string start end)))
	       (if (and n (fix:> n 0))
		   (begin
		     (set-port/previous!
		      port
		      (wide-string-ref string (fix:+ start (fix:- n 1))))
		     (transcribe-substring string start (fix:+ start n) port)))
	       n))))
	(write-external-substring
	 (let ((defer (op 'WRITE-EXTERNAL-SUBSTRING)))
	   (lambda (port string start end)
	     (let ((n (defer port string start end)))
	       (if (and n (> n 0))
		   (let ((i (+ start n))
			 (bounce (make-string 1)))
		     (xsubstring-move! string (- i 1) i bounce 0)
		     (set-port/previous! port (string-ref bounce 0))
		     (transcribe-substring string start i port)))
	       n))))
	(flush-output
	 (let ((defer (op 'FLUSH-OUTPUT)))
	   (lambda (port)
	     (defer port)
	     (flush-transcript port))))
	(discretionary-flush-output
	 (let ((defer (op 'DISCRETIONARY-FLUSH-OUTPUT)))
	   (lambda (port)
	     (defer port)
	     (discretionary-flush-transcript port)))))
    (lambda (name)
      (case name
	((WRITE-CHAR) write-char)
	((WRITE-SUBSTRING) write-substring)
	((WRITE-WIDE-SUBSTRING) write-wide-substring)
	((WRITE-EXTERNAL-SUBSTRING) write-external-substring)
	((FRESH-LINE)
	 (lambda (port)
	   (if (and (port/previous port)
		    (not (char=? (port/previous port) #\newline)))
	       (write-char port #\newline)
	       0)))
	((LINE-START?)
	 (lambda (port)
	   (if (port/previous port)
	       (char=? (port/previous port) #\newline)
	       'UNKNOWN)))
	((FLUSH-OUTPUT) flush-output)
	((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output)
	(else (op name))))))

;;;; Port object

(define-structure (port (type-descriptor <port>)
			(conc-name port/)
			(constructor %make-port (%type %state)))
  %type
  %state
  (%thread-mutex (make-thread-mutex))
  (unread #f)
  (previous #f)
  (properties '()))

(define (make-port type state)
  (guarantee-port-type type 'MAKE-PORT)
  (%make-port type state))

(define (port/type port)
  (guarantee-port port 'PORT/TYPE)
  (port/%type port))

(define (set-port/type! port type)
  (guarantee-port port 'SET-PORT/TYPE!)
  (set-port/%type! port type))

(define (port/state port)
  (guarantee-port port 'PORT/STATE)
  (port/%state port))

(define (set-port/state! port state)
  (guarantee-port port 'SET-PORT/STATE!)
  (set-port/%state! port state))

(define (port/thread-mutex port)
  (guarantee-port port 'PORT/THREAD-MUTEX)
  (port/%thread-mutex port))

(define (set-port/thread-mutex! port mutex)
  (set-port/%thread-mutex! port mutex))

(define (port=? p1 p2)
  (guarantee-port p1 'PORT=?)
  (guarantee-port p2 'PORT=?)
  (eq? p1 p2))

(define (port/operation-names port)
  (port-type/operation-names (port/type port)))

(define (port/operation port name)
  (port-type/operation (port/type port) name))

(let-syntax
    ((define-port-operation
       (sc-macro-transformer
	(lambda (form environment)
	  (let ((name (cadr form)))
	    `(DEFINE (,(symbol-append 'PORT/OPERATION/ name) PORT)
	       (,(close-syntax (symbol-append 'PORT-TYPE/ name) environment)
		(PORT/TYPE PORT))))))))
  (define-port-operation char-ready?)
  (define-port-operation read-char)
  (define-port-operation unread-char)
  (define-port-operation peek-char)
  (define-port-operation read-substring)
  (define-port-operation read-wide-substring)
  (define-port-operation read-external-substring)
  (define-port-operation write-char)
  (define-port-operation write-substring)
  (define-port-operation write-wide-substring)
  (define-port-operation write-external-substring)
  (define-port-operation fresh-line)
  (define-port-operation line-start?)
  (define-port-operation flush-output)
  (define-port-operation discretionary-flush-output))

(define (port-position port)
  ((port/operation port 'POSITION) port))

(define (set-port-position! port position)
  ((port/operation port 'SET-POSITION!) port position))

(set-record-type-unparser-method! <port>
  (lambda (state port)
    ((let ((name
	    (cond ((i/o-port? port) 'I/O-PORT)
		  ((input-port? port) 'INPUT-PORT)
		  ((output-port? port) 'OUTPUT-PORT)
		  (else 'PORT))))
       (cond ((port/operation port 'WRITE-SELF)
	      => (lambda (operation)
		   (standard-unparser-method name operation)))
	     ((port/operation port 'PRINT-SELF)
	      => (lambda (operation)
		   (unparser/standard-method name operation)))
	     (else
	      (standard-unparser-method name #f))))
     state
     port)))

(define (port/copy port state)
  (let ((port (copy-record port)))
    (set-port/state! port state)
    (set-port/thread-mutex! port (make-thread-mutex))
    port))

(define (close-port port)
  (let ((close (port/operation port 'CLOSE)))
    (if close
	(close port)
	(begin
	  (close-output-port port)
	  (close-input-port port)))))

(define (close-input-port port)
  (let ((close-input (port/operation port 'CLOSE-INPUT)))
    (if close-input
	(close-input port))))

(define (close-output-port port)
  (let ((close-output (port/operation port 'CLOSE-OUTPUT)))
    (if close-output
	(close-output port))))

(define (port/open? port)
  (let ((open? (port/operation port 'OPEN?)))
    (if open?
	(open? port)
	(and (if (input-port? port) (%input-open? port) #t)
	     (if (output-port? port) (%output-open? port) #t)))))

(define (port/input-open? port)
  (and (input-port? port)
       (%input-open? port)))

(define (%input-open? port)
  (let ((open? (port/operation port 'INPUT-OPEN?)))
    (if open?
	(open? port)
	#t)))

(define (port/output-open? port)
  (and (output-port? port)
       (%output-open? port)))

(define (%output-open? port)
  (let ((open? (port/operation port 'OUTPUT-OPEN?)))
    (if open?
	(open? port)
	#t)))

(define (port/input-channel port)
  (let ((operation (port/operation port 'INPUT-CHANNEL)))
    (and operation
	 (operation port))))

(define (port/output-channel port)
  (let ((operation (port/operation port 'OUTPUT-CHANNEL)))
    (and operation
	 (operation port))))

(define (port/get-property port name default)
  (guarantee-symbol name 'PORT/GET-PROPERTY)
  (let ((p (assq name (port/properties port))))
    (if p
	(cdr p)
	default)))

(define (port/set-property! port name value)
  (guarantee-symbol name 'PORT/SET-PROPERTY!)
  (let ((alist (port/properties port)))
    (let ((p (assq name alist)))
      (if p
	  (set-cdr! p value)
	  (set-port/properties! port (cons (cons name value) alist))))))

(define (port/intern-property! port name get-value)
  (guarantee-symbol name 'PORT/INTERN-PROPERTY!)
  (let ((alist (port/properties port)))
    (let ((p (assq name alist)))
      (if p
	  (cdr p)
	  (let ((value (get-value)))
	    (set-port/properties! port (cons (cons name value) alist))
	    value)))))

(define (port/remove-property! port name)
  (guarantee-symbol name 'PORT/REMOVE-PROPERTY!)
  (set-port/properties! port (del-assq! name (port/properties port))))

(define (port/transcript port)
  (port/get-property port 'TRANSCRIPT #f))

(define (set-port/transcript! port tport)
  (if tport
      (port/set-property! port 'TRANSCRIPT tport)
      (port/remove-property! port 'TRANSCRIPT)))

(define (transcribe-char char port)
  (let ((tport (port/transcript port)))
    (if tport
	(write-char char tport))))

(define (transcribe-substring string start end port)
  (let ((tport (port/transcript port)))
    (if tport
	(write-substring string start end tport))))

(define (flush-transcript port)
  (let ((tport (port/transcript port)))
    (if tport
	(flush-output tport))))

(define (discretionary-flush-transcript port)
  (let ((tport (port/transcript port)))
    (if tport
	(output-port/discretionary-flush tport))))

(define (input-port? object)
  (and (port? object)
       (port-type/supports-input? (port/type object))
       #t))

(define (output-port? object)
  (and (port? object)
       (port-type/supports-output? (port/type object))
       #t))

(define (i/o-port? object)
  (and (port? object)
       (let ((type (port/type object)))
	 (and (port-type/supports-input? type)
	      (port-type/supports-output? type)
	      #t))))

(define-integrable (guarantee-port port caller)
  (if (not (port? port))
      (error:not-port port caller))
  port)

(define (error:not-port port caller)
  (error:wrong-type-argument port "port" caller))

(define-integrable (guarantee-input-port port caller)
  (if (not (input-port? port))
      (error:not-input-port port caller))
  port)

(define (error:not-input-port port caller)
  (error:wrong-type-argument port "input port" caller))

(define-integrable (guarantee-output-port port caller)
  (if (not (output-port? port))
      (error:not-output-port port caller))
  port)

(define (error:not-output-port port caller)
  (error:wrong-type-argument port "output port" caller))

(define-integrable (guarantee-i/o-port port caller)
  (if (not (i/o-port? port))
      (error:not-i/o-port port caller))
  port)

(define (error:not-i/o-port port caller)
  (error:wrong-type-argument port "I/O port" caller))

(define-integrable (guarantee-8-bit-char char)
  (if (fix:>= (char->integer char) #x100)
      (error:not-8-bit-char char)))

(define (port/supports-coding? port)
  (let ((operation (port/operation port 'SUPPORTS-CODING?)))
    (if operation
	(operation port)
	#f)))

(define (port/coding port)
  (let ((operation (port/operation port 'CODING)))
    (if operation
	(operation port)
	'TEXT)))

(define (port/set-coding port name)
  (let ((operation (port/operation port 'SET-CODING)))
    (if operation
	(operation port name))))

(define (port/known-coding? port name)
  (let ((operation (port/operation port 'KNOWN-CODING?)))
    (if operation
	(operation port name)
	(memq name default-codings))))

(define (port/known-codings port)
  (let ((operation (port/operation port 'KNOWN-CODINGS)))
    (if operation
	(operation port)
	(list-copy default-codings))))

(define default-codings
  '(TEXT BINARY))

(define (port/line-ending port)
  (let ((operation (port/operation port 'LINE-ENDING)))
    (if operation
	(operation port)
	'TEXT)))

(define (port/set-line-ending port name)
  (let ((operation (port/operation port 'SET-LINE-ENDING)))
    (if operation
	(operation port name))))

(define (port/known-line-ending? port name)
  (let ((operation (port/operation port 'KNOWN-LINE-ENDING?)))
    (if operation
	(operation port name)
	(memq name default-line-endings))))

(define (port/known-line-endings port)
  (let ((operation (port/operation port 'KNOWN-LINE-ENDINGS)))
    (if operation
	(operation port)
	(list-copy default-line-endings))))

(define default-line-endings
  '(TEXT BINARY NEWLINE))

;;;; Special Operations

(define (port/input-blocking-mode port)
  (let ((operation (port/operation port 'INPUT-BLOCKING-MODE)))
    (if operation
	(operation port)
	#f)))

(define (port/set-input-blocking-mode port mode)
  (let ((operation (port/operation port 'SET-INPUT-BLOCKING-MODE)))
    (if operation
	(operation port mode))))

(define (port/with-input-blocking-mode port mode thunk)
  (bind-mode port 'INPUT-BLOCKING-MODE 'SET-INPUT-BLOCKING-MODE mode thunk))

(define (port/output-blocking-mode port)
  (let ((operation (port/operation port 'OUTPUT-BLOCKING-MODE)))
    (if operation
	(operation port)
	#f)))

(define (port/set-output-blocking-mode port mode)
  (let ((operation (port/operation port 'SET-OUTPUT-BLOCKING-MODE)))
    (if operation
	(operation port mode))))

(define (port/with-output-blocking-mode port mode thunk)
  (bind-mode port 'OUTPUT-BLOCKING-MODE 'SET-OUTPUT-BLOCKING-MODE mode thunk))

(define (port/input-terminal-mode port)
  (let ((operation (port/operation port 'INPUT-TERMINAL-MODE)))
    (if operation
	(operation port)
	#f)))

(define (port/set-input-terminal-mode port mode)
  (let ((operation (port/operation port 'SET-INPUT-TERMINAL-MODE)))
    (if operation
	(operation port mode))))

(define (port/with-input-terminal-mode port mode thunk)
  (bind-mode port 'INPUT-TERMINAL-MODE 'SET-INPUT-TERMINAL-MODE mode thunk))

(define (port/output-terminal-mode port)
  (let ((operation (port/operation port 'OUTPUT-TERMINAL-MODE)))
    (if operation
	(operation port)
	#f)))

(define (port/set-output-terminal-mode port mode)
  (let ((operation (port/operation port 'SET-OUTPUT-TERMINAL-MODE)))
    (if operation
	(operation port mode))))

(define (port/with-output-terminal-mode port mode thunk)
  (bind-mode port 'OUTPUT-TERMINAL-MODE 'SET-OUTPUT-TERMINAL-MODE mode thunk))

(define (bind-mode port read-mode write-mode mode thunk)
  (let ((read-mode (port/operation port read-mode))
	(write-mode (port/operation port write-mode)))
    (if (and read-mode write-mode (read-mode port))
	(let ((outside-mode))
	  (dynamic-wind (lambda ()
			  (set! outside-mode (read-mode port))
			  (write-mode port mode))
			thunk
			(lambda ()
			  (set! mode (read-mode port))
			  (write-mode port outside-mode))))
	(thunk))))

;;;; Standard Ports

(define *current-input-port*)
(define *current-output-port*)
(define *notification-output-port* #f)
(define *trace-output-port* #f)
(define *interaction-i/o-port* #f)

(define (current-input-port)
  (or *current-input-port* (nearest-cmdl/port)))

(define (set-current-input-port! port)
  (set! *current-input-port*
	(guarantee-input-port port 'SET-CURRENT-INPUT-PORT!))
  unspecific)

(define (with-input-from-port port thunk)
  (fluid-let ((*current-input-port*
	       (guarantee-input-port port 'WITH-INPUT-FROM-PORT)))
    (thunk)))

(define (current-output-port)
  (or *current-output-port* (nearest-cmdl/port)))

(define (set-current-output-port! port)
  (set! *current-output-port*
	(guarantee-output-port port 'SET-CURRENT-OUTPUT-PORT!))
  unspecific)

(define (with-output-to-port port thunk)
  (fluid-let ((*current-output-port*
	       (guarantee-output-port port 'WITH-OUTPUT-TO-PORT)))
    (thunk)))

(define (notification-output-port)
  (or *notification-output-port* (nearest-cmdl/port)))

(define (set-notification-output-port! port)
  (set! *notification-output-port*
	(guarantee-output-port port 'SET-NOTIFICATION-OUTPUT-PORT!))
  unspecific)

(define (with-notification-output-port port thunk)
  (fluid-let ((*notification-output-port*
	       (guarantee-output-port port 'WITH-NOTIFICATION-OUTPUT-PORT)))
    (thunk)))

(define (trace-output-port)
  (or *trace-output-port* (nearest-cmdl/port)))

(define (set-trace-output-port! port)
  (set! *trace-output-port*
	(guarantee-output-port port 'SET-TRACE-OUTPUT-PORT!))
  unspecific)

(define (with-trace-output-port port thunk)
  (fluid-let ((*trace-output-port*
	       (guarantee-output-port port 'WITH-TRACE-OUTPUT-PORT)))
    (thunk)))

(define (interaction-i/o-port)
  (or *interaction-i/o-port* (nearest-cmdl/port)))

(define (set-interaction-i/o-port! port)
  (set! *interaction-i/o-port*
	(guarantee-i/o-port port 'SET-INTERACTION-I/O-PORT!))
  unspecific)

(define (with-interaction-i/o-port port thunk)
  (fluid-let ((*interaction-i/o-port*
	       (guarantee-i/o-port port 'WITH-INTERACTION-I/O-PORT)))
    (thunk)))

(define standard-port-accessors
  (list (cons current-input-port set-current-input-port!)
	(cons current-output-port set-current-output-port!)
	(cons notification-output-port set-notification-output-port!)
	(cons trace-output-port set-trace-output-port!)
	(cons interaction-i/o-port set-interaction-i/o-port!)))