base/scl-gray-streams.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Gray streams can be defined as subclass of the native stream classes.
   4 ;;;
   5
   6 (in-package :ext)
   7
   8 (export '(fundamental-stream
   9           fundamental-input-stream
  10           fundamental-output-stream
  11           fundamental-character-stream
  12           fundamental-binary-stream
  13           fundamental-character-input-stream
  14           fundamental-character-output-stream
  15           fundamental-binary-input-stream
  16           fundamental-binary-output-stream
  17           stream-read-line
  18           stream-start-line-p
  19           stream-write-string
  20           stream-terpri
  21           stream-fresh-line
  22           stream-advance-to-column
  23           )
  24         :ext)
  25
  26 (defclass fundamental-stream (stream)
  27   ()
  28   (:documentation "Base class for all CLOS streams"))
  29
  30 ;;; Define the stream classes.
  31 (defclass fundamental-input-stream (fundamental-stream ext:input-stream) ())
  32
  33 (defclass fundamental-output-stream (fundamental-stream ext:output-stream) ())
  34
  35 (defclass fundamental-character-stream (fundamental-stream ext:character-stream) ())
  36
  37 (defclass fundamental-binary-stream (fundamental-stream ext:binary-stream) ())
  38
  39 (defclass fundamental-character-input-stream (fundamental-input-stream
  40                                               fundamental-character-stream
  41                                               ext:character-input-stream)
  42   ())
  43
  44 (defclass fundamental-character-output-stream (fundamental-output-stream
  45                                                fundamental-character-stream
  46                                                ext:character-output-stream)
  47   ())
  48
  49 (defclass fundamental-binary-input-stream (fundamental-input-stream
  50                                            fundamental-binary-stream
  51                                            ext:binary-input-stream)
  52   ())
  53
  54 (defclass fundamental-binary-output-stream (fundamental-output-stream
  55                                             fundamental-binary-stream
  56                                             ext:binary-output-stream)
  57   ())
  58
  59 (defgeneric stream-read-line (stream)
  60   (:documentation
  61    "Used by 'read-line.  A string is returned as the first value.  The
  62   second value is true if the string was terminated by end-of-file
  63   instead of the end of a line.  The default method uses repeated
  64   calls to 'stream-read-char."))
  65
  66 (defmethod stream-read-line ((stream fundamental-character-input-stream))
  67   (let ((res (make-string 80))
  68         (len 80)
  69         (index 0))
  70     (loop
  71        (let ((ch (stream-read-char stream)))
  72          (cond ((eq :eof ch)
  73                 (return (values (lisp::shrink-vector res index) t)))
  74                (t
  75                 (when (char= ch #\newline)
  76                   (return (values (lisp::shrink-vector res index) nil)))
  77                 (when (= index len)
  78                   (setq len (* len 2))
  79                   (let ((new (make-string len)))
  80                     (replace new res)
  81                     (setq res new)))
  82                 (setf (schar res index) ch)
  83                 (incf index)))))))
  84
  85 (defgeneric stream-start-line-p (stream))
  86
  87 (defmethod stream-start-line-p ((stream fundamental-character-output-stream))
  88   (eql 0 (stream-line-column stream)))
  89
  90 (defgeneric stream-terpri (stream)
  91   (:documentation
  92    "Writes an end of line, as for TERPRI.  Returns NIL.  The default
  93   method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
  94
  95 (defmethod stream-terpri ((stream fundamental-character-output-stream))
  96   (stream-write-char stream #\Newline))
  97
  98 (defgeneric stream-fresh-line (stream)
  99   (:documentation
 100    "Outputs a new line to the Stream if it is not positioned at the
 101   begining of a line.  Returns 't if it output a new line, nil
 102   otherwise. Used by 'fresh-line. The default method uses
 103   'stream-start-line-p and 'stream-terpri."))
 104
 105 (defmethod stream-fresh-line ((stream fundamental-character-output-stream))
 106   (unless (stream-start-line-p stream)
 107     (stream-terpri stream)
 108     t))
 109
 110 (defgeneric stream-advance-to-column (stream column)
 111   (:documentation
 112    "Writes enough blank space so that the next character will be
 113   written at the specified column.  Returns true if the operation is
 114   successful, or NIL if it is not supported for this stream.  This is
 115   intended for use by by PPRINT and FORMAT ~T.  The default method uses
 116   STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a
 117   #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))
 118
 119 (defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
 120                                      column)
 121   (let ((current-column (stream-line-column stream)))
 122     (when current-column
 123       (let ((fill (- column current-column)))
 124         (dotimes (i fill)
 125           (stream-write-char stream #\Space)))
 126       t)))