add `port-set-next-location!'; make prompt read handler use it

Closes PR 12035

collects/readline/pread.rkt

@@ -100,7 +100,7 @@
 (define (readline-bytes/hist p force-keep?)
   (when (eq? readline-output-port (current-output-port))
     (let-values ([(line col pos) (port-next-location readline-output-port)])
-      (when (< 0 col) (newline readline-output-port))))
+      (when (and col (positive? col)) (newline readline-output-port))))
   (let ([s (readline-bytes p)]) (add-to-history s force-keep?) s))
 
 (exit-handler

collects/scribblings/reference/custom-ports.scrbl

@@ -4,7 +4,7 @@
 @title[#:tag "customport"]{Custom Ports}
 
 The @racket[make-input-port] and @racket[make-output-port] procedures
-create custom ports with arbitrary control procedures (much like
+create @deftech{custom ports} with arbitrary control procedures (much like
 implementing a device driver). Custom ports are mainly useful to
 obtain fine control over the action of committing bytes as read or
 written.

collects/scribblings/reference/eval.scrbl

@@ -329,7 +329,14 @@ result of
 @racketblock[
 (let ([in ((current-get-interaction-input-port))])
   ((current-read-interaction) (object-name in) in))
-]}
+]
+
+If the input and output ports are both terminals (in the sense of
+@racket[terminal-port?]) and if the output port appears to be counting
+lines (because @racket[port-next-location] returns a non-@racket[#f]
+line and column), then the output port's line is incremented and its
+column is reset to @racket[0] via @racket[set-port-next-location!] 
+before returning the read result.}
 
 
 @defparam[current-get-interaction-input-port proc (-> input-port?)]{

collects/scribblings/reference/port-line-counting.scrbl

@@ -38,6 +38,11 @@ the port becomes unknown, and line and column tacking is disabled.
 Return-linefeed combinations are treated as a single character
 position only when line and column counting is enabled.
 
+@tech{Custom ports} can define their own counting functions, which are
+not subject to the rules above, except that the counting functions are
+invoked only when tracking is specifically enabled with
+@racket[port-count-lines!].
+
 @;------------------------------------------------------------------------
 
 @defproc[(port-count-lines! [port port?]) void?]{
@@ -81,6 +86,18 @@ Even with line counting enabled, a port may return @racket[#f] values
 if it somehow cannot keep track of lines, columns, or positions.}
 
 
+@defproc[(set-port-next-location! [port port?]
+                                  [line (or/c exact-positive-integer? #f)]
+                                  [column (or/c exact-nonnegative-integer? #f)]
+                                  [position (or/c exact-positive-integer? #f)])
+         void?]{
+
+Sets the next line, column, and position for @racket[port]. If line
+counting has not been enabled for @racket[port] or if @racket[port] is
+a @tech{custom port} that defines its own counting function, then 
+@racket[set-port-next-location!] has no effect.}
+
+
 @defboolparam[port-count-lines-enabled on?]{
 
 A parameter that determines whether line counting is enabled

collects/scribblings/reference/pretty-print.scrbl

@@ -14,7 +14,10 @@ default @racket[print] mode, but with newlines and whitespace inserted
 to avoid lines longer than @racket[(pretty-print-columns)], as
 controlled by @racket[(pretty-print-current-style-table)]. The printed
 form ends in a newline, unless the @racket[pretty-print-columns]
-parameter is set to @racket['infinity].
+parameter is set to @racket['infinity]. When @racket[port] has line
+counting enabled (see @secref["linecol"]), then printing is sensitive
+to the column when printing starts---both for determining an initial
+line break and indenting subsequent lines.
 
 In addition to the parameters defined in this section,
 @racket[pretty-print] conforms to the @racket[print-graph],

collects/tests/racket/port.rktl

@@ -514,7 +514,7 @@
 					  (adjust-locs line col pos))))])
 	     (port-count-lines! p2)
 	     p2)))])
-  (let ([plain (let ([p (open-input-string "Hello\n\n world")])
+  (let ([plain (let ([p (open-input-string "Hello\n\n world 1\n2")])
 		 (port-count-lines! p)
 		 p)]
 	[double (mk (lambda (l c p)
@@ -536,6 +536,14 @@
     (test-values '(#f #f #f) (lambda () (port-next-location none)))
     (err/rt-test (port-next-location bad))
 
+    ;; `set-port-next-location!' should have no effect on custom ports:
+    (set-port-next-location! double 1 1 1)
+    (test-values '(2 10 12) (lambda () (port-next-location double)))
+    (set-port-next-location! none 1 1 1)
+    (test-values '(#f #f #f) (lambda () (port-next-location none)))
+    (set-port-next-location! bad 1 1 1)
+    (err/rt-test (port-next-location bad))
+
     (let ([stx (read-syntax #f plain)])
       (test 3 syntax-line stx)
       (test 1 syntax-column stx)
@@ -555,7 +563,19 @@
     
     (test-values '(3 6 14) (lambda () (port-next-location plain)))
     (test-values '(6 12 28) (lambda () (port-next-location double)))
-    (test-values '(#f #f #f) (lambda () (port-next-location none)))))
+    (test-values '(#f #f #f) (lambda () (port-next-location none)))
+
+    ;; Check `set-port-next-location!':
+    (set-port-next-location! plain 100 13 1023)
+    (test-values '(100 13 1023) (lambda () (port-next-location plain)))
+    (let ([stx (read-syntax #f plain)])
+      (test 100 syntax-line stx)
+      (test 14 syntax-column stx)
+      (test 1024 syntax-position stx))
+    (let ([stx (read-syntax #f plain)])
+      (test 101 syntax-line stx)
+      (test 0 syntax-column stx)
+      (test 1026 syntax-position stx))))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;  Check that if the initial commit thread is killed, then

doc/release-notes/racket/HISTORY.txt

@@ -1,6 +1,11 @@
+Version 5.1.2.3
+Added set-port-next-location! and changed the default prompt 
+ read handler to use it when input and output ar terminals
+
 Version 5.1.2.2
 Changed the location-creation semantics of internal definitions
  and `letrec-syntaxes+values'
+Added unsafe-list-ref and unsafe-list-tail
 
 Version 5.1.2, July 2011
 Replaced syntax certificates with syntax taints:

src/racket/include/mzwin.def

@@ -408,6 +408,7 @@ EXPORTS
  scheme_tell_line
  scheme_tell_column
  scheme_tell_all
+ scheme_set_port_location
  scheme_count_lines
  scheme_close_input_port
  scheme_close_output_port

src/racket/include/mzwin3m.def

@@ -423,6 +423,7 @@ EXPORTS
  scheme_tell_line
  scheme_tell_column
  scheme_tell_all
+ scheme_set_port_location
  scheme_count_lines
  scheme_close_input_port
  scheme_close_output_port

src/racket/include/racket.exp

@@ -425,6 +425,7 @@ scheme_output_tell
 scheme_tell_line
 scheme_tell_column
 scheme_tell_all
+scheme_set_port_location
 scheme_count_lines
 scheme_close_input_port
 scheme_close_output_port

src/racket/include/racket3m.exp

@@ -431,6 +431,7 @@ scheme_output_tell
 scheme_tell_line
 scheme_tell_column
 scheme_tell_all
+scheme_set_port_location
 scheme_count_lines
 scheme_close_input_port
 scheme_close_output_port

src/racket/src/fun.c

@@ -8548,7 +8548,7 @@ scheme_default_prompt_read_handler(int argc, Scheme_Object *argv[])
 {
   Scheme_Config *config;
   Scheme_Object *port, *reader, *getter;
-  Scheme_Object *inport, *name, *a[2];
+  Scheme_Object *inport, *name, *a[4], *v;
 
   config = scheme_current_config();
   port = scheme_get_param(config, MZCONFIG_OUTPUT_PORT);
@@ -8569,7 +8569,31 @@ scheme_default_prompt_read_handler(int argc, Scheme_Object *argv[])
 
   a[0] = name;
   a[1] = inport;
-  return _scheme_apply(reader, 2, a);
+  v = _scheme_apply(reader, 2, a);
+
+  a[0] = inport;
+  if (SCHEME_TRUEP(scheme_terminal_port_p(1, a))) {
+    a[0] = port;
+    if (SCHEME_TRUEP(scheme_terminal_port_p(1, a))) {
+      intptr_t line, col, pos;
+      scheme_tell_all(port, &line, &col, &pos);
+      if ((col > 0) && (line > 0)) {
+        /* input and output are terminals (assume the same one), 
+           and the output port counts lines: tell output port
+           that it's on a new line: */
+        a[0] = port;
+        a[1] = scheme_make_integer(line + 1);
+        a[2] = scheme_make_integer(0);
+        if (pos > 0)
+          a[3] = scheme_make_integer(pos + 2); /* incremet plus 0-adjust */
+        else
+          a[3] = scheme_false;
+        scheme_set_port_location(4, a);
+      }
+    }
+  }
+
+  return v;
 }
   
 Scheme_Object *

src/racket/src/port.c

@@ -3386,19 +3386,69 @@ scheme_tell_column (Scheme_Object *port)
   return col;
 }
 
+
+static void extract_next_location(const char *who, int argc, Scheme_Object **a, int delta,
+                                  intptr_t *_line, intptr_t *_col, intptr_t *_pos)
+{
+  int i, j;
+  intptr_t v;
+  intptr_t line = -1, col = -1, pos = -1;
+
+  for (j = 0; j < 3; j++) {
+    v = -1;
+    i = j + delta;
+    if (SCHEME_TRUEP(a[i])) {
+      if (scheme_nonneg_exact_p(a[i])) {
+        if (SCHEME_INTP(a[i])) {
+          v = SCHEME_INT_VAL(a[i]);
+          if ((j != 1) && !v) {
+            v = -1;
+          }
+        }
+      }
+      if (v == -1) {
+        if (argc < 0)
+          a[0] = a[i];
+        scheme_wrong_type(who, 
+                          ((j == 1) ? "non-negative exact integer or #f" : "positive exact integer or #f"),
+                          ((argc > 0) ? i : -1), argc, a);
+        return;
+      }
+    }
+
+    switch (j) {
+    case 0:
+      line = v;
+      break;
+    case 1:
+      col = v;
+      break;
+    case 2:
+      pos = v;
+      break;
+    }
+  }
+
+  /* Internally, positions count from 0 instead of 1 */
+  if (pos > -1)
+    pos--;
+
+  if (_line) *_line = line;
+  if (_col) *_col = col;
+  if (_pos) *_pos = pos;
+}
+
 void
 scheme_tell_all (Scheme_Object *port, intptr_t *_line, intptr_t *_col, intptr_t *_pos)
 {
   Scheme_Port *ip;
-  intptr_t line = -1, col = -1, pos = -1;
   
   ip = scheme_port_record(port);
 
   if (ip->count_lines && ip->location_fun) {
     Scheme_Location_Fun location_fun;
     Scheme_Object *r, *a[3];
-    intptr_t v;
+    int got;
-    int got, i;
     
     location_fun = ip->location_fun;
     r = location_fun(ip);
@@ -3416,47 +3466,36 @@ scheme_tell_all (Scheme_Object *port, intptr_t *_line, intptr_t *_col, intptr_t
     a[1] = scheme_multiple_array[1];
     a[2] = scheme_multiple_array[2];
 
-    for (i = 0; i < 3; i++) {
+    extract_next_location("user port next-location", -1, a, 0, _line, _col, _pos);
-      v = -1;
-      if (SCHEME_TRUEP(a[i])) {
-	if (scheme_nonneg_exact_p(a[i])) {
-	  if (SCHEME_INTP(a[i])) {
-	    v = SCHEME_INT_VAL(a[i]);
-	    if ((i != 1) && !v) {
-	      a[0] = a[i];
-	      scheme_wrong_type("user port next-location", 
-				((i == 1) ? "non-negative exact integer or #f" : "positive exact integer or #f"),
-				-1, -1, a);
-	      return;
-	    }
-	  }
-	}
-      }
-      switch(i) {
-      case 0:
-	line = v;
-	break;
-      case 1:
-	col = v;
-	break;
-      case 2:
-	pos = v;
-	break;
-      }
-    }
-
-    /* Internally, positions count from 0 instead of 1 */
-    if (pos > -1)
-      pos--;
   } else {
+    intptr_t line, col, pos;
+
     line = scheme_tell_line(port);
     col = scheme_tell_column(port);
     pos = scheme_tell(port);
-  }
 
-  if (_line) *_line = line;
+    if (_line) *_line = line;
-  if (_col) *_col = col;
+    if (_col) *_col = col;
-  if (_pos) *_pos = pos;  
+    if (_pos) *_pos = pos;
+  }
+}
+
+void scheme_set_port_location(int argc, Scheme_Object **argv)
+{
+  Scheme_Port *ip;
+  intptr_t line, col, pos;
+  
+  extract_next_location("set-port-next-location!", argc, argv, 
+                        1, &line, &col, &pos);
+
+  
+  ip = scheme_port_record(argv[0]);
+  
+  if (ip->count_lines) {
+    ip->readpos = pos;
+    ip->lineNumber = line;
+    ip->column = col;
+  }
 }
 
 void

src/racket/src/portfun.c

@@ -125,6 +125,7 @@ static Scheme_Object *global_port_print_handler(int, Scheme_Object **args);
 static Scheme_Object *global_port_count_lines(int, Scheme_Object **args);
 static Scheme_Object *port_count_lines(int, Scheme_Object **args);
 static Scheme_Object *port_next_location(int, Scheme_Object **args);
+static Scheme_Object *set_port_next_location(int, Scheme_Object **args);
 
 static Scheme_Object *sch_default_read_handler(void *ignore, int argc, Scheme_Object *argv[]);
 static Scheme_Object *sch_default_display_handler(int argc, Scheme_Object *argv[]);
@@ -254,7 +255,7 @@ scheme_init_port_fun(Scheme_Env *env)
   GLOBAL_PRIM_W_ARITY2("load",                  load,                   1, 1, 0, -1, env);
   GLOBAL_PRIM_W_ARITY2("make-pipe",             sch_pipe,               0, 3, 2,  2, env);
   GLOBAL_PRIM_W_ARITY2("port-next-location",    port_next_location,     1, 1, 3,  3, env);
-
+  GLOBAL_PRIM_W_ARITY("set-port-next-location!",  set_port_next_location, 4, 4, env);
 
   GLOBAL_NONCM_PRIM("read",                           read_f,                         0, 1, env);
   GLOBAL_NONCM_PRIM("read/recursive",                 read_recur_f,                   0, 4, env);
@@ -4094,6 +4095,16 @@ static Scheme_Object *port_next_location(int argc, Scheme_Object *argv[])
   return scheme_values(3, a);
 }
 
+static Scheme_Object *set_port_next_location(int argc, Scheme_Object *argv[])
+{
+  if (!SCHEME_INPUT_PORTP(argv[0]) && !SCHEME_OUTPUT_PORTP(argv[0]))
+    scheme_wrong_type("set-port-next-location!", "port", 0, argc, argv);
+
+  scheme_set_port_location(argc, argv);
+  
+  return scheme_void;
+}
+
 typedef struct {
   MZTAG_IF_REQUIRED
   Scheme_Config *config;

src/racket/src/schemef.h

@@ -807,6 +807,7 @@ MZ_EXTERN intptr_t scheme_output_tell(Scheme_Object *port);
 MZ_EXTERN intptr_t scheme_tell_line(Scheme_Object *port);
 MZ_EXTERN intptr_t scheme_tell_column(Scheme_Object *port);
 MZ_EXTERN void scheme_tell_all(Scheme_Object *port, intptr_t *line, intptr_t *col, intptr_t *pos);
+MZ_EXTERN void scheme_set_port_location(int argc, Scheme_Object **argv);
 MZ_EXTERN void scheme_count_lines(Scheme_Object *port);
 MZ_EXTERN void scheme_close_input_port(Scheme_Object *port);
 MZ_EXTERN void scheme_close_output_port(Scheme_Object *port);

src/racket/src/schemex.h

@@ -662,6 +662,7 @@ intptr_t (*scheme_output_tell)(Scheme_Object *port);
 intptr_t (*scheme_tell_line)(Scheme_Object *port);
 intptr_t (*scheme_tell_column)(Scheme_Object *port);
 void (*scheme_tell_all)(Scheme_Object *port, intptr_t *line, intptr_t *col, intptr_t *pos);
+void (*scheme_set_port_location)(int argc, Scheme_Object **argv);
 void (*scheme_count_lines)(Scheme_Object *port);
 void (*scheme_close_input_port)(Scheme_Object *port);
 void (*scheme_close_output_port)(Scheme_Object *port);

src/racket/src/schemex.inc

@@ -473,6 +473,7 @@
   scheme_extension_table->scheme_tell_line = scheme_tell_line;
   scheme_extension_table->scheme_tell_column = scheme_tell_column;
   scheme_extension_table->scheme_tell_all = scheme_tell_all;
+  scheme_extension_table->scheme_set_port_location = scheme_set_port_location;
   scheme_extension_table->scheme_count_lines = scheme_count_lines;
   scheme_extension_table->scheme_close_input_port = scheme_close_input_port;
   scheme_extension_table->scheme_close_output_port = scheme_close_output_port;

src/racket/src/schemexm.h

@@ -473,6 +473,7 @@
 #define scheme_tell_line (scheme_extension_table->scheme_tell_line)
 #define scheme_tell_column (scheme_extension_table->scheme_tell_column)
 #define scheme_tell_all (scheme_extension_table->scheme_tell_all)
+#define scheme_set_port_location (scheme_extension_table->scheme_set_port_location)
 #define scheme_count_lines (scheme_extension_table->scheme_count_lines)
 #define scheme_close_input_port (scheme_extension_table->scheme_close_input_port)
 #define scheme_close_output_port (scheme_extension_table->scheme_close_output_port)

src/racket/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1026
+#define EXPECTED_PRIM_COUNT 1027
 #define EXPECTED_UNSAFE_COUNT 78
 #define EXPECTED_FLFXNUM_COUNT 68
 #define EXPECTED_FUTURES_COUNT 11

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.1.2.2"
+#define MZSCHEME_VERSION "5.1.2.3"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 1
 #define MZSCHEME_VERSION_Z 2
-#define MZSCHEME_VERSION_W 2
+#define MZSCHEME_VERSION_W 3
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)