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 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  11 ;;;;
  12 ;;;; KMRCL users are granted the rights to distribute and use this software
  13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  15 ;;;; *************************************************************************
  16
  17 (in-package :kmrcl)
  18
  19 (eval-when (:compile-toplevel)
  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                              (eof 'eof))
  43   "Read a line from a stream into a field buffers"
  44   (declare (type base-char field-delim)
  45            (type vector fields))
  46   (setf (fill-pointer fields) 0)
  47   (do ((ifield 0 (1+ ifield))
  48        (linedone nil)
  49        (is-eof nil))
  50       (linedone (if is-eof eof fields))
  51     (declare (type fixnum ifield)
  52              (type boolean linedone is-eof))
  53     (let ((field (aref fields ifield)))
  54       (declare (type base-string field))
  55       (do ((ipos 0)
  56            (fielddone nil)
  57            (rc (read-char strm nil +eof-char+)
  58               (read-char strm nil +eof-char+)))
  59           (fielddone (unread-char rc strm))
  60         (declare (type fixnum ipos)
  61                  (type base-char rc)
  62                  (type boolean fielddone))
  63         (cond
  64          ((char= rc field-delim)
  65           (setf (fill-pointer field) ipos)
  66           (setq fielddone t))
  67          ((char= rc +newline+)
  68           (setf (fill-pointer field) ipos)
  69           (setf (fill-pointer fields) ifield)
  70           (setq fielddone t)
  71           (setq linedone t))
  72          ((char= rc +eof-char+)
  73           (setf (fill-pointer field) ipos)
  74           (setf (fill-pointer fields) ifield)
  75           (setq fielddone t)
  76           (setq linedone t)
  77           (setq is-eof t))
  78          (t
  79           (setf (char field ipos) rc)
  80           (incf ipos)))))))
  81
  82 ;; Buffered fields parsing
  83 ;; Does not use fill-pointer
  84 ;; Returns 2 values -- string array and length array
  85 (defstruct field-buffers
  86   (nfields 0 :type fixnum)
  87   (buffers)
  88   (field-lengths))
  89
  90 (defun make-fields-buffer2 (&optional (max-fields +max-fields-per-line+)
  91                                    (max-field-len +max-field+))
  92   (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer nil :adjustable nil))
  93         (bufstruct (make-field-buffers)))
  94     (dotimes (i +max-fields-per-line+)
  95       (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer nil :adjustable nil)))
  96     (setf (field-buffers-buffers bufstruct) bufs)
  97     (setf (field-buffers-field-lengths bufstruct) (make-array +max-fields-per-line+
  98                                                               :element-type 'fixnum :fill-pointer nil :adjustable nil))
  99     (setf (field-buffers-nfields bufstruct) 0)
 100     bufstruct))
 101
 102
 103 (defun read-buffered-fields2 (fields strm &optional (field-delim +field-delim+)
 104                               (eof 'eof))
 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        (is-eof nil))
 111       (linedone (if is-eof eof fields))
 112     (declare (fixnum ifield)
 113              (t linedone is-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 is-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 eof)
 155     "Read a line from astream into a vector buffer"
 156     (declare (optimize (speed 3) (space 0) (safety 0)))
 157     (let ((pos 0)
 158           (done nil))
 159       (declare (fixnum pos) (type boolean 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          ((>= pos +max-line+)
 169           (warn "Line overflow")
 170           (setf done t))
 171          ((char= c #\Newline)
 172           (when (plusp pos)
 173             (setf (fill-pointer linebuffer) (1- pos)))
 174           (setf done t))
 175          ((char= +eof-char+)
 176           (setf done t))
 177          (t
 178           (setf (char linebuffer pos) c)
 179           (incf pos)))))))
 180