From 87865cb1bd583118343277e5db80da57bda24e43 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Thu, 20 Jan 2011 12:13:01 -0700
Subject: [PATCH] Fixing PR11649

---
 collects/tests/xml/srcloc.rkt   | 38 ++++++++++++++++++++
 collects/xml/private/reader.rkt | 63 +++++++++++++++++++--------------
 2 files changed, 75 insertions(+), 26 deletions(-)
 create mode 100644 collects/tests/xml/srcloc.rkt

diff --git a/collects/tests/xml/srcloc.rkt b/collects/tests/xml/srcloc.rkt
new file mode 100644
index 0000000000..f4682efdd6
--- /dev/null
+++ b/collects/tests/xml/srcloc.rkt
@@ -0,0 +1,38 @@
+#lang racket
+(require xml
+         tests/eli-tester)
+
+(define (ppos p) 
+  (define-values (line col pos) (port-next-location p))
+  pos)
+
+; open-input-string is broken
+(define (the-test first? second?)
+  (define is (open-input-string "abcdef"))
+  
+  (test #:failure-prefix (format "~a ~a" first? second?)
+        (test
+         (when first? (port-count-lines! is))
+         (ppos is) => 1 (read-char is)
+         (ppos is) => 2 (read-char is)
+         (ppos is) => 3 (read-char is)
+         (when second? (port-count-lines! is))
+         (ppos is) => 4 (read-char is)
+         (ppos is) => 5 (read-char is)
+         (ppos is) => 6 (read-char is))))
+(test (the-test #f #f)
+      (the-test #t #f)
+      (the-test #f #t)
+      (the-test #t #t))
+
+(define p (open-input-string "abcdef"))
+(for ([x (in-range 0 6)]) (read-char p))
+(define pos (ppos p))
+
+(define exn
+  (with-handlers ((exn:fail? values))
+    (read-xml/element p)))
+
+(test
+ pos => 7
+ (srcloc-position (first ((exn:srclocs-accessor exn) exn))) => 7)
\ No newline at end of file
diff --git a/collects/xml/private/reader.rkt b/collects/xml/private/reader.rkt
index 7aa63cfe1c..b635c6b468 100644
--- a/collects/xml/private/reader.rkt
+++ b/collects/xml/private/reader.rkt
@@ -26,21 +26,19 @@
                   [(misc0 start) (read-misc in pos)])
       (make-document (make-prolog misc0 #f empty)
                      (read-xml-element-helper pos in start)
-                     (let ([loc-before (pos)])
-                       (let-values ([(misc1 end-of-file) (read-misc in pos)])
-                         (unless (eof-object? end-of-file)
-                           (let ([loc-after (pos)])
-                             (parse-error (list
-                                           (make-srcloc
-                                            (object-name in)
-                                            #f
-                                            #f
-                                            (location-offset loc-before)
-                                            (- (location-offset loc-after)
-                                               (location-offset loc-before))))
-                                          "extra stuff at end of document ~e"
-                                          end-of-file)))
-                         misc1))))))
+                     (let-values ([(misc1 end-of-file) (read-misc in pos)])
+                       (unless (EOF? end-of-file)
+                         (parse-error (list
+                                       (make-srcloc
+                                        (object-name in)
+                                        #f
+                                        #f
+                                        (location-offset (source-start end-of-file))
+                                        (- (location-offset (source-stop end-of-file))
+                                           (location-offset (source-start end-of-file)))))
+                                      "extra stuff at end of document ~e"
+                                      end-of-file))
+                       misc1)))))
 
 ;; read-xml/element : [Input-port] -> Element
 (define read-xml/element
@@ -54,15 +52,26 @@
   (cond
     [(start-tag? start) (read-element start in pos)]
     [(element? start) start]
-    [else (parse-error (list
-                        (make-srcloc
-                         (object-name in)
-                         #f
-                         #f
-                         1
-                         (- (location-offset (pos)) 1)))
-                       "expected root element - received ~e"
-                       (if (pcdata? start) (pcdata-string start) start))]))
+    [else 
+     (parse-error
+      (list
+       (make-srcloc
+        (object-name in)
+        #f
+        #f
+        ; XXX Some data structures should really be changed to be sources
+        (if (source? start)
+            (location-offset (source-start start))
+            #f)
+        (if (source? start)
+            (- (location-offset (source-stop start))
+               (location-offset (source-start start)))
+            #f)))
+      "expected root element - received ~e"
+      (cond
+        [(pcdata? start) (pcdata-string start)]
+        [(EOF? start) eof]
+        [else start]))]))
 
 ;; read-misc : Input-port (-> Location) -> (listof Misc) Token
 (define (read-misc in pos)
@@ -92,7 +101,7 @@
                              body))])
       (let ([x (lex in pos)])
         (cond
-          [(eof-object? x)
+          [(EOF? x)
            (parse-error (list
                          (make-srcloc
                           (object-name in)
@@ -159,11 +168,13 @@
     [(apos) "'"]
     [else #f]))
 
+(define-struct (EOF source) ())
+
 ;; lex : Input-port (-> Location) -> (U Token special)
 (define (lex in pos)
   (let ([c (peek-char-or-special in)])
     (cond
-      [(eof-object? c) c]
+      [(eof-object? c) (EOF (pos) (pos))]
       [(eq? c #\&) (lex-entity in pos)]
       [(eq? c #\<) (lex-tag-cdata-pi-comment in pos)]
       [(not (char? c)) (read-char-or-special in)]