losp/muerte/streams.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001, 2003-2004,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      streams.lisp
   9 ;;;; Description:   Basic I/O streams code.
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Mon Jun 30 14:33:15 2003
  12 ;;;;
  13 ;;;; $Id: streams.lisp,v 1.5 2006/04/10 11:57:24 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (require :muerte/basic-macros)
  18 (require :muerte/los-closette)
  19 (provide :muerte/streams)
  20
  21 (in-package muerte)
  22
  23 (defgeneric stream-write-char (stream character)
  24   (:no-clos-fallback stream-no-clos))
  25
  26 (defmethod stream-write-char ((stream string) character)
  27   (vector-push-extend character stream)
  28   character)
  29
  30 (defmethod stream-write-char ((stream function) character)
  31   (funcall stream 'stream-write-char character))
  32
  33 (defgeneric stream-read-char (stream)
  34   (:no-clos-fallback stream-no-clos))
  35
  36 (defmethod stream-read-char ((stream function))
  37   (funcall stream 'stream-read-char))
  38
  39 (defun output-stream-designator (d)
  40   (cond
  41    ((eq nil d) *standard-output*)
  42    ((eq t d)   *terminal-io*)
  43    (t d)))
  44
  45 (defun input-stream-designator (d)
  46   (cond
  47    ((eq nil d) *standard-input*)
  48    ((eq t d) *terminal-io*)
  49    (t d)))
  50
  51 (defun install-streams-printing (&optional (new-stdout (make-instance 'muerte.x86-pc::vga-text-console)))
  52   ;; (check-type new-stdout stream)
  53   (let ((s new-stdout))
  54     (setf *standard-output* s
  55           *debug-io* s
  56           *terminal-io* s
  57           *trace-output* s
  58           *query-io* s))
  59   (values))
  60
  61 (defgeneric stream-write-string (stream string &optional start end)
  62   (:no-clos-fallback :unspecialized-method))
  63
  64 (defmethod stream-write-string (stream string &optional (start 0) (end (length string)))
  65   (with-subvector-accessor (string-ref string start end)
  66     (do ((i start (1+ i)))
  67         ((>= i end))
  68       (stream-write-char stream (string-ref i))))
  69   string)
  70
  71 (defgeneric stream-write-escaped-string (stream string escaped-char &optional start end)
  72   (:no-clos-fallback :unspecialized-method))
  73
  74 (defmethod stream-write-escaped-string (stream string escaped-char
  75                                         &optional (start 0) (end (length string)))
  76   (stream-write-char stream escaped-char)
  77   (with-subvector-accessor (string-ref string start end)
  78     (do ((i start (1+ i)))
  79         ((>= i end))
  80       (let ((c (string-ref i)))
  81         (when (or (eql c escaped-char) (char= c #\\))
  82           (stream-write-char stream #\\))
  83         (stream-write-char stream c))))
  84   (stream-write-char stream escaped-char)
  85   string)
  86
  87 (defgeneric stream-fresh-line (stream)
  88   (:no-clos-fallback stream-no-clos))
  89
  90 (defmethod stream-fresh-line (stream)
  91   (stream-write-char stream #\Newline)
  92   t)
  93
  94 (defmethod stream-fresh-line ((stream function))
  95   (funcall stream 'stream-fresh-line))
  96
  97 (defun stream-no-clos (stream &rest args)
  98   (declare (dynamic-extent args))
  99   (etypecase stream
 100     (string
 101      (case (funobj-name *forward-generic-function*)
 102        (stream-write-char
 103         (vector-push-extend (car args) stream)
 104         (car args))
 105        (stream-fresh-line
 106         (vector-push-extend #\newline stream)
 107         t)))
 108     (function
 109      (apply stream (funobj-name *forward-generic-function*) args))))
 110
 111
 112 ;;;;
 113
 114
 115 (defun read-char (&optional input-stream (eof-error-p t) eof-value recursive-p)
 116   " => char"
 117   (%read-char (input-stream-designator input-stream) eof-error-p eof-value recursive-p t))
 118
 119 (defun read-key (&optional input-stream (eof-error-p t) eof-value recursive-p)
 120   " => char, symbol, etc."
 121   (%read-key (input-stream-designator input-stream) eof-error-p eof-value recursive-p t))
 122
 123 (defun finish-output (&optional stream)
 124   "finish-output attempts to ensure that any buffered output sent to output-stream has reached its
 125 destination, and then returns."
 126   (let ((stream (output-stream-designator stream)))
 127     (etypecase stream
 128       (function)                        ; NOP
 129       (simple-stream
 130        (%finish-output stream)))))
 131