suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix bugs in the reader, especially related to readtables

Browse Source 
Closes #1118, but improved testing exposed many other bugs.
This commit is contained in:
Matthew Flatt 2015-11-04 07:51:56 -07:00
parent 86f19474ca
commit 5a8d2e4204
8 changed files with 166 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
pkgs/racket-doc/scribblings/reference/fixnums.scrbl
View File

@ -104,6 +104,10 @@ Two @tech{fxvectors} are @racket[equal?] if they have the same length,
and if the values in corresponding slots of the @tech{fxvectors} are and if the values in corresponding slots of the @tech{fxvectors} are
@racket[equal?]. @racket[equal?].
A printed @tech{fxvector} starts with @litchar{#fx(}, optionally with
a number between the @litchar{#fx} and
@litchar{(}. @see-read-print["vector" #:print "vectors"]{fxvectors}
@defproc[(fxvector? [v any/c]) boolean?]{ @defproc[(fxvector? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{fxvector}, @racket[#f] otherwise.} Returns @racket[#t] if @racket[v] is a @tech{fxvector}, @racket[#f] otherwise.}

4
pkgs/racket-doc/scribblings/reference/flonums.scrbl
View File

@ -163,6 +163,10 @@ Two @tech{flvectors} are @racket[equal?] if they have the same length,
and if the values in corresponding slots of the @tech{flvectors} are and if the values in corresponding slots of the @tech{flvectors} are
@racket[equal?]. @racket[equal?].
A printed @tech{flvector} starts with @litchar{#fl(}, optionally with
a number between the @litchar{#fl} and
@litchar{(}. @see-read-print["vector" #:print "vectors"]{flvectors}
@defproc[(flvector? [v any/c]) boolean?]{ @defproc[(flvector? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{flvector}, @racket[#f] otherwise.} Returns @racket[#t] if @racket[v] is a @tech{flvector}, @racket[#f] otherwise.}

2
pkgs/racket-doc/scribblings/reference/printer.scrbl
View File

@ -288,7 +288,7 @@ all @tech{quotable}, then the vector @racket[print]s as
and a closing @litchar{)}. A vector is @tech{quotable} when all of and a closing @litchar{)}. A vector is @tech{quotable} when all of
its elements are @tech{quotable}. its elements are @tech{quotable}.
In @racket[write] or @racket[display] mode, an @tech{flvector} prints In @racket[write] or @racket[display] mode, a @tech{flvector} prints
like a @tech{vector}, but with a @litchar{#fl} prefix instead of like a @tech{vector}, but with a @litchar{#fl} prefix instead of
@litchar{#}. A @tech{fxvector} similarly prints with a @litchar{#fx} @litchar{#}. A @tech{fxvector} similarly prints with a @litchar{#fx}
prefix instead of @litchar{#}. The @racket[print-vector-length] prefix instead of @litchar{#}. The @racket[print-vector-length]

2
pkgs/racket-doc/scribblings/reference/reader.scrbl
View File

@ -631,7 +631,7 @@ The elements of the vector are recursively read until a matching
lists (see @secref["parse-pair"]). A delimited @litchar{.} is not lists (see @secref["parse-pair"]). A delimited @litchar{.} is not
allowed among the vector elements. In the case of @tech{flvectors}, allowed among the vector elements. In the case of @tech{flvectors},
the recursive read for element is implicitly prefixed with @litchar{#i} the recursive read for element is implicitly prefixed with @litchar{#i}
and must produce a @tech{flonum}. In the case of @tech{flvectors}, and must produce a @tech{flonum}. In the case of @tech{fxvectors},
the recursive read for element is implicitly prefixed with @litchar{#e} the recursive read for element is implicitly prefixed with @litchar{#e}
and must produce a @tech{fixnum}. and must produce a @tech{fixnum}.

2
pkgs/racket-doc/scribblings/reference/readtables.scrbl
View File

@ -67,7 +67,7 @@ otherwise.
} }
@defproc[(make-readtable [readtable readtable?] @defproc[(make-readtable [readtable (or/c readtable? #f)]
[key (or/c char? #f)] [key (or/c char? #f)]
[mode (or/c (or/c 'terminating-macro [mode (or/c (or/c 'terminating-macro
'non-terminating-macro 'non-terminating-macro

68
pkgs/racket-test-core/tests/racket/read.rktl
View File

@ -2,7 +2,7 @@
(load-relative "loadtest.rktl") (load-relative "loadtest.rktl")
(Section 'reading) (Section 'reading)
(define readstr (define core-readstr
(lambda (s) (lambda (s)
(let* ([o (open-input-string s)] (let* ([o (open-input-string s)]
[read (lambda () (read o))]) [read (lambda () (read o))])
@ -12,6 +12,37 @@
last last
(loop v))))))) (loop v)))))))
(define (readstr s)
(if (current-readtable)
(core-readstr s)
;; Try using a readtable that behaves the same as the default,
;; since that triggers some different paths in the reader:
(let* ([normal (with-handlers ([exn:fail? values])
(core-readstr s))]
[c-normal (adjust-result-to-compare normal)]
[rt (adjust-result-to-compare
(with-handlers ([exn:fail? values])
(parameterize ([current-readtable (make-readtable (current-readtable))])
(core-readstr s))))])
(if (equal? c-normal rt)
(if (exn? normal)
(raise normal)
normal)
(list "different with readtable" s c-normal rt)))))
(define (adjust-result-to-compare v)
;; Make results from two readstrs comparable
(cond
[(hash? v)
(for/fold ([ht (hash)]) ([(k hv) (in-hash v)])
(hash-update ht
(if (eq? k v) 'SELF k)
(lambda (vht)
(hash-set vht hv #t))
(hash)))]
[(exn? v) (exn-message v)]
[else v]))
(define readerrtype (define readerrtype
(lambda (x) x)) (lambda (x) x))
@ -54,6 +85,9 @@
(err/rt-test (readstr "(8 . 9 . ]") exn:fail:read?) (err/rt-test (readstr "(8 . 9 . ]") exn:fail:read?)
(err/rt-test (readstr "(8 . 9 . 1 . )") exn:fail:read?) (err/rt-test (readstr "(8 . 9 . 1 . )") exn:fail:read?)
(err/rt-test (readstr "(8 . 9 . 1 . 10)") exn:fail:read?) (err/rt-test (readstr "(8 . 9 . 1 . 10)") exn:fail:read?)
(err/rt-test (readstr "(8 . 9 . #;1)") exn:fail:read?)
(err/rt-test (readstr "(8 . 9 . ;\n)") exn:fail:read?)
(err/rt-test (readstr "(8 . 9 . #|x|#)") exn:fail:read?)
(let ([w-suffix (let ([w-suffix
(lambda (s) (lambda (s)
@ -857,6 +891,30 @@
(err/rt-test (read (make-p (list #"|x" a-special #"y|") (lambda (x) 1) void)) exn:fail:read:non-char?)) (err/rt-test (read (make-p (list #"|x" a-special #"y|") (lambda (x) 1) void)) exn:fail:read:non-char?))
(run-delim-special a-special) (run-delim-special a-special)
(run-delim-special special-comment) (run-delim-special special-comment)
(parameterize ([current-readtable (make-readtable #f)])
(run-delim-special special-comment))
(require racket/flonum
racket/fixnum)
(define (run-comment-special)
(test (list 5) read (make-p (list #"(" special-comment #"5)") (lambda (x) 1) void))
(test (list 5) read (make-p (list #"(5" special-comment #")") (lambda (x) 1) void))
(test (cons 1 5) read (make-p (list #"(1 . " special-comment #"5)") (lambda (x) 1) void))
(test (cons 1 5) read (make-p (list #"(1 . 5" special-comment #")") (lambda (x) 1) void))
(err/rt-test (read (make-p (list #"(1 . " special-comment #")") (lambda (x) 1) void)) exn:fail:read?)
(test (list 2 1 5) read (make-p (list #"(1 . 2 . " special-comment #"5)") (lambda (x) 1) void))
(test (list 2 1 a-special 5) read (make-p (list #"(1 . 2 ." a-special #"5)") (lambda (x) 1) void))
(test (list 2 1 5) read (make-p (list #"(1 . " special-comment #"2 . 5)") (lambda (x) 1) void))
(test (list 2 1 5) read (make-p (list #"(1 . 2 " special-comment #" . 5)") (lambda (x) 1) void))
(test (vector 1 2 5) read (make-p (list #"#(1 2 " special-comment #"5)") (lambda (x) 1) void))
(test (flvector 1.0) read (make-p (list #"#fl(1.0 " special-comment #")") (lambda (x) 1) void))
(test (fxvector 1) read (make-p (list #"#fx(1 " special-comment #")") (lambda (x) 1) void))
(err/rt-test (read (make-p (list #"#fl(1.0 " a-special #")") (lambda (x) 1) void)) exn:fail:read?)
(err/rt-test (read (make-p (list #"#fx(1 " a-special #")") (lambda (x) 1) void)) exn:fail:read?))
(run-comment-special)
(parameterize ([current-readtable (make-readtable #f)])
(run-comment-special))
;; Test read-char-or-special: ;; Test read-char-or-special:
(let ([p (make-p (list #"x" a-special #"y") (lambda (x) 5) void)]) (let ([p (make-p (list #"x" a-special #"y") (lambda (x) 5) void)])
@ -1134,6 +1192,9 @@
(test #t equal? (fxvector 1000 76 100000 100000 100000 100000 100000 100000 100000 100000) (readstr "#fx10(1000 76 100000)")) (test #t equal? (fxvector 1000 76 100000 100000 100000 100000 100000 100000 100000 100000) (readstr "#fx10(1000 76 100000)"))
(test #t equal? (flvector 0.0 0.0 0.0) (readstr "#fl3()")) (test #t equal? (flvector 0.0 0.0 0.0) (readstr "#fl3()"))
(test #t equal? (flvector 2.0 1.0 1.0) (readstr "#fl3(2 1)")) (test #t equal? (flvector 2.0 1.0 1.0) (readstr "#fl3(2 1)"))
(test #t equal? (flvector 2.0 1.0) (readstr "#fl(2 #;5 1)"))
(test #t equal? (flvector 2.0 1.0) (readstr "#fl(2 #|5|# 1)"))
(test #t equal? (flvector 2.0 1.0) (readstr "#fl(2 ;5\n 1)"))
(test #t equal? (fxvector 0 0 0) (readstr "#fx3()")) (test #t equal? (fxvector 0 0 0) (readstr "#fx3()"))
(test #t equal? (fxvector 2 1 1) (readstr "#fx3(2 1)")) (test #t equal? (fxvector 2 1 1) (readstr "#fx3(2 1)"))
@ -1151,6 +1212,11 @@
(err/rt-test (read-syntax 'x (open-input-string "#fx()")) exn:fail:read?) (err/rt-test (read-syntax 'x (open-input-string "#fx()")) exn:fail:read?)
(err/rt-test (read-syntax 'x (open-input-string "#fl()")) exn:fail:read?) (err/rt-test (read-syntax 'x (open-input-string "#fl()")) exn:fail:read?)
(parameterize ([current-readtable (make-readtable
#f
#f 'non-terminating-macro (lambda args 3.0))])
(test #t equal? (flvector 3.0) (readstr "#fl(3)")))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require racket/extflonum) (require racket/extflonum)

15
racket/src/racket/src/hash.c
View File

@ -1331,7 +1331,12 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi)
t = SCHEME_TYPE(o); t = SCHEME_TYPE(o);
if (t == scheme_hash_tree_indirection_type) { if (t == scheme_hash_tree_indirection_type) {
if (SAME_OBJ(o, orig_obj)) {
o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o); o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o);
orig_obj = o;
} else {
o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o);
}
t = SCHEME_TYPE(o); t = SCHEME_TYPE(o);
} }
@ -2064,10 +2069,16 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi)
return k; return k;
} }
case scheme_hash_tree_type: case scheme_hash_tree_indirection_type:
if (!SAME_OBJ(o, orig_obj)) {
o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o);
} else {
o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o);
orig_obj = o;
}
case scheme_hash_tree_type: /* ^^^ fallthrough ^^^ */
case scheme_eq_hash_tree_type: case scheme_eq_hash_tree_type:
case scheme_eqv_hash_tree_type: case scheme_eqv_hash_tree_type:
case scheme_hash_tree_indirection_type:
{ {
Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)o; Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)o;
Scheme_Object *iv, *ik; Scheme_Object *iv, *ik;

97
racket/src/racket/src/read.c
View File

@ -311,7 +311,8 @@ static int next_is_delim(Scheme_Object *port,
static int skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, static int skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
Scheme_Hash_Table **ht, Scheme_Hash_Table **ht,
Scheme_Object *indentation, Scheme_Object *indentation,
ReadParams *params, Readtable *table); ReadParams *params, Readtable *table,
Scheme_Object **prefetched);
static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, ReadParams *params, static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, ReadParams *params,
Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos,
@ -448,6 +449,7 @@ void scheme_init_read(Scheme_Env *env)
} }
builtin_fast[';'] = READTABLE_TERMINATING; builtin_fast[';'] = READTABLE_TERMINATING;
builtin_fast['\''] = READTABLE_TERMINATING; builtin_fast['\''] = READTABLE_TERMINATING;
builtin_fast['`'] = READTABLE_TERMINATING;
builtin_fast[','] = READTABLE_TERMINATING; builtin_fast[','] = READTABLE_TERMINATING;
builtin_fast['"'] = READTABLE_TERMINATING; builtin_fast['"'] = READTABLE_TERMINATING;
builtin_fast['|'] = READTABLE_MULTIPLE_ESCAPE; builtin_fast['|'] = READTABLE_MULTIPLE_ESCAPE;
@ -874,14 +876,17 @@ static int read_vector_length(Scheme_Object *port, Readtable *table, int *ch, mz
} }
if (!(*overflow)) { if (!(*overflow)) {
intptr_t old_len; uintptr_t old_len;
uintptr_t new_len;
if (*vector_length < 0) if (*vector_length < 0)
*vector_length = 0; *vector_length = 0;
old_len = *vector_length; old_len = *vector_length;
*vector_length = ((*vector_length) * 10) + ((*ch) - 48); new_len = *vector_length;
if ((*vector_length < 0)|| ((*vector_length / 10) != old_len)) { new_len = ((new_len) * 10) + ((*ch) - 48);
*vector_length = new_len;
if ((*vector_length < 0) || ((new_len / 10) != old_len)) {
*overflow = 1; *overflow = 1;
} }
} }
@ -894,6 +899,11 @@ static int read_vector_length(Scheme_Object *port, Readtable *table, int *ch, mz
vecbuf[j] = 0; vecbuf[j] = 0;
tagbuf[i] = 0; tagbuf[i] = 0;
if (!j) {
vecbuf[j] = '0';
vecbuf[0] = 0;
}
return readtable_effective_char(table, (*ch)); return readtable_effective_char(table, (*ch));
} }
@ -1847,7 +1857,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
if (!ph) { if (!ph) {
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
"read: no #%ld= preceding #%ld#", "read: no #%d= preceding #%d#",
vector_length, vector_length); vector_length, vector_length);
return scheme_void; return scheme_void;
} }
@ -1874,7 +1884,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
if (*ht) { if (*ht) {
if (scheme_hash_get(*ht, scheme_make_integer(vector_length))) { if (scheme_hash_get(*ht, scheme_make_integer(vector_length))) {
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation,
"read: multiple #%ld= tags", "read: multiple #%d= tags",
vector_length); vector_length);
return NULL; return NULL;
} }
@ -2662,7 +2672,7 @@ read_list(Scheme_Object *port,
else if (got_ch_already) else if (got_ch_already)
got_ch_already = 0; got_ch_already = 0;
else else
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table); ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, NULL);
if ((ch == EOF) && (closer != EOF)) { if ((ch == EOF) && (closer != EOF)) {
char *suggestion = ""; char *suggestion = "";
@ -2754,9 +2764,11 @@ read_list(Scheme_Object *port,
switch (shape) { switch (shape) {
case mz_shape_fl_vec: case mz_shape_fl_vec:
car = read_flonum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); car = read_flonum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT);
MZ_ASSERT(SCHEME_DBLP(car));
break; break;
case mz_shape_fx_vec: case mz_shape_fx_vec:
car = read_fixnum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); car = read_fixnum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT);
MZ_ASSERT(SCHEME_INTP(car));
break; break;
default: default:
car = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); car = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT);
@ -2770,7 +2782,7 @@ read_list(Scheme_Object *port,
retry_before_dot: retry_before_dot:
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table); ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, NULL);
effective_ch = readtable_effective_char(table, ch); effective_ch = readtable_effective_char(table, ch);
if (effective_ch == closer) { if (effective_ch == closer) {
if (shape == mz_shape_hash_elem) { if (shape == mz_shape_hash_elem) {
@ -2819,7 +2831,7 @@ read_list(Scheme_Object *port,
/* can't be eof, due to check above: */ /* can't be eof, due to check above: */
cdr = read_inner(port, stxsrc, ht, indentation, params, 0); cdr = read_inner(port, stxsrc, ht, indentation, params, 0);
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table); ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, &prefetched);
effective_ch = readtable_effective_char(table, ch); effective_ch = readtable_effective_char(table, ch);
if ((effective_ch != closer) || (shape == mz_shape_vec_plus_infix)) { if ((effective_ch != closer) || (shape == mz_shape_vec_plus_infix)) {
if (params->can_read_infix_dot if (params->can_read_infix_dot
@ -2848,13 +2860,14 @@ read_list(Scheme_Object *port,
last = pair; last = pair;
/* Make sure there's not a closing paren immediately after the dot: */ /* Make sure there's not a closing paren immediately after the dot: */
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table); ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, &prefetched);
effective_ch = readtable_effective_char(table, ch); effective_ch = readtable_effective_char(table, ch);
if ((effective_ch == closer) || (ch == EOF)) { if ((effective_ch == closer) || (ch == EOF)) {
scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation, scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation,
"read: illegal use of `%c'", ch); "read: illegal use of `%c'", ch);
return NULL; return NULL;
} }
if (!prefetched)
got_ch_already = 1; got_ch_already = 1;
} else { } else {
scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation, scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation,
@ -2881,13 +2894,24 @@ read_list(Scheme_Object *port,
} }
} else { } else {
if ((ch == SCHEME_SPECIAL) if ((ch == SCHEME_SPECIAL)
|| (table && (ch != EOF) && (shape != mz_shape_hash_list))) { || (table
&& (ch != EOF)
&& (shape != mz_shape_hash_list)
&& (shape != mz_shape_fl_vec)
&& (shape != mz_shape_fx_vec))) {
/* We have to try the read, because it might be a comment. */ /* We have to try the read, because it might be a comment. */
scheme_ungetc(ch, port); scheme_ungetc(ch, port);
prefetched = read_inner(port, stxsrc, ht, indentation, params, prefetched = read_inner(port, stxsrc, ht, indentation, params,
RETURN_FOR_SPECIAL_COMMENT); RETURN_FOR_SPECIAL_COMMENT);
if (!prefetched) if (!prefetched)
goto retry_before_dot; goto retry_before_dot;
if ((shape == mz_shape_fl_vec) && !SCHEME_DBLP(prefetched)) {
scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation,
"read: stream produced a non-flonum for flvector");
} else if ((shape == mz_shape_fx_vec) && !SCHEME_INTP(prefetched)) {
scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation,
"read: stream produced a non-fixnum for fxvector");
}
} else { } else {
got_ch_already = 1; got_ch_already = 1;
} }
@ -4111,9 +4135,12 @@ Scheme_Object *scheme_read_intern(Scheme_Object *o)
static int static int
skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
Scheme_Hash_Table **ht, Scheme_Object *indentation, Scheme_Hash_Table **ht, Scheme_Object *indentation,
ReadParams *params, Readtable *table) ReadParams *params, Readtable *table,
Scheme_Object **_prefetched)
/* If `_prefetched` is non_NULL, then a SCHEME_SPECIAL result means that
the special value has already been read, and it wasn't a comment. */
{ {
int ch; int ch, effective_ch;
int blockc_1, blockc_2; int blockc_1, blockc_2;
blockc_1 = '#'; blockc_1 = '#';
@ -4126,21 +4153,23 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
if (!(readtable_kind(table, ch, params) & READTABLE_WHITESPACE)) if (!(readtable_kind(table, ch, params) & READTABLE_WHITESPACE))
break; break;
} }
return ch;
} else { } else {
while ((ch = scheme_getc_special_ok(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isspace(ch))) {} while ((ch = scheme_getc_special_ok(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isspace(ch))) {}
} }
if (ch == ';') { effective_ch = readtable_effective_char(table, ch);
if (effective_ch == ';') {
do { do {
ch = scheme_getc_special_ok(port); ch = scheme_getc_special_ok(port);
if (ch == SCHEME_SPECIAL) effective_ch = readtable_effective_char(table, ch);
if (effective_ch == SCHEME_SPECIAL)
scheme_get_ready_read_special(port, stxsrc, ht); scheme_get_ready_read_special(port, stxsrc, ht);
} while (!is_line_comment_end(ch) && ch != EOF); } while (!is_line_comment_end(effective_ch) && (effective_ch != EOF));
goto start_over; goto start_over;
} }
if (ch == blockc_1 && (scheme_peekc_special_ok(port) == blockc_2)) { if ((effective_ch == blockc_1)
&& (readtable_effective_char(table, scheme_peekc_special_ok(port)) == blockc_2)) {
int depth = 0; int depth = 0;
int ch2 = 0; int ch2 = 0;
intptr_t col, pos, line; intptr_t col, pos, line;
@ -4150,27 +4179,29 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
(void)scheme_getc(port); /* re-read '|' */ (void)scheme_getc(port); /* re-read '|' */
do { do {
ch = scheme_getc_special_ok(port); ch = scheme_getc_special_ok(port);
effective_ch = readtable_effective_char(table, ch);
if (ch == EOF) if (effective_ch == EOF)
scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation, scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation,
"read: end of file in #| comment"); "read: end of file in #| comment");
else if (ch == SCHEME_SPECIAL) else if (effective_ch == SCHEME_SPECIAL)
scheme_get_ready_read_special(port, stxsrc, ht); scheme_get_ready_read_special(port, stxsrc, ht);
if ((ch2 == blockc_2) && (ch == blockc_1)) { if ((ch2 == blockc_2) && (effective_ch == blockc_1)) {
if (!(depth--)) if (!(depth--))
goto start_over; goto start_over;
ch = 0; /* So we don't count '#' toward an opening "#|" */ effective_ch = 0; /* So we don't count '#' toward an opening "#|" */
} else if ((ch2 == blockc_1) && (ch == blockc_2)) { } else if ((ch2 == blockc_1) && (ch == blockc_2)) {
depth++; depth++;
ch = 0; /* So we don't count '|' toward a closing "|#" */ effective_ch = 0; /* So we don't count '|' toward a closing "|#" */
} }
ch2 = ch; ch2 = effective_ch;
} while (1); } while (1);
goto start_over; goto start_over;
} }
if (ch == '#' && (scheme_peekc_special_ok(port) == ';')) { if ((effective_ch == '#')
&& (readtable_effective_char(table, scheme_peekc_special_ok(port)) == ';')) {
Scheme_Object *skipped; Scheme_Object *skipped;
intptr_t col, pos, line; intptr_t col, pos, line;
@ -4198,6 +4229,20 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
goto start_over; goto start_over;
} }
if ((ch == SCHEME_SPECIAL) && _prefetched) {
Scheme_Object *v;
intptr_t col, pos, line;
scheme_tell_all(port, &line, &col, &pos);
v = scheme_get_special(port, stxsrc, line, col, pos, 0, ht);
if (!scheme_special_comment_value(v)) {
*_prefetched = v;
return SCHEME_SPECIAL;
}
goto start_over;
}
return ch; return ch;
} }
@ -6303,7 +6348,7 @@ static void check_proc_either_arity(const char *who, int a1, int a2, int which,
{ {
if (!scheme_check_proc_arity(NULL, a1, which, argc, argv) if (!scheme_check_proc_arity(NULL, a1, which, argc, argv)
&& !scheme_check_proc_arity(NULL, a2, which, argc, argv)) { && !scheme_check_proc_arity(NULL, a2, which, argc, argv)) {
char buffer[60]; char buffer[256];
sprintf(buffer, "(or (procedure-arity-includes/c %d) (procedure-arity-includes/c %d))", a1, a2); sprintf(buffer, "(or (procedure-arity-includes/c %d) (procedure-arity-includes/c %d))", a1, a2);
scheme_wrong_contract(who, buffer, which, argc, argv); scheme_wrong_contract(who, buffer, which, argc, argv);
} }