scsh-0.6/scsh/rdelim.scm

291 lines
11 KiB
Scheme
Raw Normal View History

;;; Delimited readers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These procedures ran their inner I/O loop in a C primitive in
;;; earlier versions of scsh. In a multi-threaded environment this
;;; causes lots of trouble in case the operation would
;;; block. Therefore the current implementation runs in Scheme but
;;; operates directly on the buffer of the port for speed. This also
;;; allows us to implement the push-back behaviour without a peek/read
;;; pair.
;;;
;;; (read-delimited delims [port delim-action])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Returns a string or the EOF object. DELIM-ACTION determines what to do
;;; with the terminating delimiter:
;;; - PEEK
;;; Leave it in the input stream for later reading.
;;; - TRIM (the default)
;;; Drop it on the floor.
;;; - CONCAT
;;; Append it to the returned string.
;;; - SPLIT
;;; Return it as a second return value.
;;;
;;; We repeatedly allocate a buffer and fill it with READ-DELIMITED!
;;; until we hit a delimiter or EOF. Each time through the loop, we
;;; double the total buffer space, so the loop terminates with a log
;;; number of reads, but uses at most double the optimal buffer space.
(define (read-delimited delims . args)
(let-optionals args ((port (current-input-port))
(delim-action 'trim))
(let ((substr (lambda (s end) ; Smart substring.
(if (= end (string-length s)) s
(substring s 0 end))))
(delims (->char-set delims))
(gobble? (not (eq? delim-action 'peek))))
;; BUFLEN is total amount of buffer space allocated to date.
(let lp ((strs '()) (buflen 80) (buf (make-string 80)))
(receive (terminator num-read)
(%read-delimited! delims buf gobble? port)
(if terminator
;; We are done. NUM-READ is either a read count or EOF.
(let ((retval (if (and (zero? num-read)
(eof-object? terminator)
(null? strs))
terminator ; EOF -- got nothing.
;; Got something. Stick all the strings
;; together, plus the terminator if the
;; client said 'CONCAT.
(let ((s (substr buf num-read)))
(cond ((and (eq? delim-action 'concat)
(char? terminator))
(apply string-append
(reverse `(,(string terminator)
,s . ,strs))))
((null? strs) s) ; Gratuitous opt.
(else (apply string-append
(reverse (cons s strs)))))))))
(if (eq? delim-action 'split)
(values retval terminator)
retval))
;; We are not done. Loop and read in some more.
(lp (cons buf strs)
(+ buflen buflen)
(make-string buflen))))))))
;;; (read-delimited! delims buf [port delim-action start end])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Returns:
;;; - EOF if at end of file, and a non-zero read was requested.
;;; - Integer j if that many chars read into BUF.
;;; - #f if the buffer was filled w/o finding a delimiter.
;;;
;;; DELIM-ACTION determines what to do with the terminating delimiter;
;;; it is as in READ-DELIMITED.
;;;
;;; In determining the return value, there is an ambiguous case: when the
;;; buffer is full, *and* the following char is a delimiter char or EOF.
;;; Ties are broken favoring termination over #f -- after filling the buffer,
;;; READ-DELIMITED! won't return #f until it has peeked one past the end
;;; of the buffer to ensure the next char doesn't terminate input (or is EOF).
;;; However, this rule is relaxed with delim-action = CONCAT -- if the buffer
;;; is full, READ-DELIMITED! won't wait around trying to peek at the following
;;; char to determine whether or not it is a delimiter char, since it doesn't
;;; have space to store the character anyway. It simply immediately returns #f;
;;; a following read can pick up the delimiter char.
(define (read-delimited! delims buf . args) ; [port delim-action start end]
(let-optionals args ((port (current-input-port))
(delim-action 'trim)
(start 0)
(end (string-length buf)))
(receive (terminator num-read)
(%read-delimited! delims buf
(not (eq? delim-action 'peek)) ;Gobble delim?
port
start
(if (eq? delim-action 'concat)
(- end 1) ; Room for terminator.
end))
(if terminator ; Check for buffer overflow.
(let ((retval (if (and (zero? num-read)
(eof-object? terminator))
terminator ; EOF -- got nothing.
num-read))) ; Got something.
(case delim-action
((peek trim) retval)
((split) (values retval terminator))
((concat) (cond ((char? terminator)
(string-set! buf (+ start num-read) terminator)
(+ num-read 1))
(else retval)))))
;; Buffer overflow.
(case delim-action
((peek trim) #f)
((split) (values #f #f))
((concat) (let ((last (read-char port)))
(if (char? last)
(string-set! buf (+ start num-read) last))
(and (or (eof-object? last)
(char-set-contains? (->char-set delims)
last))
(+ num-read 1)))))))))
;;; (%read-delimited! delims buf gobble? [port start end])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This low-level routine uses a different interface. It returns two values:
;;; - TERMINATOR: A value describing why the read was terminated:
;;; + character or eof-object => read terminated by this value;
;;; + #f => filled buffer w/o terminating read.
;;; - NUM-READ: Number of chars read into buf.
;;;
;;; Note:
;;; - Invariant: TERMINATOR = #f => NUM-READ = END - START.
;;; - Invariant: TERMINATOR = eof-object and NUM-READ = 0 => at EOF.
;;; - When determining the TERMINATOR return value, ties are broken
;;; favoring character or the eof-object over #f. That is, if the buffer
;;; fills up, %READ-DELIMITED! will peek at one more character from the
;;; input stream to determine if it terminates the input. If so, that
;;; is returned, not #f.
;;;
;;; If GOBBLE? is true, then a terminator character is removed from
;;; the input stream. Otherwise, it is left in place for a following input
;;; operation.
(define (port-buffer-read-delimited delims buf gobble? port start end)
(obtain-port-lock port)
(let ((the-port-limit (port-limit port)))
(let lp ((i start) (lp-port-index (port-index port)))
(cond ((port-pending-eof? port)
(set-port-index! port lp-port-index)
(release-port-lock port)
(values (eof-object) (- i start)))
((>= i end)
(set-port-index! port lp-port-index)
(release-port-lock port)
(values #f (- i start)))
((< lp-port-index the-port-limit)
(let ((the-read-char
(ascii->char (byte-vector-ref
(port-buffer port) lp-port-index))))
(if (char-set-contains? delims the-read-char)
(begin
(if gobble?
(set-port-index! port (+ lp-port-index 1))
(set-port-index! port lp-port-index))
(release-port-lock port)
(values the-read-char (- i start)))
(begin
(string-set! buf i the-read-char)
(lp (+ i 1) (+ lp-port-index 1))))))
(else (set-port-index! port 0)
(set-port-limit! port 0)
(release-port-lock port)
(values 'port-buffer-exhausted (- i start)))))))
(define (%read-delimited! delims buf gobble? . args)
(let-optionals args ((port (current-input-port))
(start 0)
(end (string-length buf)))
1999-09-23 13:46:46 -04:00
(let* ((delims (->char-set delims))
(sdelims (char-set:s delims)))
(let lp ((start start) (total 0))
(receive (terminator num-read)
(port-buffer-read-delimited delims buf gobble? port start end)
(if (not (eq? terminator 'port-buffer-exhausted))
(values terminator (+ num-read total))
(begin (peek-char port) ; kludge to fill the buffer
(lp (+ start num-read) (+ total num-read)))))))))
; overwrites port-index :-(
(define (push-back port char)
(byte-vector-set! (port-buffer port) (port-index port) (char->ascii char))
(set-port-limit! port (+ (port-limit port) 1)))
(define (skip-char-set skip-chars . maybe-port)
1999-09-23 13:46:46 -04:00
(let* ((port (:optional maybe-port (current-input-port)))
(cset (->char-set skip-chars))
(scset (char-set:s cset)))
(let lp ((total 0))
(receive (succ num-read) (buffer-skip-char-set cset port)
(if (not succ)
(+ total num-read) ; eof
(begin (peek-char port); kludge to fill the buffer
(lp (+ total num-read))))))))
(define (buffer-skip-char-set cset port)
(let ((the-port-limit (port-limit port)))
(let lp ((lp-port-index (port-index port)) (i 0))
(cond ((port-pending-eof? port)
(set-port-index! port lp-port-index)
(values #f i))
((< lp-port-index the-port-limit)
(let ((the-read-char
(ascii->char (byte-vector-ref
(port-buffer port) lp-port-index))))
(cond ((char-set-contains? cset the-read-char)
(lp (+ lp-port-index 1) (+ i 1)))
(else
(set-port-index! port lp-port-index)
(values #f i)))))
(else (set-port-index! port 0)
(set-port-limit! port 0)
(values 'port-buffer-exhausted i))))))
;;; (read-line [port delim-action])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Read in a line of data. Input is terminated by either a newline or EOF.
;;; The newline is trimmed from the string by default.
(define charset:newline (char-set #\newline))
(define (read-line . rest) (apply read-delimited charset:newline rest))
;;; (read-paragraph [port handle-delim])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1999-09-23 13:46:46 -04:00
(define blank-line-regexp (rx bos (* white) #\newline eos))
(define (read-paragraph . args)
(let-optionals args ((port (current-input-port))
(handle-delim 'trim))
;; First, skip all blank lines.
(let lp ()
(let ((line (read-line port 'concat)))
(cond ((eof-object? line)
(if (eq? handle-delim 'split) (values line line) line))
1999-09-23 13:46:46 -04:00
((regexp-search? blank-line-regexp line) (lp))
;; Then, read in non-blank lines.
(else
(let lp ((lines (list line)))
(let ((line (read-line port 'concat)))
(if (and (string? line)
1999-09-23 13:46:46 -04:00
(not (regexp-search? blank-line-regexp line)))
(lp (cons line lines))
;; Return the paragraph
(let ((->str (lambda (lns) (apply string-append (reverse lns)))))
(case handle-delim
((trim) (->str lines))
((concat)
(->str (if (eof-object? line) lines (cons line lines))))
((split)
(values (->str lines) line))
(else (error "Illegal HANDLE-DELIM parameter to READ-PARAGRAPH")))))))))))))