/
port-collect.scm
74 lines (61 loc) · 2.47 KB
/
port-collect.scm
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
;;; Read characters from PORT until EOF, collect into a string.
(define (port->string port)
(reduce ((input* char port read-char))
((sc (make-string-collector)))
(collect-char! sc char)
(string-collector->string sc)))
;;; Read items from PORT with READER until EOF. Collect items into a list.
(define (port->list reader port)
(let lp ((ans '()))
(let ((x (reader port)))
(if (eof-object? x) (reverse! ans)
(lp (cons x ans))))))
(define (port->sexp-list port)
(port->list read port))
(define (port->string-list port)
(port->list read-line port))
(define (port-fold port reader op . seeds)
(letrec ((fold (lambda seeds
(let ((x (reader port)))
(if (eof-object? x) (apply values seeds)
(call-with-values (lambda () (apply op x seeds))
fold))))))
(apply fold seeds)))
(define reduce-port
(deprecated-proc port-fold 'reduce-port "Use port-fold instead."))
;;; Not defined:
;;; (field-reader field-delims record-delims)
;;; Returns a reader that reads strings delimited by 1 or more chars from
;;; the string FIELD-DELIMS. These strings are collected in a list until
;;; eof or until 1 or more chars from RECORD-DELIMS are read. Then the
;;; accumulated list of strings is returned. For example, if we want
;;; a procedure that reads one line of input, splitting it into
;;; whitespace-delimited strings, we can use
;;; (field-reader " \t" "\n")
;;; for a reader.
;; Loop until EOF reading characters or strings and writing (FILTER char)
;; or (FILTER string). Useful as an arg to FORK or FORK/PIPE.
(define (make-char-port-filter filter)
(lambda ()
(let lp ()
(let ((c (read-char)))
(if (not (eof-object? c))
(begin (write-char (filter c))
(lp)))))))
(define (port->string/limit port limit)
(iterate loop ((input* char port read-char)
(count* len 0))
((chars (list)))
(let ((chars (cons char chars)))
(if (>= len (- limit 1))
(list->string (reverse chars))
(loop chars)))
(and (pair? chars) (list->string (reverse chars)))))
(define (make-string-port-filter filter . maybe-buflen)
(let ((buflen (:optional maybe-buflen 1024)))
(lambda ()
(let lp ()
(cond ((port->string/limit (current-input-port) buflen) =>
(lambda (string)
(display (filter string))
(lp))))))))