From ef4eb585d7e86c46f39ebcd796f457f5025b050e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 11 Jul 2019 12:09:21 -0600 Subject: [PATCH] reader: repair readtable re-mapping of `#` comment forms Thanks to @LiberalArtist for the bug report and examples. --- .../scribblings/reference/readtables.scrbl | 4 +- .../tests/racket/readtable.rktl | 51 +++++++++++++++++++ racket/src/expander/read/readtable.rkt | 8 +++ racket/src/expander/read/whitespace.rkt | 6 +-- racket/src/racket/src/startup.inc | 16 ++++-- 5 files changed, 78 insertions(+), 7 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/readtables.scrbl b/pkgs/racket-doc/scribblings/reference/readtables.scrbl index 855b6dce92..0ba679c3ae 100644 --- a/pkgs/racket-doc/scribblings/reference/readtables.scrbl +++ b/pkgs/racket-doc/scribblings/reference/readtables.scrbl @@ -115,7 +115,9 @@ The possible combinations for @racket[key], @racket[mode], and @item{@racket[(code:line _char _like-char _readtable)] --- causes @racket[_char] to be parsed in the same way that @racket[_like-char] is parsed in @racket[_readtable], where @racket[_readtable] can be - @racket[#f] to indicate the default readtable. Mapping a character to + @racket[#f] to indicate the default readtable. (The mapping of + @racket[_char] does not apply after @litchar{#}, which is configured + separately via @racket['dispatch-macro].) Mapping a character to the same actions as @litchar{|} in the default reader means that the character starts quoting for symbols, and the same character terminates the quote; in contrast, mapping a character to the same diff --git a/pkgs/racket-test-core/tests/racket/readtable.rktl b/pkgs/racket-test-core/tests/racket/readtable.rktl index dd2760dc57..8225303ba5 100644 --- a/pkgs/racket-test-core/tests/racket/readtable.rktl +++ b/pkgs/racket-test-core/tests/racket/readtable.rktl @@ -387,7 +387,58 @@ (try #\( #\) #\[ #\]) (try #\[ #\] #\( #\)) (try #\{ #\} #\[ #\])) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that comment forms can be redirecteed by a readtable + +(let ([readstr (lambda (s) + (read (open-input-string s)))]) + (define readtable + (make-readtable #f + #\$ #\; #f + #\* #\| #f + #\? #\! #f)) + + (parameterize ([current-readtable readtable]) + (test 'x readstr "$this\nx") + ;; char mapping doesn't affect `#...` + (err/rt-test (readstr "#$datum x") exn:fail:read?) + (err/rt-test (readstr "#* ??? *# x") exn:fail:read?) + (err/rt-test (readstr "#?/other\nx") exn:fail:read?))) + +(let ([readstr (lambda (s) + (read (open-input-string s)))]) + (define saw #f) + (define ((comment->x msg) ch in src line col pos) + (test #f equal? saw msg) ; only once + (set! saw msg) + 'x) + + (define readtable0 + (make-readtable #f + #\; 'terminating-macro (comment->x "line") + #\; 'dispatch-macro (comment->x "s-exp") + #\| 'dispatch-macro (comment->x "block") + #\! 'dispatch-macro (comment->x "unix"))) + + (define readtable + (make-readtable readtable0 + #\$ #\; readtable0 + #\* #\| readtable0 + #\? #\! readtable0)) + + (parameterize ([current-readtable readtable]) + (for ([str '(";this" "$this" "#;datum" "#$datum" "#|a block|#" "#* x *#" "#!/usr/bin/env racket" "#?/other")] + [kind '("line" "line" "s-exp" error "block" error "unix" error)]) + (cond + [(eq? kind 'error) + (err/rt-test (readstr str) exn:fail:read?)] + [else + (set! saw #f) + (test 'x readstr str) + (test kind values saw)])))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/racket/src/expander/read/readtable.rkt b/racket/src/expander/read/readtable.rkt index 0e46e83ef0..4825bb6145 100644 --- a/racket/src/expander/read/readtable.rkt +++ b/racket/src/expander/read/readtable.rkt @@ -13,6 +13,7 @@ readtable-mapping current-readtable readtable-effective-char + readtable-effective-char/# effective-char readtable-handler readtable-dispatch-handler @@ -136,6 +137,13 @@ [(char? target) target] [else #\x])) ; return some non-special character +;; Similar to `readtable-effective-char`, but for a character after +;; `#` to detect whether it has the usual meaning +(define (readtable-effective-char/# rt c) + (cond + [(and rt (hash-ref (readtable-dispatch-ht rt) c #f)) #f] + [else c])) + (define (effective-char c config) (readtable-effective-char (read-config-readtable config) c)) diff --git a/racket/src/expander/read/whitespace.rkt b/racket/src/expander/read/whitespace.rkt index 47e1871205..8bf1b3524c 100644 --- a/racket/src/expander/read/whitespace.rkt +++ b/racket/src/expander/read/whitespace.rkt @@ -43,13 +43,13 @@ (result-special-comment) (skip-loop #f))] [(and (char=? #\# ec) - (eqv? #\| (peek-char/special in config 0 source))) + (eqv? #\| (readtable-effective-char/# rt (peek-char/special in config 0 source)))) (skip-pipe-comment! c in config) (if (read-config-keep-comment? config) (result-special-comment) (skip-loop #f))] [(and (char=? #\# ec) - (eqv? #\! (peek-char/special in config 0 source)) + (eqv? #\! (readtable-effective-char/# rt (peek-char/special in config 0 source))) (let ([c3 (peek-char/special in config 1 source)]) (or (eqv? #\space c3) (eqv? #\/ c3)))) @@ -58,7 +58,7 @@ (result-special-comment) (skip-loop #f))] [(and (char=? #\# ec) - (eqv? #\; (peek-char/special in config 0 source))) + (eqv? #\; (readtable-effective-char/# rt (peek-char/special in config 0 source)))) (consume-char in #\;) (define v (read-one #f in config)) (when (eof-object? v) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 71223d2848..b99e967733 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -52860,6 +52860,10 @@ static const char *startup_source = "(let-values(((target_0)(hash-ref(readtable-char-ht rt_0) c_0 #f)))" "(if(not target_0)(let-values() c_0)(if(char? target_0)(let-values() target_0)(let-values() '#\\x)))))))" "(define-values" +"(readtable-effective-char/#)" +"(lambda(rt_0 c_0)" +"(begin(if(if rt_0(hash-ref(readtable-dispatch-ht rt_0) c_0 #f) #f)(let-values() #f)(let-values() c_0)))))" +"(define-values" "(effective-char)" "(lambda(c_0 config_0)" "(begin" @@ -53152,6 +53156,8 @@ static const char *startup_source = "(if(if(char=? '#\\# ec_0)" "(eqv?" " '#\\|" +"(readtable-effective-char/#" +" rt_0" "(let-values(((in_1) in_0)((skip-count_0) 0)((source_1) source_0))" "(let-values(((c_1)" "(peek-char-or-special" @@ -53159,7 +53165,7 @@ static const char *startup_source = " skip-count_0" " 'special" " source_1)))" -"(if(eq? c_1 'special)(special1.1 'special) c_1))))" +"(if(eq? c_1 'special)(special1.1 'special) c_1)))))" " #f)" "(let-values()" "(begin" @@ -53170,6 +53176,8 @@ static const char *startup_source = "(if(if(char=? '#\\# ec_0)" "(if(eqv?" " '#\\!" +"(readtable-effective-char/#" +" rt_0" "(let-values(((in_1) in_0)" "((skip-count_0) 0)" "((source_1) source_0))" @@ -53179,7 +53187,7 @@ static const char *startup_source = " skip-count_0" " 'special" " source_1)))" -"(if(eq? c_1 'special)(special1.1 'special) c_1))))" +"(if(eq? c_1 'special)(special1.1 'special) c_1)))))" "(let-values(((c3_0)" "(let-values(((in_1) in_0)" "((skip-count_0) 1)" @@ -53206,6 +53214,8 @@ static const char *startup_source = "(if(if(char=? '#\\# ec_0)" "(eqv?" " '#\\;" +"(readtable-effective-char/#" +" rt_0" "(let-values(((in_1) in_0)" "((skip-count_0) 0)" "((source_1) source_0))" @@ -53215,7 +53225,7 @@ static const char *startup_source = " skip-count_0" " 'special" " source_1)))" -"(if(eq? c_1 'special)(special1.1 'special) c_1))))" +"(if(eq? c_1 'special)(special1.1 'special) c_1)))))" " #f)" "(let-values()" "(let-values((()(begin(consume-char in_0 '#\\;)(values))))"