peek-{char,byte}-or-special: add 'special option

The old reader used an internal option to short-circuit special-value
reading when a special value acts as a terminating "character". Expose
that shortcut by allowing 'special as an argument to
`peek-{char,byte}-or-special`, and update the reader to use it.

pkgs/racket-doc/scribblings/reference/string-input.scrbl

@@ -410,20 +410,39 @@ character.}
 
 @defproc[(peek-char-or-special [in input-port? (current-input-port)]
                                [skip-bytes-amt exact-nonnegative-integer? 0]
-                               [special-wrap (or/c (any/c -> any/c) #f) #f]
+                               [special-wrap (or/c (any/c -> any/c) #f 'special) #f]
                                [source-name any/c #f])
          (or/c char? eof-object? any/c)]{
 
 Like @racket[peek-char], but if the input port returns a non-byte
-value after @racket[skip-bytes-amt] byte positions, then it is returned.
+value after @racket[skip-bytes-amt] byte positions, then the result
+depends on @racket[special-wrap]:
+
+@itemlist[
+
+ @item{If @racket[special-wrap] is @racket[#f], then the special value
+       is returned (as for @racket[read-char-or-special]).}
+
+@item{If @racket[special-wrap] is a procedure, then it is applied the
+       special value to produce the result (as for
+       @racket[read-char-or-special]).}
+
+ @item{If @racket[special-wrap] is @racket['special], then
+       @racket['special] is returned in place of the special
+       value---without calling the special-value procedure that is
+       returned by the input-port implementation.}
+
+]
 
 @history[#:changed "6.8.0.2" @elem{Added the @racket[special-wrap] and
-                                   @racket[source-name] arguments.}]}
+                                   @racket[source-name] arguments.}
+         #:changed "6.90.0.16" @elem{Added @racket['special] as an option
+                                     for @racket[special-wrap].}]}
 
 @defproc[(peek-byte-or-special [in input-port? (current-input-port)]
                                [skip-bytes-amt exact-nonnegative-integer? 0]
                                [progress (or/c progress-evt? #f) #f]
-                               [special-wrap (or/c (any/c -> any/c) #f) #f]
+                               [special-wrap (or/c (any/c -> any/c) #f 'special) #f]
                                [source-name any/c #f])
          (or/c byte? eof-object? any/c)]{
 
@@ -432,7 +451,9 @@ instead of a character, and it supports a @racket[progress] argument
 like @racket[peek-bytes-avail!].
 
 @history[#:changed "6.8.0.2" @elem{Added the @racket[special-wrap] and
-                                   @racket[source-name] arguments.}]}
+                                   @racket[source-name] arguments.}
+         #:changed "6.90.0.16" @elem{Added @racket['special] as an option
+                                     for @racket[special-wrap].}]}
 
 
 @defproc[(port-progress-evt [in (and/c input-port? port-provides-progress-evts?)

pkgs/racket-test-core/tests/racket/port.rktl

@@ -368,6 +368,15 @@
 (err/rt-test (read-char infinite-voids) exn:application:mismatch?)
 (test 'void read-byte-or-special infinite-voids)
 (test 'void read-char-or-special infinite-voids)
+(test 'void peek-char-or-special infinite-voids 0)
+(test 'special peek-char-or-special infinite-voids 0 'special)
+(let ([p (make-input-port
+          'voids
+          (lambda (s) (lambda args 'void))
+          (lambda (skip s progress-evt) (lambda args (error "oops")))
+          void)])
+  (test 'special peek-char-or-special infinite-voids 0 'special)
+  (test 'void read-char-or-special infinite-voids))
 (let ([go
        (lambda (get-avail!)
 	 (define (get)

pkgs/racket-test-core/tests/racket/read.rktl

@@ -952,6 +952,49 @@
   (test #\y read-char-or-special p)
   (test 3 file-position p))
 
+;; Test read-char-or-special:
+(let ([p (make-p (list #"x" a-special #"y") (lambda (x) 5) void)])
+  (test #\x peek-char-or-special p)
+  (test 0 file-position p)
+  (test #\x peek-char-or-special p 0)
+  (test a-special peek-char-or-special p 1)
+  (test #\y peek-char-or-special p 2)
+  (test 0 file-position p)
+  (test #\x read-char-or-special p)
+  (test 1 file-position p)
+  (test a-special peek-char-or-special p)
+  (test 1 file-position p)
+  (test a-special read-char-or-special p)
+  (test 2 file-position p)
+  (test #\y peek-char-or-special p)
+  (test 2 file-position p)
+  (test #\y read-char-or-special p)
+  (test 3 file-position p))
+
+;; Reading somethign like a symbol should stop at a special
+;; without calling the special-producing procedure:
+(let* ([pos 0]
+       [p (make-input-port
+           'voids
+           (lambda (s)
+             (if (pos . < . 3)
+                 (begin
+                   (set! pos (add1 pos))
+                   (bytes-set! s 0 (char->integer #\a))
+                   1)
+                 (lambda args (error "oops/read"))))
+           (lambda (s skip progress-evt)
+             (cond
+              [((+ skip pos) . < . 3)
+               (begin
+                 (bytes-set! s 0 (char->integer #\a))
+                 1)]
+              [((+ skip pos) . < . 4)
+               (lambda args (error "oops/peek"))]
+              [else eof-object]))
+           void)])
+  (test 'aaa read p))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Test read-syntax offsets:
 

racket/src/expander/read/special.rkt

@@ -16,5 +16,9 @@
 (define-inline (read-char/special in config [source (read-config-source config)])
   (read-char-or-special in special source))
 
+;; Returns `(special 'special)` for any special value:
 (define-inline (peek-char/special in config [skip-count 0] [source (read-config-source config)])
-  (peek-char-or-special in skip-count special source))
+  (define c (peek-char-or-special in skip-count 'special source))
+  (if (eq? c 'special)
+      (special 'special)
+      c))

racket/src/io/Makefile

@@ -30,11 +30,11 @@ GENERATE_ARGS = -t main.rkt --submod main \
 io-src-generate:
 	$(RACKET) ../expander/bootstrap-run.rkt $(GENERATE_ARGS)
 
-demo: compiled/rktio.rktl
+demo: $(RKTIO_DEP)
 	$(RACO) make demo.rkt
 	$(RACKET) demo.rkt
 
-demo-thread: compiled/rktio.rktl
+demo-thread: $(RKTIO_DEP)
 	$(RACO) make demo-thread.rkt
 	$(RACKET) demo-thread.rkt
 

racket/src/io/demo.rkt

@@ -277,6 +277,8 @@
 (test '#&(special src 1 1 2) (read-byte-or-special specialist box 'src))
 (test '(special #f #f #f #f) (peek-byte-or-special specialist))
 (test '#&(special src 1 2 3) (peek-byte-or-special specialist 0 #f box 'src))
+(test 'special (peek-byte-or-special specialist 0 #f 'special 'src))
+(test 'special (peek-char-or-special specialist 0 'special 'src))
 
 (let-values ([(i o) (make-pipe)])
   (struct my-i (i) #:property prop:input-port 0)

racket/src/io/host/bootstrap-rktio.rkt

@@ -78,7 +78,7 @@
             (rktio_get_last_error rktio-name)
             (rktio_get_last_error_step rktio-name))))
 
-(include "../compiled/rktio.rktl")
+(include "../../rktio/rktio.rktl")
 
 (define rktio_NULL #f)
 
@@ -215,4 +215,4 @@
                                          'rktio_do_install_os_signal_handler rktio_do_install_os_signal_handler
                                          'rktio_get_ctl_c_handler rktio_get_ctl_c_handler]
                                         form ...))
-                   (include "../compiled/rktio.rktl")))
+                   (include "../../rktio/rktio.rktl")))

racket/src/io/port/special-input.rkt

@@ -35,7 +35,7 @@
   (check who input-port? orig-in)
   (check who exact-nonnegative-integer? skip-k)
   (check who #:or-false evt? progress-evt)
-  (check who #:or-false (procedure-arity-includes/c 1) special-wrap)
+  (check who special-wrap-for-peek? #:contract special-wrap-for-peek/c-str special-wrap)
   (when progress-evt
     (check-progress-evt who progress-evt orig-in))
   (let ([in (->core-input-port orig-in)])
@@ -64,7 +64,7 @@
                                   [source-name #f])
   (check who input-port? in)
   (check who exact-nonnegative-integer? skip-k)
-  (check who #:or-false (procedure-arity-includes/c 1) special-wrap)
+  (check who special-wrap-for-peek? #:contract special-wrap-for-peek/c-str special-wrap)
   (extract-special-value (do-peek-char who in skip-k #:special-ok? #t)
                          in source-name skip-k
                          special-wrap))
@@ -74,21 +74,33 @@
 (define (extract-special-value v in source-name delta special-wrap)
   (cond
     [(procedure? v)
-     (define special
+     (cond
-       (cond
+       [(eq? special-wrap 'special)
-         [(not source-name)
+        'special]
+       [else
+        (define special
           (cond
-            [(procedure-arity-includes? v 0)
+            [(not source-name)
-             (v)]
+             (cond
+               [(procedure-arity-includes? v 0)
+                (v)]
+               [else
+                (v #f #f #f #f)])]
             [else
-             (v #f #f #f #f)])]
+             (define-values (line col pos) (port-next-location in))
-         [else
+             (v source-name
-          (define-values (line col pos) (port-next-location in))
+                line
-          (v source-name
+                (and col (+ col delta))
-             line
+                (and pos (+ pos delta)))]))
-             (and col (+ col delta))
+        (if special-wrap
-             (and pos (+ pos delta)))]))
+            (special-wrap special)
-     (if special-wrap
+            special)])]
-         (special-wrap special)
-         special)]
     [else v]))
+
+(define (special-wrap-for-peek? w)
+  (or (not w) (eq? w 'special) (and (procedure? w)
+                                    (procedure-arity-includes? w 1))))
+
+(define special-wrap-for-peek/c-str
+  "(or/c (any/c -> any/c) #f 'special)")
+                

racket/src/racket/src/portfun.c

@@ -143,6 +143,7 @@ ROSYM static Scheme_Object *lf_symbol;
 ROSYM static Scheme_Object *crlf_symbol;
 ROSYM static Scheme_Object *module_symbol;
 ROSYM static Scheme_Object *string_symbol;
+ROSYM static Scheme_Object *special_symbol;
 
 READ_ONLY static Scheme_Object *default_read_handler;
 READ_ONLY static Scheme_Object *default_display_handler;
@@ -200,6 +201,7 @@ scheme_init_port_fun(Scheme_Startup_Env *env)
   REGISTER_SO(crlf_symbol);
   REGISTER_SO(module_symbol);
   REGISTER_SO(string_symbol);
+  REGISTER_SO(special_symbol);
 
   any_symbol      = scheme_intern_symbol("any");
   any_one_symbol  = scheme_intern_symbol("any-one");
@@ -208,6 +210,7 @@ scheme_init_port_fun(Scheme_Startup_Env *env)
   crlf_symbol     = scheme_intern_symbol("return-linefeed");
   module_symbol   = scheme_intern_symbol("module");
   string_symbol   = scheme_intern_symbol("string");
+  special_symbol  = scheme_intern_symbol("special");
 
   scheme_write_proc   = scheme_make_noncm_prim(sch_write, "write",    1, 2);
   scheme_display_proc = scheme_make_noncm_prim(display,   "display",  1, 2);
@@ -2982,8 +2985,17 @@ do_read_char(char *name, int argc, Scheme_Object *argv[], int peek, int spec, in
     spec_wrap = argv[pos];
     if (SCHEME_FALSEP(spec_wrap))
       spec_wrap = NULL;
-    else if (!scheme_fast_check_arity(spec_wrap, 1))
+    else if (!(peek && SAME_OBJ(spec_wrap, special_symbol))
-      scheme_check_proc_arity2(name, 1, pos, argc, argv, 1);
+             && !scheme_fast_check_arity(spec_wrap, 1)) {
+      if (!scheme_check_proc_arity2(NULL, 1, pos, argc, argv, 1)) {
+        scheme_wrong_contract(name,
+                              (peek
+                               ? "(or/c (any/c -> any/c) #f 'special)"
+                               : "(or/c (any/c -> any/c) #f)"),
+                              pos, argc, argv);
+        return NULL;
+      }
+    }
     pos++;
     if (argc > pos)
       src = argv[pos++];
@@ -3021,6 +3033,8 @@ do_read_char(char *name, int argc, Scheme_Object *argv[], int peek, int spec, in
   }
 
   if (ch == SCHEME_SPECIAL) {
+    if (SAME_OBJ(spec_wrap, special_symbol))
+      return special_symbol;
     src = scheme_get_ready_special(port, src, peek);
     if (spec_wrap) {
       Scheme_Object *a[1];