diff --git a/collects/mzlib/port.rkt b/collects/mzlib/port.rkt index a7a033772e..a703db51ba 100644 --- a/collects/mzlib/port.rkt +++ b/collects/mzlib/port.rkt @@ -839,6 +839,43 @@ (when close-orig? (close-input-port port))))))) + + +(define special-filter-input-port + (lambda (p filter [close? #t]) + (unless (input-port? p) + (raise-type-error 'special-filter-input-port "input port" p)) + (unless (and (procedure? filter) + (procedure-arity-includes? filter 2)) + (raise-type-error 'special-filter-input-port "procedure (arity 2)" filter)) + (make-input-port + (object-name p) + (lambda (s) + (let ([v (read-bytes-avail!* s p)]) + (cond + [(eq? v 0) (wrap-evt p (lambda (x) 0))] + [(procedure? v) (filter v s)] + [else v]))) + (lambda (s skip evt) + (let ([v (peek-bytes-avail!* s skip evt p)]) + (cond + [(eq? v 0) + (choice-evt + (wrap-evt p (lambda (x) 0)) + (if evt (wrap-evt evt (lambda (x) #f)) never-evt))] + [(procedure? v) (filter v s)] + [else v]))) + (lambda () + (when close? (close-input-port p))) + (and (port-provides-progress-evts? p) + (lambda () (port-progress-evt p))) + (and (port-provides-progress-evts? p) + (lambda (n evt target-evt) (port-commit-peeked n evt target-evt p))) + (lambda () (port-next-location p)) + (lambda () (port-count-lines! p)) + (let-values ([(l c p) (port-next-location p)]) + p)))) + ;; ---------------------------------------- (define (poll-or-spawn go) @@ -1695,6 +1732,7 @@ peeking-input-port relocate-input-port transplant-input-port + special-filter-input-port relocate-output-port transplant-output-port merge-input diff --git a/collects/scribblings/reference/port-lib.scrbl b/collects/scribblings/reference/port-lib.scrbl index 6a553a1b33..3a5fbe51b9 100644 --- a/collects/scribblings/reference/port-lib.scrbl +++ b/collects/scribblings/reference/port-lib.scrbl @@ -475,12 +475,34 @@ is enabled for the resulting port. The default is @scheme[void].} Like @scheme[transplant-input-port], but for output ports.} +@defproc[(special-filter-input-port [in input-port?] + [proc (procedure? bytes? . -> . (or/c exact-nonnegative-integer? + eof-object? + procedure? + evt?))] + [close? any/c #t]) + input-port?]{ + +Produces an input port that that is equivalent to @scheme[in], except +that when @scheme[in] produces a procedure to access a special value, +@scheme[proc] is applied to the procedure to allow the special value +to be replaced with an alternative. The @scheme[proc] is called with +the special-value procedure and the byte string that was given to the +port's read or peek function (see @racket[make-input-port]), and the +result is used as te read or peek function's result. The +@racket[proc] can modify the byte string to substitute a byte for the +special value, but the byte string is guaranteed only to hold at least +one byte. + +If @scheme[close?] is true, then closing the resulting input port also +closes @racket[in].} + @; ---------------------------------------------------------------------- @section{Port Events} -@defproc[(eof-evt [in input-port?]) evt?] +@defproc[(eof-evt [in input-port?]) evt?]{ Returns a @tech{synchronizable event} is that is ready when @scheme[in] produces an @scheme[eof]. If @scheme[in] produces a @@ -516,7 +538,7 @@ a special non-byte value during the read attempt.} @defproc[(read-bytes!-evt [bstr (and/c bytes? (not/c immutable?))] [in input-port?]) - evt?] + evt?]{ Like @scheme[read-bytes-evt], except that the read bytes are placed into @scheme[bstr], and the number of bytes to read corresponds to @@ -595,7 +617,7 @@ cancelled.} @defproc[(regexp-match-evt [pattern (or/c string? bytes? regexp? byte-regexp?)] - [in input-port?]) any] + [in input-port?]) any]{ Returns a @tech{synchronizable event} that is ready when @scheme[pattern] matches the stream of bytes/characters from diff --git a/collects/syntax-color/scribble-lexer.rkt b/collects/syntax-color/scribble-lexer.rkt index 04d157d837..64f03583ed 100644 --- a/collects/syntax-color/scribble-lexer.rkt +++ b/collects/syntax-color/scribble-lexer.rkt @@ -1,5 +1,6 @@ #lang scheme/base -(require "scheme-lexer.rkt") +(require "scheme-lexer.rkt" + racket/port) (provide scribble-inside-lexer scribble-lexer) @@ -30,7 +31,11 @@ #f #rx".*?(?:(?=[@\r\n])|$)" #f - #f)))]) + #f)))] + [in (special-filter-input-port in + (lambda (v s) + (bytes-set! s 0 (char->integer #\.)) + 1))]) (let-values ([(line col pos) (port-next-location in)] [(l) (car mode)]) @@ -61,11 +66,11 @@ (define (enter-@ comment-k) (cond - [(equal? #\; (peek-char in)) + [(equal? #\; (peek-char-or-special in)) ;; Comment (read-char in) - (if (or (equal? #\{ (peek-char in)) - (equal? #\| (peek-char in))) + (if (or (equal? #\{ (peek-char-or-special in)) + (equal? #\| (peek-char-or-special in))) ;; Bracketed comment: (let-values ([(end-line end-col end-pos) (port-next-location in)]) (comment-k "@;" @@ -94,7 +99,7 @@ [else (let ([new-mode (cond - [(equal? #\| (peek-char in)) + [(equal? #\| (peek-char-or-special in)) (read-char in) (list* (make-scheme 'bar (+ offset pos)) (no-backup mode))] @@ -153,7 +158,7 @@ '|}|) ;; Better complex paren? (no-backup mode)))))) - (if (eof-object? (peek-char in)) + (if (eof-object? (peek-char-or-special in)) (values eof 'eof #f