From 08ca76b741179c1abf32aae229f7fc73cdbf958e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 12 Jan 2017 08:12:48 -0800 Subject: [PATCH] extend `{read,peek}-char-or-special` Support an external implementation of `read-syntax` by exposing functionality that is currently internal to `read-syntax`: a srcloc argument to a "special"-producing port function and wrapping special results to reliably distinguish them from characters. --- pkgs/base/info.rkt | 2 +- .../scribblings/reference/custom-ports.scrbl | 19 ++++---- .../scribblings/reference/string-input.scrbl | 45 ++++++++++++----- pkgs/racket-test-core/tests/racket/file.rktl | 4 +- racket/src/racket/src/portfun.c | 48 +++++++++++++++---- racket/src/racket/src/schvers.h | 4 +- 6 files changed, 89 insertions(+), 33 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 04e08e1610..9f83dff004 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "6.8.0.1") +(define version "6.8.0.2") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/custom-ports.scrbl b/pkgs/racket-doc/scribblings/reference/custom-ports.scrbl index ac690a17ba..80766573a9 100644 --- a/pkgs/racket-doc/scribblings/reference/custom-ports.scrbl +++ b/pkgs/racket-doc/scribblings/reference/custom-ports.scrbl @@ -381,17 +381,20 @@ The arguments implement the port as follows: @itemize[ - @item{When the special read is triggered by @racket[read-syntax] - or @racket[read-syntax/recursive], the + @item{When the special read is triggered by @racket[read-syntax], + @racket[read-syntax/recursive] the procedure is passed four arguments that represent a source - location.} + location. Four arguments for a source location are also provided when + the read is triggered by @racket[read-byte-or-special], + @racket[read-char-or-special], @racket[peek-byte-or-special], or + @racket[peek-char-or-special] with a non-@racket[#f] source name.} @item{When the special read is triggered by @racket[read], - @racket[read-byte-or-special], - @racket[read-char-or-special], @racket[peek-byte-or-special], or - @racket[peek-char-or-special], the procedure is passed no arguments - if it accepts zero arguments, otherwise it is passed four arguments - that are all @racket[#f].} + @racket[read/recursive], or other calls to + @racket[read-byte-or-special], @racket[read-char-or-special], + @racket[peek-byte-or-special], or @racket[peek-char-or-special], the + procedure is passed no arguments if it accepts zero arguments, + otherwise it is passed four arguments that are all @racket[#f].} ] diff --git a/pkgs/racket-doc/scribblings/reference/string-input.scrbl b/pkgs/racket-doc/scribblings/reference/string-input.scrbl index 31c537ed83..cbd23d189c 100644 --- a/pkgs/racket-doc/scribblings/reference/string-input.scrbl +++ b/pkgs/racket-doc/scribblings/reference/string-input.scrbl @@ -366,19 +366,32 @@ with @racket[skip-bytes-amt] and @racket[progress] arguments like @racket[peek-bytes-avail!].} -@defproc[(read-char-or-special [in input-port? (current-input-port)]) +@defproc[(read-char-or-special [in input-port? (current-input-port)] + [source-name any/c #f] + [special-wrap (or/c (any/c -> any/c) #f) #f]) (or/c char? eof-object? any/c)]{ -Like @racket[read-char], but if the input port returns a @tech{special} -value (through a value-generating procedure in a custom port; see -@secref["customport"] and @secref["special-comments"] for -details), then the @tech{special} value is returned.} +Like @racket[read-char], but if the input port returns a +@tech{special} value (through a value-generating procedure in a custom +port, where @racket[source-name] is provided to the procedure; see +@secref["customport"] and @secref["special-comments"] for details), +then the result of applying @racket[special-wrap] to the +@tech{special} value is returned. A @racket[#f] value for +@racket[special-wrap] is treated the same as the identity function. -@defproc[(read-byte-or-special [in input-port? (current-input-port)]) +@history[#:changed "6.8.0.2" @elem{Added the @racket[sourve-name] and + @racket[special-wrap] arguments.}]} + +@defproc[(read-byte-or-special [in input-port? (current-input-port)] + [source-name any/c #f] + [special-wrap (or/c (any/c -> any/c) #f) #f]) (or/c byte? eof-object? any/c)]{ Like @racket[read-char-or-special], but reads and returns a byte -instead of a character.} +instead of a character. + +@history[#:changed "6.8.0.2" @elem{Added the @racket[sourve-name] and + @racket[special-wrap] arguments.}]} @defproc[(peek-char [in input-port? (current-input-port)] [skip-bytes-amt exact-nonnegative-integer? 0]) @@ -396,20 +409,30 @@ Like @racket[peek-char], but @tech{peeks} and returns a byte instead of a character.} @defproc[(peek-char-or-special [in input-port? (current-input-port)] - [skip-bytes-amt exact-nonnegative-integer? 0]) + [skip-bytes-amt exact-nonnegative-integer? 0] + [source-name any/c #f] + [special-wrap (or/c (any/c -> any/c) #f) #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 it is returned. + +@history[#:changed "6.8.0.2" @elem{Added the @racket[sourve-name] and + @racket[special-wrap] arguments.}]} @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]) + [progress (or/c progress-evt? #f) #f] + [source-name any/c #f] + [special-wrap (or/c (any/c -> any/c) #f) #f]) (or/c byte? eof-object? any/c)]{ Like @racket[peek-char-or-special], but @tech{peeks} and returns a byte instead of a character, and it supports a @racket[progress] argument -like @racket[peek-bytes-avail!].} +like @racket[peek-bytes-avail!]. + +@history[#:changed "6.8.0.2" @elem{Added the @racket[sourve-name] and + @racket[special-wrap] arguments.}]} @defproc[(port-progress-evt [in (and/c input-port? port-provides-progress-evts?) diff --git a/pkgs/racket-test-core/tests/racket/file.rktl b/pkgs/racket-test-core/tests/racket/file.rktl index f65203d79a..83370ecceb 100644 --- a/pkgs/racket-test-core/tests/racket/file.rktl +++ b/pkgs/racket-test-core/tests/racket/file.rktl @@ -37,10 +37,10 @@ (err/rt-test (current-error-port (current-input-port))) (test #\; peek-char this-file) (arity-test peek-char 0 2) -(arity-test peek-char-or-special 0 2) +(arity-test peek-char-or-special 0 4) (test #\; read-char this-file) (arity-test read-char 0 1) -(arity-test read-char-or-special 0 1) +(arity-test read-char-or-special 0 3) (test '(define cur-section '()) read this-file) (arity-test read 0 1) (test #\( peek-char this-file) diff --git a/racket/src/racket/src/portfun.c b/racket/src/racket/src/portfun.c index f39b2ba010..474bc6afa7 100644 --- a/racket/src/racket/src/portfun.c +++ b/racket/src/racket/src/portfun.c @@ -275,9 +275,9 @@ scheme_init_port_fun(Scheme_Env *env) GLOBAL_NONCM_PRIM("read-syntax/recursive", read_syntax_recur_f, 0, 5, env); GLOBAL_PRIM_W_ARITY2("read-language", read_language, 0, 2, 0, -1, env); GLOBAL_NONCM_PRIM("read-char", read_char, 0, 1, env); - GLOBAL_NONCM_PRIM("read-char-or-special", read_char_spec, 0, 1, env); + GLOBAL_NONCM_PRIM("read-char-or-special", read_char_spec, 0, 3, env); GLOBAL_NONCM_PRIM("read-byte", read_byte, 0, 1, env); - GLOBAL_NONCM_PRIM("read-byte-or-special", read_byte_spec, 0, 1, env); + GLOBAL_NONCM_PRIM("read-byte-or-special", read_byte_spec, 0, 3, env); GLOBAL_NONCM_PRIM("read-bytes-line", read_byte_line, 0, 2, env); GLOBAL_NONCM_PRIM("read-line", read_line, 0, 2, env); GLOBAL_NONCM_PRIM("read-string", sch_read_string, 1, 2, env); @@ -305,9 +305,9 @@ scheme_init_port_fun(Scheme_Env *env) GLOBAL_NONCM_PRIM("write-special", scheme_write_special, 1, 2, env); GLOBAL_NONCM_PRIM("write-special-avail*", scheme_write_special_nonblock, 1, 2, env); GLOBAL_NONCM_PRIM("peek-char", peek_char, 0, 2, env); - GLOBAL_NONCM_PRIM("peek-char-or-special", peek_char_spec, 0, 2, env); + GLOBAL_NONCM_PRIM("peek-char-or-special", peek_char_spec, 0, 4, env); GLOBAL_NONCM_PRIM("peek-byte", peek_byte, 0, 2, env); - GLOBAL_NONCM_PRIM("peek-byte-or-special", peek_byte_spec, 0, 3, env); + GLOBAL_NONCM_PRIM("peek-byte-or-special", peek_byte_spec, 0, 5, env); GLOBAL_NONCM_PRIM("byte-ready?", byte_ready_p, 0, 1, env); GLOBAL_NONCM_PRIM("char-ready?", char_ready_p, 0, 1, env); GLOBAL_NONCM_PRIM("newline", newline, 0, 1, env); @@ -3038,7 +3038,8 @@ static Scheme_Object * do_read_char(char *name, int argc, Scheme_Object *argv[], int peek, int spec, int is_byte) { Scheme_Object *port; - int ch; + Scheme_Object *skip, *unless_evt, *src, *spec_wrap; + int ch, pos; if (argc && !SCHEME_INPUT_PORTP(argv[0])) scheme_wrong_contract(name, "input-port?", 0, argc, argv); @@ -3049,8 +3050,7 @@ do_read_char(char *name, int argc, Scheme_Object *argv[], int peek, int spec, in port = CURRENT_INPUT_PORT(scheme_current_config()); if (peek) { - Scheme_Object *skip, *unless_evt = NULL; - + unless_evt = NULL; if (argc > 1) { skip = argv[1]; if (!(SCHEME_INTP(skip) && (SCHEME_INT_VAL(skip) >= 0)) @@ -3058,7 +3058,7 @@ do_read_char(char *name, int argc, Scheme_Object *argv[], int peek, int spec, in scheme_wrong_contract(name, "exact-nonnegative-integer?", 1, argc, argv); return NULL; } - if (argc > 2) { + if (is_byte && (argc > 2)) { if (SCHEME_TRUEP(argv[2])) { unless_evt = argv[2]; if (!SAME_TYPE(SCHEME_TYPE(unless_evt), scheme_progress_evt_type)) { @@ -3077,7 +3077,31 @@ do_read_char(char *name, int argc, Scheme_Object *argv[], int peek, int spec, in } } else skip = NULL; + } else { + unless_evt = NULL; + skip = NULL; + } + pos = (peek ? (is_byte ? 3 : 2) : 1); + if (argc > pos) { + spec_wrap = argv[pos]; + if (SCHEME_FALSEP(spec_wrap)) + spec_wrap = NULL; + else + scheme_check_proc_arity2(name, 1, pos, argc, argv, 1); + pos++; + if (argc > pos) { + src = argv[pos++]; + if (SCHEME_FALSEP(src)) + src = NULL; + } else + src = NULL; + } else { + src = NULL; + spec_wrap = NULL; + } + + if (peek) { if (spec) { if (is_byte) { ch = scheme_peek_byte_special_ok_skip(port, skip, unless_evt); @@ -3104,7 +3128,13 @@ do_read_char(char *name, int argc, Scheme_Object *argv[], int peek, int spec, in } if (ch == SCHEME_SPECIAL) { - return scheme_get_ready_special(port, NULL, peek); + src = scheme_get_ready_special(port, src, peek); + if (spec_wrap) { + Scheme_Object *a[1]; + a[0] = src; + return _scheme_tail_apply(spec_wrap, 1, a); + } else + return src; } else if (ch == EOF) return scheme_eof; else if (is_byte) diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 1c4782ee3a..f78b92cb3f 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.8.0.1" +#define MZSCHEME_VERSION "6.8.0.2" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 8 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 1 +#define MZSCHEME_VERSION_W 2 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)