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$
  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 (eval-when (:compile-toplevel)
  22   (declaim (optimize (speed 3) (safety 0) (space 0) (debug 0))))
  23
  24 (defconstant +max-field+ 10000)
  25 (defconstant +max-fields-per-line+ 20)
  26 (defconstant +field-delim+ #\|)
  27 (defconstant +eof-char+ #\rubout)
  28 (defconstant +newline+ #\Newline)
  29
  30 (declaim (type character +eof-char+ +field-delim+ +newline+)
  31          (type fixnum +max-field+ +max-fields-per-line+))
  32
  33 ;; Buffered fields parsing function
  34 ;; Uses fill-pointer for size
  35
  36 (defun make-fields-buffer (&optional (max-fields +max-fields-per-line+)
  37                                    (max-field-len +max-field+))
  38   (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer 0 :adjustable nil)))
  39     (dotimes (i +max-fields-per-line+)
  40       (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer 0 :adjustable nil)))
  41     bufs))
  42
  43 (defun read-buffered-fields (fields strm &optional (field-delim +field-delim+)
  44                              (eof 'eof))
  45   "Read a line from a stream into a field buffers"
  46   (declare (type base-char field-delim)
  47            (type vector fields))
  48   (setf (fill-pointer fields) 0)
  49   (do ((ifield 0 (1+ ifield))
  50        (linedone nil)
  51        (is-eof nil))
  52       (linedone (if is-eof eof fields))
  53     (declare (type fixnum ifield)
  54              (type boolean linedone is-eof))
  55     (let ((field (aref fields ifield)))
  56       (declare (type base-string field))
  57       (do ((ipos 0)
  58            (fielddone nil)
  59            (rc (read-char strm nil +eof-char+)
  60               (read-char strm nil +eof-char+)))
  61           (fielddone (unread-char rc strm))
  62         (declare (type fixnum ipos)
  63                  (type base-char rc)
  64                  (type boolean fielddone))
  65         (cond
  66          ((char= rc field-delim)
  67           (setf (fill-pointer field) ipos)
  68           (setq fielddone t))
  69          ((char= rc +newline+)
  70           (setf (fill-pointer field) ipos)
  71           (setf (fill-pointer fields) ifield)
  72           (setq fielddone t)
  73           (setq linedone t))
  74          ((char= rc +eof-char+)
  75           (setf (fill-pointer field) ipos)
  76           (setf (fill-pointer fields) ifield)
  77           (setq fielddone t)
  78           (setq linedone t)
  79           (setq is-eof t))
  80          (t
  81           (setf (char field ipos) rc)
  82           (incf ipos)))))))
  83
  84 ;; Buffered fields parsing
  85 ;; Does not use fill-pointer
  86 ;; Returns 2 values -- string array and length array
  87 (defstruct field-buffers
  88   (nfields 0 :type fixnum)
  89   (buffers)
  90   (field-lengths))
  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                               (eof 'eof))
 107   "Read a line from a stream into a field buffers"
 108   (declare (character field-delim))
 109   (setf (field-buffers-nfields fields) 0)
 110   (do ((ifield 0 (1+ ifield))
 111        (linedone nil)
 112        (is-eof nil))
 113       (linedone (if is-eof eof fields))
 114     (declare (fixnum ifield)
 115              (t linedone is-eof))
 116     (let ((field (aref (field-buffers-buffers fields) ifield)))
 117       (declare (simple-string field))
 118       (do ((ipos 0)
 119            (fielddone nil)
 120            (rc (read-char strm nil +eof-char+)
 121               (read-char strm nil +eof-char+)))
 122           (fielddone (unread-char rc strm))
 123         (declare (fixnum ipos)
 124                  (character rc)
 125                  (t fielddone))
 126         (cond
 127          ((char= rc field-delim)
 128           (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
 129           (setq fielddone t))
 130          ((char= rc +newline+)
 131           (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
 132           (setf (field-buffers-nfields fields) ifield)
 133           (setq fielddone t)
 134           (setq linedone t))
 135          ((char= rc +eof-char+)
 136           (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
 137           (setf (field-buffers-nfields fields) ifield)
 138           (setq fielddone t)
 139           (setq linedone t)
 140           (setq is-eof t))
 141          (t
 142           (setf (char field ipos) rc)
 143           (incf ipos)))))))
 144
 145 (defun bfield (fields i)
 146   (if (>= i (field-buffers-nfields fields))
 147       nil
 148     (subseq (aref (field-buffers-buffers fields) i) 0 (aref (field-buffers-field-lengths fields) i))))
 149
 150 ;;; Buffered line parsing function
 151
 152 (defconstant +max-line+ 20000)
 153 (let ((linebuffer (make-array +max-line+
 154                               :element-type 'character
 155                               :fill-pointer 0)))
 156   (defun read-buffered-line (strm eof)
 157     "Read a line from astream into a vector buffer"
 158     (declare (optimize (speed 3) (space 0) (safety 0)))
 159     (let ((pos 0)
 160           (done nil))
 161       (declare (fixnum pos) (type boolean done))
 162       (setf (fill-pointer linebuffer) 0)
 163       (do ((c (read-char strm nil +eof-char+)
 164               (read-char strm nil +eof-char+)))
 165           (done (progn
 166                   (unless (eql c +eof-char+) (unread-char c strm))
 167                   (if (eql c +eof-char+) eof linebuffer)))
 168         (declare (character c))
 169         (cond
 170          ((>= pos +max-line+)
 171           (warn "Line overflow")
 172           (setf done t))
 173          ((char= c #\Newline)
 174           (when (plusp pos)
 175             (setf (fill-pointer linebuffer) (1- pos)))
 176           (setf done t))
 177          ((char= +eof-char+)
 178           (setf done t))
 179          (t
 180           (setf (char linebuffer pos) c)
 181           (incf pos)))))))
 182