I/O generic functions

[David N Gray <Gray@DSG.csc.ti.com>]

It would be nice if the Common Lisp input and output functions could be
defined in terms of primitives which are generic functions so that users
would have a portable way to create their own streams by defining classes
and methods and have those streams be acceptable to the standard I/O
functions.  This would be especially valuable for supporting the
development of window systems for Common Lisp.
 
It may be too late to include this in the standard, but it would be useful
to at least establish some common practice guidelines to avoid unnecessary
incompatibilities between implementations that will want to do something
like this anyway.  In order to get some discussion started, following is a
preliminary outline showing what might be done.
 
Shown below are a few primitive generic functions which would need to have
methods defined for each stream class, and a few more which the user could
either define himself, or use a default method provided by an included
class.  [This does not yet include non-character streams.] Finally, it
shows how the I/O functions of CLtL could be implemented using these
generic functions.  Note that the Common Lisp I/O functions themselves
cannot be made into generic functions because in nearly every case the
stream argument is optional and thus can't be specialized.  Note also that
the existing generic function PRINT-OBJECT is a higher-level operation
since even when the first argument is just a character or string, it still
needs to format the output in accordance with *PRINT-ESCAPE*.


;;;;	Implementation of Common Lisp I/O routines using generic functions

;;;  Generic functions for primitive input operations that must be defined for each stream.

(defgeneric STREAM-READ-CHAR (stream &optional eof-error-p eof-value))
(defgeneric STREAM-UNREAD-CHAR (stream character))
(defgeneric STREAM-LISTEN (stream))

;;;  Other input operations which can be defaulted by including the following class.

(defclass DEFAULT-INPUT-STREAM (stream) ())
(defgeneric STREAM-READ-CHAR-NO-HANG (stream &optional eof-error-p eof-value)
   (:method ((stream default-input-stream) &optional eof-error-p eof-value)
	     (stream-read-char stream eof-error-p eof-value)))
(defgeneric STREAM-PEEK-CHAR (stream &optional eof-error-p eof-value)
  (:method ((stream default-input-stream) &optional (eof-error-p t) eof-value)
	     (let ((character (stream-read-char stream eof-error-p eof-value)))
		 (unless (eql character eof-value)
		   (stream-unread-char stream character))
		 character)))
(defgeneric STREAM-READ-LINE (stream &optional eof-error-p eof-value)
  (:method ((stream default-input-stream) &optional eof-error-p eof-value)
	     (let ((line (make-array 60 :element-type 'string-char :fill-pointer 0)))
		 (loop (let ((character (stream-read-char stream eof-error-p eof-value)))
			   (if (eql character eof-value)
				 (return (values line eof-value))
			     (if (eql character #\newline)
				   (return (values line nil))
				 (vector-push-extend character line))))))))
(defgeneric STREAM-CLEAR-INPUT (stream)
  (:method ((stream default-input-stream)) nil))
(defgeneric STREAM-CLOSE (stream))
(defmethod STREAM-CLOSE ((stream default-input-stream)) nil) ; or is it T?


;;;  Generic functions for primitive output operations that must be defined for each stream.

(defgeneric STREAM-WRITE-CHAR (stream character))
(defgeneric STREAM-START-LINE-P (stream)) ; returns true if positioned at beginning of line.
(defgeneric STREAM-LINE-COLUMN (stream)) ; returns current column number if meaningful, else nil

;;;  Other output operations which can be defaulted by including the following class.

(defclass DEFAULT-OUTPUT-STREAM (stream) ())

(defgeneric STREAM-WRITE-STRING (stream string &optional start end)
  (:method ((stream default-output-stream) string &optional (start 0) end)
	     (let ((limit (or end (length string))))
		 (do ((i start (1+ i)))
		     ((< i limit))
		   (stream-write-char stream (char string i))))
	     string))
(defgeneric STREAM-TERPRI (stream)
  (:method ((stream default-output-stream))
	     (stream-write-char stream #\newline)
	     nil))
(defgeneric STREAM-FRESH-LINE (stream)
   (:method ((stream default-output-stream))
	       (if (stream-start-line-p stream)
		   nil
		 (progn (stream-terpri stream) t))))

(defgeneric STREAM-FINISH-OUTPUT (stream)
  (:method ((stream default-output-stream)) nil))
(defgeneric STREAM-FORCE-OUTPUT (stream)
  (:method ((stream default-output-stream)) nil))
(defgeneric STREAM-CLEAR-OUTPUT (stream)
  (:method ((stream default-output-stream)) nil))

;; useful for pprint and format ~T
(defgeneric STREAM-ADVANCE-TO-COLUMN (stream column) 
   (:method ((stream default-output-stream) column)
	       (let ((current (stream-line-column stream)))
		  (unless (null current)
		     (dotimes (i (- current column))
		        (stream-write-char stream #\space))
		     t))))
	     
(defmethod STREAM-CLOSE ((stream default-output-stream)) nil)

;;;  Internal helper functions [not intended to be standardized]

(proclaim '(inline decode-read-arg))
(defun decode-read-arg (arg)
  (cond ((null arg) *standard-input*)
	((eq arg t) *terminal-io*)
	(t arg)))

(proclaim '(inline decode-print-arg))
(defun decode-print-arg (arg)
  (cond ((null arg) *standard-output*)
	((eq arg t) *terminal-io*)
	(t arg)))


;;;  Common Lisp query functions

(defgeneric INPUT-STREAM-P (stream)
  (:method ((stream default-input-stream)) t)
  (:method ((stream default-output-stream)) nil))

(defgeneric OUTPUT-STREAM-P (stream)
  (:method ((stream default-output-stream)) t)
  (:method ((stream default-input-stream)) nil))

(defgeneric STREAM-ELEMENT-TYPE (stream)
  (:method ((stream default-output-stream)) 'character)
  (:method ((stream default-input-stream)) 'character))


;;;  Common Lisp input functions

(defun READ-CHAR (&optional input-stream (eof-errorp t) eof-value recursive-p)
  (declare (ignore recursive-p)) ; This appears to have been a mistake in CLtL.
  (stream-read-char (decode-read-arg input-stream) eof-errorp eof-value))

(defun PEEK-CHAR (&optional peek-type input-stream (eof-errorp t) eof-value recursive-p)
  (declare (ignore recursive-p))
  (let ((stream (decode-read-arg input-stream)))
    (if (null peek-type)
	(stream-peek-char stream eof-errorp eof-value)
      ...)))

(defun UNREAD-CHAR (character &optional input-stream)
  (stream-unread-char (decode-read-arg input-stream) character))

(defun LISTEN (&optional input-stream)
  (stream-listen (decode-read-arg input-stream)))

(defun READ-LINE (&optional input-stream (eof-error-p t) eof-value recursive-p)
  (declare (ignore recursive-p))
  (stream-read-line (decode-read-arg input-stream) eof-error-p eof-value))

(defun CLEAR-INPUT (&optional input-stream)
  (stream-clear-input (decode-read-arg input-stream)))

(defun READ-CHAR-NO-HANG (&optional input-stream (eof-errorp t) eof-value recursive-p)
  (declare (ignore recursive-p))
  (stream-read-char-no-hang (decode-read-arg input-stream) eof-errorp eof-value))


;;;  Common Lisp output functions

(defun WRITE-CHAR (character &optional output-stream)
   (stream-write-char (decode-print-arg output-stream) character))

(defun FRESH-LINE (&optional output-stream)
  (stream-fresh-line (decode-print-arg output-stream)))

(defun WRITE-STRING (string &optional output-stream &key (start 0) end)
  (stream-write-string (decode-print-arg output-stream) string start end))

(defun WRITE-LINE (string &optional output-stream &key (start 0) end)
  (let ((stream (decode-print-arg output-stream)))
    (stream-write-string stream string start end)
    (stream-terpri stream)
    string))

(defun FORCE-OUTPUT (&optional stream)
  (stream-force-output (decode-print-arg stream)))

(defun FINISH-OUTPUT (&optional stream)
  (stream-finish-output (decode-print-arg stream)))

(defun CLEAR-OUTPUT (&optional stream)
  (stream-clear-output (decode-print-arg stream)))