buff-input.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          buff-input.lisp
   6 ;;;; Purpose:       Buffered line input
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: buff-input.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; Genutils users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the GNU General Public License.
  16 ;;;; *************************************************************************
  17
  18 (in-package :genutils)
  19
  20 (declaim (optimize (speed 3) (safety 0) (space 0) (debug 0)))
  21
  22 (defconstant +max-field+ 10000)
  23 (defconstant +max-fields-per-line+ 20)
  24 (defconstant +field-delim+ #\|)
  25 (defconstant +eof-char+ #\rubout)
  26 (defconstant +newline+ #\Newline)
  27
  28 (declaim (type character +eof-char+ +field-delim+ +newline+)
  29          (type fixnum +max-field+ +max-fields-per-line+))
  30
  31 ;; Buffered fields parsing function
  32 ;; Uses fill-pointer for size
  33
  34 (defun make-fields-buffer (&optional (max-fields +max-fields-per-line+)
  35                                    (max-field-len +max-field+))
  36   (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer 0 :adjustable nil)))
  37     (dotimes (i +max-fields-per-line+)
  38       (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer 0 :adjustable nil)))
  39     bufs))
  40
  41 (defun read-buffered-fields (fields strm &optional (field-delim +field-delim+))
  42   "Read a line from a stream into a field buffers"
  43   (declare (type base-char field-delim)
  44            (type vector fields))
  45   (setf (fill-pointer fields) 0)
  46   (do ((ifield 0 (1+ ifield))
  47        (linedone nil)
  48        (eof nil))
  49       (linedone (if eof 'eof fields))
  50     (declare (type fixnum ifield)
  51              (type boolean linedone eof))
  52     (let ((field (aref fields ifield)))
  53       (declare (type base-string field))
  54       (do ((ipos 0)
  55            (fielddone nil)
  56            (rc (read-char strm nil +eof-char+)
  57               (read-char strm nil +eof-char+)))
  58           (fielddone (unread-char rc strm))
  59         (declare (type fixnum ipos)
  60                  (type base-char rc)
  61                  (type boolean fielddone))
  62         (cond
  63          ((char= rc field-delim)
  64           (setf (fill-pointer field) ipos)
  65           (setq fielddone t))
  66          ((char= rc +newline+)
  67           (setf (fill-pointer field) ipos)
  68           (setf (fill-pointer fields) ifield)
  69           (setq fielddone t)
  70           (setq linedone t))
  71          ((char= rc +eof-char+)
  72           (setf (fill-pointer field) ipos)
  73           (setf (fill-pointer fields) ifield)
  74           (setq fielddone t)
  75           (setq linedone t)
  76           (setq eof t))
  77          (t
  78           (setf (char field ipos) rc)
  79           (incf ipos)))))))
  80
  81 ;; Buffered fields parsing
  82 ;; Does not use fill-pointer
  83 ;; Returns 2 values -- string array and length array
  84 (defstruct field-buffers
  85   (nfields 0 :type fixnum)
  86   (buffers)
  87   (field-lengths))
  88
  89 (defmethod print-object ((f field-buffers) s)
  90   (format s "#<~d>~%" (field-buffers-nfields f)))
  91
  92 (defun make-fields-buffer2 (&optional (max-fields +max-fields-per-line+)
  93                                    (max-field-len +max-field+))
  94   (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer nil :adjustable nil))
  95         (bufstruct (make-field-buffers)))
  96     (dotimes (i +max-fields-per-line+)
  97       (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer nil :adjustable nil)))
  98     (setf (field-buffers-buffers bufstruct) bufs)
  99     (setf (field-buffers-field-lengths bufstruct) (make-array +max-fields-per-line+
 100                                                               :element-type 'fixnum :fill-pointer nil :adjustable nil))
 101     (setf (field-buffers-nfields bufstruct) 0)
 102     bufstruct))
 103
 104
 105 (defun read-buffered-fields2 (fields strm &optional (field-delim +field-delim+))
 106   "Read a line from a stream into a field buffers"
 107   (declare (character field-delim))
 108   (setf (field-buffers-nfields fields) 0)
 109   (do ((ifield 0 (1+ ifield))
 110        (linedone nil)
 111        (eof nil))
 112       (linedone (if eof 'eof fields))
 113     (declare (fixnum ifield)
 114              (t linedone eof))
 115     (let ((field (aref (field-buffers-buffers fields) ifield)))
 116       (declare (simple-string field))
 117       (do ((ipos 0)
 118            (fielddone nil)
 119            (rc (read-char strm nil +eof-char+)
 120               (read-char strm nil +eof-char+)))
 121           (fielddone (unread-char rc strm))
 122         (declare (fixnum ipos)
 123                  (character rc)
 124                  (t fielddone))
 125         (cond
 126          ((char= rc field-delim)
 127           (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
 128           (setq fielddone t))
 129          ((char= rc +newline+)
 130           (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
 131           (setf (field-buffers-nfields fields) ifield)
 132           (setq fielddone t)
 133           (setq linedone t))
 134          ((char= rc +eof-char+)
 135           (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
 136           (setf (field-buffers-nfields fields) ifield)
 137           (setq fielddone t)
 138           (setq linedone t)
 139           (setq eof t))
 140          (t
 141           (setf (char field ipos) rc)
 142           (incf ipos)))))))
 143
 144 (defun bfield (fields i)
 145   (if (>= i (field-buffers-nfields fields))
 146       nil
 147     (subseq (aref (field-buffers-buffers fields) i) 0 (aref (field-buffers-field-lengths fields) i))))
 148
 149 ;;; Buffered line parsing function
 150
 151 (defconstant +max-line+ 20000)
 152 (let ((linebuffer (make-array +max-line+
 153                               :element-type 'character
 154                               :fill-pointer 0)))
 155   (defun read-buffered-line (strm)
 156     "Read a line from astream into a vector buffer"
 157     (let ((pos 0)
 158           (done nil))
 159       (declare (fixnum pos) (t done))
 160       (setf (fill-pointer linebuffer) 0)
 161       (do ((c (read-char strm nil +eof-char+)
 162               (read-char strm nil +eof-char+)))
 163           (done (progn
 164                   (unless (eql c +eof-char+) (unread-char c strm))
 165                   (if (eql c +eof-char+) 'eof linebuffer)))
 166         (declare (character c))
 167         (cond
 168         ((char= c #\Newline)
 169          (unless (zerop pos)
 170            (setf (fill-pointer linebuffer) (1- pos)))
 171          (setf done t))
 172         ((char= +eof-char+)
 173          (setf done t))
 174         (t
 175          (setf (char linebuffer pos) c)
 176          (incf pos)))))))
 177