Fix `at-exp' syntax colorer to handle non-text input

- added 'special-filter-input-port' to `racker/port'
 Merge to v5.0

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

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

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))
+        (if (or (equal? #\{ (peek-char-or-special in))
-                (equal? #\| (peek-char 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