From 1efc894ada66fa0978f9e6794c6a2749a4a36f0f Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 26 Jul 2012 09:23:21 -0600
Subject: [PATCH] toward fixed interaction between positions and peek-commits

When a `port-commit-peeked' succeeds, position information should
(appear to) be updated. This patch synchronizes commits and
position information for primitive ports, but synchronizing
them for user ports remains a problem.
---
 collects/tests/racket/portlib.rktl | 51 ++++++++++++++++++------------
 src/racket/src/port.c              | 27 ++++++++++++++--
 2 files changed, 54 insertions(+), 24 deletions(-)

diff --git a/collects/tests/racket/portlib.rktl b/collects/tests/racket/portlib.rktl
index 15bbd2a7b7..e37766a77a 100644
--- a/collects/tests/racket/portlib.rktl
+++ b/collects/tests/racket/portlib.rktl
@@ -876,27 +876,36 @@
     (test #t list? r)))
 
 ;; check proper locking for concurrent access:
-(for ([i 100])
-  (let* ([p (make-limited-input-port
-             (open-input-string "A\nB\nC\nD\n") 
-             4)]
-         [N 6]
-         [chs (for/list ([i N])
-                (let ([ch (make-channel)])
-                  (thread
-                   (lambda ()
-                     (when (even? i) (sleep))
-                     (channel-put ch (list (sync (read-bytes-line-evt p))
-                                           (file-position p)))))
-                  ch))]
-         [rs (for/list ([ch chs])
-               (channel-get ch))])
-    (test 2 apply + (for/list ([r rs]) (if (bytes? (car r)) 1 0)))
-    (test #t values (for/and ([r rs]) 
-                      (if (eof-object? (car r))
-                          (eq? (cadr r) 4)
-                          (and (memq (cadr r) '(2 4)) #t))))))
-
+(for ([mk-p (list
+             (lambda ()
+               (open-input-string "A\nB\n"))
+             (lambda ()
+               (make-limited-input-port
+                (open-input-string "A\nB\nC\nD\n") 
+                4)))])
+  (for ([i 100])
+    (let* ([p (mk-p)]
+           [N 6]
+           [chs (for/list ([i N])
+                  (let ([ch (make-channel)])
+                    (thread
+                     (lambda ()
+                       (when (even? i) (sleep))
+                       (channel-put ch (list (sync (read-bytes-line-evt p))
+                                             (file-position p)
+                                             (let ()
+                                               (define-values (l c pos) (port-next-location p))
+                                               (sub1 pos))))))
+                    ch))]
+           [rs (for/list ([ch chs])
+                 (channel-get ch))])
+      (test 2 apply + (for/list ([r rs]) (if (bytes? (car r)) 1 0)))
+      (for ([r rs]) 
+        (if (eof-object? (car r))
+            (test 4 cadr r)
+            (let ([memq? (lambda (a l) (and (memq a l) #t))])
+              (test #t memq? (cadr r) '(2 4))
+              (test #t = (cadr r) (caddr r))))))))
 
 (let-values ([(in out) (make-pipe-with-specials)])
   (struct str (v)    
diff --git a/src/racket/src/port.c b/src/racket/src/port.c
index f632689dd0..5a469fa51f 100644
--- a/src/racket/src/port.c
+++ b/src/racket/src/port.c
@@ -2150,11 +2150,11 @@ intptr_t scheme_get_byte_string_unless(const char *who,
   while (1) {
     SCHEME_USE_FUEL(1);
 
-    CHECK_PORT_CLOSED(who, "input", port, ip->closed);
-
     if (ip->input_lock)
       scheme_wait_input_allowed(ip, only_avail);
 
+    CHECK_PORT_CLOSED(who, "input", port, ip->closed);
+
     if (only_avail == -1) {
       /* We might need to break. */
       if (scheme_current_thread->external_break) {
@@ -3819,6 +3819,15 @@ scheme_need_wakeup (Scheme_Object *port, void *fds)
           CHECK_PORT_CLOSED(who, "output", port, ((Scheme_Output_Port *)port)->closed); \
         }
 
+static void check_input_port_lock(Scheme_Port *ip)
+{
+  if (SCHEME_INPORTP(ip)) {
+    Scheme_Input_Port *iip = (Scheme_Input_Port *)ip;
+    if (iip->input_lock)
+      scheme_wait_input_allowed(iip, 0);
+  }
+}
+
 intptr_t
 scheme_tell (Scheme_Object *port)
 {
@@ -3827,6 +3836,8 @@ scheme_tell (Scheme_Object *port)
 
   ip = scheme_port_record(port);
   
+  check_input_port_lock(ip);
+  
   CHECK_IOPORT_CLOSED("get-file-position", ip);
 
   if (!ip->count_lines || (ip->position < 0))
@@ -3848,6 +3859,8 @@ scheme_tell_line (Scheme_Object *port)
   if (!ip->count_lines || (ip->position < 0))
     return -1;
 
+  check_input_port_lock(ip);
+
   CHECK_IOPORT_CLOSED("get-file-line", ip);
 
   line = ip->lineNumber;
@@ -3865,7 +3878,9 @@ scheme_tell_column (Scheme_Object *port)
 
   if (!ip->count_lines || (ip->position < 0))
     return -1;
-  
+
+  check_input_port_lock(ip);
+
   CHECK_IOPORT_CLOSED("get-file-column", ip);
 
   col = ip->column;
@@ -4015,6 +4030,9 @@ scheme_close_input_port (Scheme_Object *port)
 
   ip = scheme_input_port_record(port);
 
+  if (ip->input_lock && scheme_force_port_closed)
+    scheme_wait_input_allowed(ip, 0);
+
   if (!ip->closed) {
     if (ip->close_fun) {
       Scheme_Close_Input_Fun f = ip->close_fun;
@@ -5100,6 +5118,9 @@ scheme_file_position(int argc, Scheme_Object *argv[])
 
     ip = scheme_input_port_record(argv[0]);
 
+    if (ip->input_lock)
+      scheme_wait_input_allowed(ip, 0);
+
     if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
       f = ((Scheme_Input_File *)ip->port_data)->f;
 #ifdef MZ_FDS