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.5 2003/05/05 19:54:14 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 (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   "Read a line from a stream into a field buffers"
  45   (declare (type base-char field-delim)
  46            (type vector fields))
  47   (setf (fill-pointer fields) 0)
  48   (do ((ifield 0 (1+ ifield))
  49        (linedone nil)
  50        (eof nil))
  51       (linedone (if eof 'eof fields))
  52     (declare (type fixnum ifield)
  53              (type boolean linedone eof))
  54     (let ((field (aref fields ifield)))
  55       (declare (type base-string field))
  56       (do ((ipos 0)
  57            (fielddone nil)
  58            (rc (read-char strm nil +eof-char+)
  59               (read-char strm nil +eof-char+)))
  60           (fielddone (unread-char rc strm))
  61         (declare (type fixnum ipos)
  62                  (type base-char rc)
  63                  (type boolean fielddone))
  64         (cond
  65          ((char= rc field-delim)
  66           (setf (fill-pointer field) ipos)
  67           (setq fielddone t))
  68          ((char= rc +newline+)
  69           (setf (fill-pointer field) ipos)
  70           (setf (fill-pointer fields) ifield)
  71           (setq fielddone t)
  72           (setq linedone t))
  73          ((char= rc +eof-char+)
  74           (setf (fill-pointer field) ipos)
  75           (setf (fill-pointer fields) ifield)
  76           (setq fielddone t)
  77           (setq linedone t)
  78           (setq eof t))
  79          (t
  80           (setf (char field ipos) rc)
  81           (incf ipos)))))))
  82
  83 ;; Buffered fields parsing
  84 ;; Does not use fill-pointer
  85 ;; Returns 2 values -- string array and length array
  86 (defstruct field-buffers
  87   (nfields 0 :type fixnum)
  88   (buffers)
  89   (field-lengths))
  90
  91 (defun make-fields-buffer2 (&optional (max-fields +max-fields-per-line+)
  92                                    (max-field-len +max-field+))
  93   (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer nil :adjustable nil))
  94         (bufstruct (make-field-buffers)))
  95     (dotimes (i +max-fields-per-line+)
  96       (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer nil :adjustable nil)))
  97     (setf (field-buffers-buffers bufstruct) bufs)
  98     (setf (field-buffers-field-lengths bufstruct) (make-array +max-fields-per-line+
  99                                                               :element-type 'fixnum :fill-pointer nil :adjustable nil))
 100     (setf (field-buffers-nfields bufstruct) 0)
 101     bufstruct))
 102
 103
 104 (defun read-buffered-fields2 (fields strm &optional (field-delim +field-delim+))
 105   "Read a line from a stream into a field buffers"
 106   (declare (character field-delim))
 107   (setf (field-buffers-nfields fields) 0)
 108   (do ((ifield 0 (1+ ifield))
 109        (linedone nil)
 110        (eof nil))
 111       (linedone (if eof 'eof fields))
 112     (declare (fixnum ifield)
 113              (t linedone eof))
 114     (let ((field (aref (field-buffers-buffers fields) ifield)))
 115       (declare (simple-string field))
 116       (do ((ipos 0)
 117            (fielddone nil)
 118            (rc (read-char strm nil +eof-char+)
 119               (read-char strm nil +eof-char+)))
 120           (fielddone (unread-char rc strm))
 121         (declare (fixnum ipos)
 122                  (character rc)
 123                  (t fielddone))
 124         (cond
 125          ((char= rc field-delim)
 126           (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
 127           (setq fielddone t))
 128          ((char= rc +newline+)
 129           (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
 130           (setf (field-buffers-nfields fields) ifield)
 131           (setq fielddone t)
 132           (setq linedone t))
 133          ((char= rc +eof-char+)
 134           (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
 135           (setf (field-buffers-nfields fields) ifield)
 136           (setq fielddone t)
 137           (setq linedone t)
 138           (setq eof t))
 139          (t
 140           (setf (char field ipos) rc)
 141           (incf ipos)))))))
 142
 143 (defun bfield (fields i)
 144   (if (>= i (field-buffers-nfields fields))
 145       nil
 146     (subseq (aref (field-buffers-buffers fields) i) 0 (aref (field-buffers-field-lengths fields) i))))
 147
 148 ;;; Buffered line parsing function
 149
 150 (defconstant +max-line+ 20000)
 151 (let ((linebuffer (make-array +max-line+
 152                               :element-type 'character
 153                               :fill-pointer 0)))
 154   (defun read-buffered-line (strm)
 155     "Read a line from astream into a vector buffer"
 156     (let ((pos 0)
 157           (done nil))
 158       (declare (fixnum pos) (t done))
 159       (setf (fill-pointer linebuffer) 0)
 160       (do ((c (read-char strm nil +eof-char+)
 161               (read-char strm nil +eof-char+)))
 162           (done (progn
 163                   (unless (eql c +eof-char+) (unread-char c strm))
 164                   (if (eql c +eof-char+) 'eof linebuffer)))
 165         (declare (character c))
 166         (cond
 167         ((char= c #\Newline)
 168          (unless (zerop pos)
 169            (setf (fill-pointer linebuffer) (1- pos)))
 170          (setf done t))
 171         ((char= +eof-char+)
 172          (setf done t))
 173         (t
 174          (setf (char linebuffer pos) c)
 175          (incf pos)))))))
 176