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 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
|
; Code to extract the examples from the report. Written for R5RS by
; Richard Kelsey.
; This prints everything in INPUT-FILE that is between a "\begin{scheme}"
; and an "\end{scheme}" to the current output port.
(define (find-examples input-file)
(call-with-input-file input-file
(lambda (in)
(extract-text "\\begin{scheme}"
"\\end{scheme}"
(input-port->source in)
(output-port->sink (current-output-port))))))
; Turning ports into sources (thunks that generate characters) and
; sinks (procedures of one argument that consume characters).
(define (input-port->source port)
(lambda ()
(read-char port)))
(define (output-port->sink port)
(lambda (char)
(write-char char port)))
; Read characters from SOURCE, passing to SINK all characters found between
; the strings BEGIN and END.
(define (extract-text begin end source sink)
(let loop ()
(if (find-string begin source (lambda (char) (values)))
(if (find-string end source sink)
(loop)))))
; Transfer characters from SOURCE to SINK until STRING is found.
;
; We first make a circular buffer containing the first (string-length STRING)
; characters from SOURCE. We then compare the buffer with STRING to see if
; a match is found. If not, we pass the first character from the buffer to
; SINK and get the next item from SOURCE. If it's a character we put it in
; the buffer, advance the buffer one character, and continue. When we reach
; the end of SOURCE, the remaining characters in the buffer are passed to SINK.
(define (find-string string source sink)
(let ((buffer (make-circular-buffer (string-length string) source)))
(let loop ((buffer buffer))
(if (buffer-match? string buffer)
#t
(begin
(sink (car buffer))
(let ((next (source)))
(if (char? next)
(begin
(set-car! buffer next)
(loop (cdr buffer)))
(begin
(set-car! buffer #f)
(let flush-loop ((buffer (cdr buffer)))
(if (car buffer)
(begin
(sink (car buffer))
(flush-loop (cdr buffer)))
#f))))))))))
; Returns a circular list of COUNT pairs containing the first COUNT
; items from SOURCE.
(define (make-circular-buffer count source)
(let ((start (list (source))))
(let loop ((last start) (i 1))
(if (= i count)
(begin
(set-cdr! last start)
last)
(let ((next (list (source))))
(set-cdr! last next)
(loop next (+ i 1)))))
start))
; Returns #T if the contents of the BUFFER, a list of characters, matches
; STRING. This is the same as `(string=? string (list->string buffer))'
; except that it works for circular buffers.
(define (buffer-match? string buffer)
(let loop ((buffer buffer) (i 0))
(cond ((= i (string-length string))
#t)
((char=? (car buffer) (string-ref string i))
(loop (cdr buffer) (+ i 1)))
(else
#f))))
; Return a source that generates the characters from STRING. This is only
; used for testing.
(define (string-source string)
(let ((i 0))
(lambda ()
(if (= i (string-length string))
#f
(begin
(set! i (+ i 1))
(string-ref string (- i 1)))))))
|