stdlib/csv.tl


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75

;; Copyright 2025
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; 1. Redistributions of source code must retain the above copyright notice,
;;    this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;;    this list of conditions and the following disclaimer in the documentation
;;    and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.

(defun get-csv (: (stream *stdin*))
  (if (stringp stream)
    (upd stream make-string-input-stream))
  (enumlet (rfield qfield quot)
    (let ((record (vec))
          (field (str 0))
          (state rfield)
          (done nil))
      (while (not done)
        (let ((ch (get-char stream)))
          (when (eq ch #\return)
            (let ((ch2 (get-char stream)))
              (if (eq ch2 #\newline)
                (set ch ch2)
                (if ch2
                  (unget-char ch2 stream)))))
          (caseql* state
            (rfield (caseql* ch
                      (#\newline (vec-push record field)
                                 (set done t))
                      (#\,       (vec-push record field)
                                 (set field (str 0)))
                      (#\"       (cond
                                   ((empty field)
                                    (set state qfield))
                                   (t
                                     (string-extend field ch))))
                      (nil       (vec-push record field)
                                 (set done t))
                      (t         (string-extend field ch))))
            (qfield (caseql* ch
                      (#\"       (set state quot))
                      (nil       (vec-push record field)
                                 (set done t))
                      (t         (string-extend field ch))))
            (quot   (caseql* ch
                      (#\,       (vec-push record field)
                                 (set field (str 0)
                                      state rfield))
                      (#\"       (string-extend field ch)
                                 (set state qfield))
                      (#\newline (vec-push record field)
                                 (set done t))
                      (nil       (vec-push record field)
                                 (set done t))
                      (t         (string-extend field ch)
                                 (set state rfield)))))))
      record)))