From 0c73b84692ff89398717e7171a7ec6a968e6249f Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 24 Jul 2009 04:37:34 +0000
Subject: [PATCH] PR 10344

svn: r15545
---
 collects/parser-tools/parser-tools.scrbl    |  6 ++--
 collects/syntax-color/scheme-lexer.ss       | 17 ++++++++++
 collects/tests/syntax-color/scheme-lexer.ss | 36 +++++++++++++++------
 3 files changed, 48 insertions(+), 11 deletions(-)

diff --git a/collects/parser-tools/parser-tools.scrbl b/collects/parser-tools/parser-tools.scrbl
index 00654b88a5..fc41727d39 100644
--- a/collects/parser-tools/parser-tools.scrbl
+++ b/collects/parser-tools/parser-tools.scrbl
@@ -216,8 +216,10 @@ are a few examples, using @scheme[:] prefixed SRE syntax:
        no @scheme[(special)] rule is present, the lexer returns
        @scheme[(void)].}]
 
-    End-of-files, specials, special-comments and special-errors can
-    never be part of a lexeme with surrounding characters.
+    End-of-files, specials, special-comments and special-errors cannot
+    be parsed via a rule using an ordinary regular expression
+    (but dropping down and manipulating the port to handle them
+     is possible in some situations).
 
     Since the lexer gets its source information from the port, use
     @scheme[port-count-lines!] to enable the tracking of line and
diff --git a/collects/syntax-color/scheme-lexer.ss b/collects/syntax-color/scheme-lexer.ss
index 7a81d0e43d..681cc14fd4 100644
--- a/collects/syntax-color/scheme-lexer.ss
+++ b/collects/syntax-color/scheme-lexer.ss
@@ -235,6 +235,18 @@
         (else
          (read-char i)
          (cons next (special-read-line i))))))
+  
+  (define (read-line/skip-over-specials i)
+    (let loop ()
+      (let ((next (peek-char-or-special i)))
+        (cond
+          ((or (eq? next #\newline) (eof-object? next))
+           null)
+          (else
+           (read-char-or-special i)
+           (if (char? next)
+               (cons next (loop))
+               (loop)))))))
           
   (define (get-here-string start-pos i)
     (let* ((ender (list->string (special-read-line i)))
@@ -273,6 +285,11 @@
       (ret lexeme 'constant #f start-pos end-pos)]
      [keyword (ret lexeme 'parenthesis #f start-pos end-pos)]
      [str (ret lexeme 'string #f start-pos end-pos)]
+     [";"
+      (values (apply string (read-line/skip-over-specials input-port)) 'comment #f 
+              (position-offset start-pos)
+              (get-offset input-port))]
+     #;
      [line-comment
       (ret lexeme 'comment #f start-pos end-pos)]
      ["#;"
diff --git a/collects/tests/syntax-color/scheme-lexer.ss b/collects/tests/syntax-color/scheme-lexer.ss
index afd6f07f8c..79d366ede1 100644
--- a/collects/tests/syntax-color/scheme-lexer.ss
+++ b/collects/tests/syntax-color/scheme-lexer.ss
@@ -1,4 +1,6 @@
-;; Not tested:
+#lang scheme
+
+;; Not well tested:
 ;;  Non-character input data (i.e. specials)
 ;;  The R5RS part of numbers
 ;; 
@@ -40,22 +42,35 @@
      (cons (make-string (- end start) (char kind))
            (lex f p)))))
       
-(define (test input expected . num-toks)
-  (let* ((l (lex scheme-lexer (open-input-string input)))
+(define (test input expected [e-n (chunks (string->list expected))])
+  (let* ([p (input->port input)]
+         (l (lex scheme-lexer p))
          (s (apply string-append l)))
+    (close-input-port p)
     (unless (string=? s expected)
-      (printf "input   : ~a~n" input)
+      (printf "input   : ~s~n" input)
       (printf "output  : ~s~n" s)
       (printf "expected: ~s~n~n" expected))
-    (let ((e-n
-           (cond
-             ((not (null? num-toks)) (car num-toks))
-             (else (chunks (string->list expected)))))
-          (a-n (length l)))
+    (let ((a-n (length l)))
       (unless (= e-n a-n)
         (printf "input   : ~a~n" input)
         (printf "expected: ~a tokens~n" e-n)
         (printf "got     : ~a tokens~n~n" a-n)))))
+
+(define (input->port input) 
+  (let-values ([(in out) (make-pipe-with-specials)])
+    (thread
+     (λ ()
+       (let loop ([input input])
+         (cond
+           [(list? input) 
+            (for-each loop input)]
+           [(string? input)
+            (display input out)]
+           [else
+            (write-special input out)]))
+       (close-output-port out)))
+    in))
       
 ;; Delimiters
 (test " " " ")
@@ -400,11 +415,14 @@ end-string
       
       
 ;; Comments
+(test ";ab" ";;;")
 (test #<<end-string
 1 a; asd\
 1 ;a
 end-string
     "c i;;;;;; c ;;")
+(test '(";a" 1 "b") ";;;;" 1)  ;; a special comment
+(test '(";a" 1 "b\n1" 1) ";;;; cn" 4)
 
 (test "#||#" ";;;;")
 (test "#|#||#|#" ";;;;;;;;")