io.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          io.lisp
   6 ;;;; Purpose:       Input/Output functions for KMRCL package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: io.lisp,v 1.10 2003/06/20 08:50:38 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; KMRCL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:kmrcl)
  20
  21 (defun print-file-contents (file &optional (strm *standard-output*))
  22   "Opens a reads a file. Returns the contents as a single string"
  23   (when (probe-file file)
  24     (with-open-file (in file :direction :input)
  25       (let ((eof (gensym)))
  26         (do ((line (read-line in nil eof)
  27                    (read-line in nil eof)))
  28             ((eq line eof))
  29           (format strm "~A~%" line))))))
  30
  31 (defun read-file-to-string (file)
  32   "Opens a reads a file. Returns the contents as a single string"
  33   (with-output-to-string (out)
  34     (with-open-file (in file :direction :input)
  35       (let ((eof (gensym)))
  36         (do ((line (read-line in nil eof)
  37                    (read-line in nil eof)))
  38             ((eq line eof))
  39           (format out "~A~%" line))))))
  40
  41 (defun read-file-to-strings (file)
  42   "Opens a reads a file. Returns the contents as a list of strings"
  43   (let ((lines '()))
  44     (with-open-file (in file :direction :input)
  45       (let ((eof (gensym)))
  46         (do ((line (read-line in nil eof)
  47                    (read-line in nil eof)))
  48             ((eq line eof))
  49           (push line lines)))
  50       (nreverse lines))))
  51
  52 (defun file-subst (old new file1 file2)
  53   (with-open-file (in file1 :direction :input)
  54     (with-open-file (out file2 :direction :output
  55                          :if-exists :supersede)
  56       (stream-subst old new in out))))
  57
  58 (defun print-n-chars (char n stream)
  59   (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  60   (dotimes (i n)
  61     (declare (fixnum i))
  62     (write-char char stream)))
  63
  64 (defun print-n-strings (str n stream)
  65   (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0)))
  66   (dotimes (i n)
  67     (declare (fixnum i))
  68     (write-string str stream)))
  69
  70 (defun indent-spaces (n &optional (stream *standard-output*))
  71   "Indent n*2 spaces to output stream"
  72   (print-n-chars #\space (+ n n) stream))
  73
  74
  75 (defun indent-html-spaces (n &optional (stream *standard-output*))
  76   "Indent n*2 html spaces to output stream"
  77   (print-n-strings "&nbsp;" (+ n n) stream))
  78
  79
  80 (defun print-list (l &optional (output *standard-output*))
  81   "Print a list to a stream"
  82   (format output "~{~A~%~}" l))
  83
  84 (defun print-rows (rows &optional (ostrm *standard-output*))
  85   "Print a list of list rows to a stream"
  86   (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r)))
  87
  88
  89 ;; Buffered stream substitute
  90
  91 (defstruct buf
  92   vec (start -1) (used -1) (new -1) (end -1))
  93
  94 (defun bref (buf n)
  95   (svref (buf-vec buf)
  96          (mod n (length (buf-vec buf)))))
  97
  98 (defun (setf bref) (val buf n)
  99   (setf (svref (buf-vec buf)
 100                (mod n (length (buf-vec buf))))
 101         val))
 102
 103 (defun new-buf (len)
 104   (make-buf :vec (make-array len)))
 105
 106 (defun buf-insert (x b)
 107   (setf (bref b (incf (buf-end b))) x))
 108
 109 (defun buf-pop (b)
 110   (prog1
 111     (bref b (incf (buf-start b)))
 112     (setf (buf-used b) (buf-start b)
 113           (buf-new  b) (buf-end   b))))
 114
 115 (defun buf-next (b)
 116   (when (< (buf-used b) (buf-new b))
 117     (bref b (incf (buf-used b)))))
 118
 119 (defun buf-reset (b)
 120   (setf (buf-used b) (buf-start b)
 121         (buf-new  b) (buf-end   b)))
 122
 123 (defun buf-clear (b)
 124   (setf (buf-start b) -1 (buf-used  b) -1
 125         (buf-new   b) -1 (buf-end   b) -1))
 126
 127 (defun buf-flush (b str)
 128   (do ((i (1+ (buf-used b)) (1+ i)))
 129       ((> i (buf-end b)))
 130     (princ (bref b i) str)))
 131
 132
 133 (defun stream-subst (old new in out)
 134   (declare (string old new))
 135   (let* ((pos 0)
 136          (len (length old))
 137          (buf (new-buf len))
 138          (from-buf nil))
 139     (declare (fixnum pos len))
 140     (do ((c (read-char in nil :eof)
 141             (or (setf from-buf (buf-next buf))
 142                 (read-char in nil :eof))))
 143         ((eql c :eof))
 144       (declare (character c))
 145       (cond ((char= c (char old pos))
 146              (incf pos)
 147              (cond ((= pos len)            ; 3
 148                     (princ new out)
 149                     (setf pos 0)
 150                     (buf-clear buf))
 151                    ((not from-buf)         ; 2
 152                     (buf-insert c buf))))
 153             ((zerop pos)                   ; 1
 154              (princ c out)
 155              (when from-buf
 156                (buf-pop buf)
 157                (buf-reset buf)))
 158             (t                             ; 4
 159              (unless from-buf
 160                (buf-insert c buf))
 161              (princ (buf-pop buf) out)
 162              (buf-reset buf)
 163              (setf pos 0))))
 164     (buf-flush buf out)))
 165
 166 (declaim (inline write-fixnum))
 167 (defun write-fixnum (n s)
 168   #+allegro (excl::print-fixnum s 10 n)
 169   #-allegro (write-string (write-to-string n) s))
 170
 171