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

Adjust use of readtable argument in read/recursive

Browse Source 
Use the given readtable more consistently to parse
delimiters in the top-level form. This change particularly
addresses problems with trying to restore the original
`(` when parsing a hash table, but allowing nested
forms to still use a different `(` mapping.
This commit is contained in:
Matthew Flatt 2015-04-15 12:30:23 -06:00
parent 968d1a3685
commit 469763ca37
4 changed files with 190 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
pkgs/racket-doc/scribblings/reference/read.scrbl
View File

@ -46,7 +46,9 @@ prefixed to the beginning of @racket[in]'s stream for the read. (To
prefix multiple characters, use @racket[input-port-append].)
The @racket[readtable] argument is used for top-level parsing to
satisfy the read request; recursive parsing within the read (e.g., to
satisfy the read request, including various delimiters of a built-in
top-level form (such as parentheses and @litchar{.} for reading a hash
table); recursive parsing within the read (e.g., to
read the elements of a list) instead uses the current readtable as
determined by the @racket[current-readtable] parameter. A reader
macro might call @racket[read/recursive] with a character and
@ -71,7 +73,12 @@ same outermost @racket[read], it will be replaced with the actual read
value before the outermost @racket[read] returns.
See @secref["readtables"] for an extended example that uses
@racket[read/recursive].}
@racket[read/recursive].
@history[#:changed "6.2.0.2" @elem{Adjusted use of @racket[readtable] to
more consistently apply to the delimiters of
a built-in form.}]}
@defproc[(read-syntax/recursive [source-name any/c (object-name in)]
[in input-port? (current-input-port)]
@ -102,7 +109,11 @@ using @racket[read-syntax/recursive] within the dynamic extent of
when the input stream starts with a comment (after whitespace).
See @secref["readtables"] for an extended example that uses
@racket[read-syntax/recursive].}
@racket[read-syntax/recursive].
@history[#:changed "6.2.0.2" @elem{Adjusted use of @racket[readtable]
in the same way as for
@racket[read/recursive].}]}
@defproc[(read-language [in input-port? (current-input-port)]

104
pkgs/racket-test-core/tests/racket/readtable.rktl
View File

@ -3,8 +3,9 @@
(Section 'readtable)
(require (only-in racket/port
[relocate-input-port relocate-input-port]))
(require (only-in racket/port
relocate-input-port
input-port-append))
(define (shift-rt-port p deltas)
(let ([p (relocate-input-port p
(add1 (car deltas))
@ -165,34 +166,77 @@
(for-each try-as-plain (string->list "()[]{}|\\ \r\n\t\v',\"#")))
;; Check /recursive functions with pre char and initial readtable
(for-each
(lambda (base-readtable swap?)
(for-each
(lambda (read/recursive)
(let ([t (make-readtable #f
#\~ 'terminating-macro (lambda (ch port src line col pos)
(define read/rec
(if src
(lambda (port char readtable)
(read-syntax/recursive
src port
char readtable))
read/recursive))
(if (eq? (char=? #\! (peek-char port)) (not swap?))
(read/rec port #\( base-readtable)
(read/rec port #\{ base-readtable))))])
(parameterize ([current-readtable t])
(test-read "~!a (b))" `((!a (b))))
(test-read "~?a (b)}" `((?a (b)))))))
(list read/recursive (lambda (port char readtable)
(read-syntax/recursive 'ok port char readtable)))))
(list #f (make-readtable #f
#\! 'terminating-macro (lambda (ch port src line col pos) (error 'ack))
#\? 'terminating-macro (lambda (ch port src line col pos) (error 'ack))
#\( #\{ #f
#\{ #\( #f))
(list #f #t))
(for-each
(lambda (base-readtable swap?)
(for-each
(lambda (read/recursive)
(let ([t (make-readtable #f
#\~ 'terminating-macro (lambda (ch port src line col pos)
;; Use `read/recur` or `read-syntax/recur`:
(define read/rec
(if src
(lambda (port char readtable graph?)
(read-syntax/recursive
src port
char readtable graph?))
read/recursive))
(define (parse-vector ch port src line col pos)
;; We want to add a `(` to the front of `port`; that's
;; complicated if we also want to preserve source locations
(define p2 (input-port-append #f
(open-input-string "(")
port))
(define-values (line col pos) (port-next-location port))
(define p3 (if line
(begin
(port-count-lines! p2)
(relocate-input-port p2
line
(max 0 (sub1 col))
(max 1 (sub1 pos))))
p2))
(when line
(port-count-lines! p3))
(read/rec p3
#\#
(make-readtable #f #\> #\) #f)
#t))
;; Recursive read depends on next character and test mode
(define next-char (peek-char port))
(cond
[(or (char=? next-char #\h)
(char=? next-char #\<))
(read/rec port #\# (make-readtable base-readtable
#\< #\( #f
#\> #\) #f
#\< 'dispatch-macro parse-vector)
#t)]
[else
(if (eq? (eq? (char=? #\! next-char)
(not swap?))
(not swap?))
(read/rec port #\( base-readtable #t)
(read/rec port #\{ base-readtable #t))])))])
(parameterize ([current-readtable t])
(test-read "~!a (b))" `((!a (b))))
(test-read "~?a (b)}" `((?a (b))))
(test-read "~?a (b)}" `((?a (b))))
(test-read "~<a b c)" '(#(a b c)))
(test-read "~hash<<a . b > (c . d)>" '(#hash((a . b) (c . d))))
(test-read "~hash<<a . (<) > ((>) . d)>" '(#hash((a . (<)) ((>) . d))))
(test-read "~<a b c >" '(#(a b c))))))
(list read/recursive (lambda (port char readtable graph?)
(read-syntax/recursive 'ok port char readtable graph?)))))
(list #f (make-readtable #f
#\! 'terminating-macro (lambda (ch port src line col pos) (error 'ack))
#\? 'terminating-macro (lambda (ch port src line col pos) (error 'ack))
#\( #\{ #f
#\{ #\( #f
#\) #\} #f
#\} #\) #f))
(list #f #t))
(void)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

@ -193,13 +193,15 @@ static Scheme_Object *read_list(Scheme_Object *port, Scheme_Object *stxsrc,
int shape, int use_stack,
Scheme_Hash_Table **ht,
Scheme_Object *indentation,
ReadParams *params);
ReadParams *params,
Readtable *table);
static Scheme_Object *read_string(int is_byte,
Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos,
Scheme_Hash_Table **ht,
Scheme_Object *indentation,
ReadParams *params, int err_ok);
ReadParams *params, Readtable *table,
int err_ok);
static Scheme_Object *read_here_string(Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos,
Scheme_Object *indentation,
@ -216,21 +218,24 @@ static Scheme_Object *read_vector(Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t reqLen, const mzchar *reqBuffer,
Scheme_Hash_Table **ht,
Scheme_Object *indentation,
ReadParams *params, int allow_infix);
ReadParams *params, Readtable *table,
int allow_infix);
static Scheme_Object *read_flvector (Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos,
int opener, char closer,
intptr_t requestLength, const mzchar *reqBuffer,
Scheme_Hash_Table **ht,
Scheme_Object *indentation,
ReadParams *params, int allow_infix);
intptr_t line, intptr_t col, intptr_t pos,
int opener, char closer,
intptr_t requestLength, const mzchar *reqBuffer,
Scheme_Hash_Table **ht,
Scheme_Object *indentation,
ReadParams *params, Readtable *table,
int allow_infix);
static Scheme_Object *read_fxvector (Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos,
int opener, char closer,
intptr_t requestLength, const mzchar *reqBuffer,
Scheme_Hash_Table **ht,
Scheme_Object *indentation,
ReadParams *params, int allow_infix);
intptr_t line, intptr_t col, intptr_t pos,
int opener, char closer,
intptr_t requestLength, const mzchar *reqBuffer,
Scheme_Hash_Table **ht,
Scheme_Object *indentation,
ReadParams *params, Readtable *table,
int allow_infix);
static Scheme_Object *read_number(int init_ch,
Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos,
@ -274,7 +279,7 @@ static Scheme_Object *read_hash(Scheme_Object *port, Scheme_Object *stxsrc,
int opener, char closer, int kind,
Scheme_Hash_Table **ht,
Scheme_Object *indentation,
ReadParams *params);
ReadParams *params, Readtable *table);
static Scheme_Object *read_reader(Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos,
Scheme_Hash_Table **ht,
@ -309,7 +314,7 @@ static int next_is_delim(Scheme_Object *port,
static int skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
Scheme_Hash_Table **ht,
Scheme_Object *indentation,
ReadParams *params);
ReadParams *params, Readtable *table);
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,
@ -878,7 +883,8 @@ static Scheme_Object *read_inner_inner_k(void)
p->ku.k.p4 = NULL;
p->ku.k.p5 = NULL;
return read_inner_inner(o, stxsrc, ht, indentation, params, p->ku.k.i1, p->ku.k.i2, table, p->ku.k.i3);
return read_inner_inner(o, stxsrc, ht, indentation, params, p->ku.k.i1, p->ku.k.i2,
table, p->ku.k.i3);
}
#endif
@ -1102,24 +1108,24 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
unexpected_closer(ch, port, stxsrc, line, col, pos, indentation, params);
return NULL;
case '(':
return read_list(port, stxsrc, line, col, pos, ch, ')', mz_shape_cons, 0, ht, indentation, params);
return read_list(port, stxsrc, line, col, pos, ch, ')', mz_shape_cons, 0, ht, indentation, params, table);
case '[':
if (!params->square_brackets_are_parens) {
scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open square bracket");
return NULL;
} else
return read_list(port, stxsrc, line, col, pos, ch, ']', mz_shape_cons, 0, ht, indentation, params);
return read_list(port, stxsrc, line, col, pos, ch, ']', mz_shape_cons, 0, ht, indentation, params, table);
case '{':
if (!params->curly_braces_are_parens) {
scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open curly brace");
return NULL;
} else
return read_list(port, stxsrc, line, col, pos, ch, '}', mz_shape_cons, 0, ht, indentation, params);
return read_list(port, stxsrc, line, col, pos, ch, '}', mz_shape_cons, 0, ht, indentation, params, table);
case '|':
special_value = read_symbol(ch, 1, port, stxsrc, line, col, pos, ht, indentation, params, table);
break;
case '"':
return read_string(0, port, stxsrc, line, col, pos, ht, indentation, params, 1);
return read_string(0, port, stxsrc, line, col, pos, ht, indentation, params, table, 1);
case '\'':
return read_quote("quoting '", quote_symbol, 1, port, stxsrc, line, col, pos, ht, indentation, params);
case '`':
@ -1225,21 +1231,21 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
return read_keyword(-1, port, stxsrc, line, col, pos, ht, indentation, params, table);
break;
case '(':
return read_vector(port, stxsrc, line, col, pos, ch, ')', -1, NULL, ht, indentation, params, 0);
return read_vector(port, stxsrc, line, col, pos, ch, ')', -1, NULL, ht, indentation, params, table, 0);
break;
case '[':
if (!params->square_brackets_are_parens) {
scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#['");
return NULL;
} else
return read_vector(port, stxsrc, line, col, pos, ch, ']', -1, NULL, ht, indentation, params, 0);
return read_vector(port, stxsrc, line, col, pos, ch, ']', -1, NULL, ht, indentation, params, table, 0);
break;
case '{':
if (!params->curly_braces_are_parens) {
scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#{'");
return NULL;
} else
return read_vector(port, stxsrc, line, col, pos, ch, '}', -1, NULL, ht, indentation, params, 0);
return read_vector(port, stxsrc, line, col, pos, ch, '}', -1, NULL, ht, indentation, params, table, 0);
case '\\':
{
Scheme_Object *chr;
@ -1295,9 +1301,9 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
switch (effective_ch) {
case '(':
if (next == 'l')
return read_flvector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, 0);
return read_flvector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, table, 0);
else
return read_fxvector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, 0);
return read_fxvector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, table, 0);
break;
case '[':
if (!params->square_brackets_are_parens) {
@ -1305,9 +1311,9 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
return NULL;
} else
if (next == 'l')
return read_flvector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, 0);
return read_flvector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, table, 0);
else
return read_fxvector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, 0);
return read_fxvector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, table, 0);
break;
case '{':
if (!params->curly_braces_are_parens) {
@ -1315,9 +1321,9 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
return NULL;
} else
if (next == 'l')
return read_flvector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, 0);
return read_flvector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, table, 0);
else
return read_fxvector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, 0);
return read_fxvector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, table, 0);
break;
default:
scheme_read_err(port, stxsrc, line, col, pos, 3, effective_ch, indentation,
@ -1396,7 +1402,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
else if (effective_ch == '{')
ch = '}';
v = read_vector(port, stxsrc, line, col, pos, orig_ch, ch, -1, NULL, ht, indentation, params, 1);
v = read_vector(port, stxsrc, line, col, pos, orig_ch, ch, -1, NULL, ht, indentation, params, table, 1);
if (stxsrc)
v = SCHEME_STX_VAL(v);
@ -1500,7 +1506,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
scheme_tell_all(port, &sline, &scol, &spos);
str = read_string(1, port, stxsrc, sline, scol, spos, ht, indentation, params, 1);
str = read_string(1, port, stxsrc, sline, scol, spos, ht, indentation, params, table, 1);
str->type = SCHEME_PLATFORM_PATH_KIND;
@ -1643,7 +1649,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
/* Skip #rx[#]: */
scheme_tell_all(port, &sline, &scol, &spos);
str = read_string(is_byte, port, stxsrc, sline, scol, spos, ht, indentation, params, 1);
str = read_string(is_byte, port, stxsrc, sline, scol, spos, ht, indentation, params, table, 1);
if (stxsrc)
str = SCHEME_STX_VAL(str);
@ -1760,11 +1766,11 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
kind = 2;
if (effective_ch == '(')
return read_hash(port, stxsrc, line, col, pos, ch, ')', kind, ht, indentation, params);
return read_hash(port, stxsrc, line, col, pos, ch, ')', kind, ht, indentation, params, table);
if (effective_ch == '[' && params->square_brackets_are_parens)
return read_hash(port, stxsrc, line, col, pos, ch, ']', kind, ht, indentation, params);
return read_hash(port, stxsrc, line, col, pos, ch, ']', kind, ht, indentation, params, table);
if (effective_ch == '{' && params->curly_braces_are_parens)
return read_hash(port, stxsrc, line, col, pos, ch, '}', kind, ht, indentation, params);
return read_hash(port, stxsrc, line, col, pos, ch, '}', kind, ht, indentation, params, table);
}
/* Report an error. So far, we read 'ha', then scanpos chars of str, then ch. */
@ -1790,7 +1796,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
}
break;
case '"':
return read_string(1, port, stxsrc, line, col, pos, ht, indentation, params, 1);
return read_string(1, port, stxsrc, line, col, pos, ht, indentation, params, table, 1);
break;
case '<':
if (scheme_peekc_special_ok(port) == '<') {
@ -1861,11 +1867,11 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
effective_ch = read_vector_length(port, table, &ch, tagbuf, vecbuf, &vector_length, &digits, &overflow);
if (effective_ch == '(')
return read_vector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, 0);
return read_vector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, table, 0);
if (effective_ch == '[' && params->square_brackets_are_parens)
return read_vector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, 0);
return read_vector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, table, 0);
if (effective_ch == '{' && params->curly_braces_are_parens)
return read_vector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, 0);
return read_vector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, table, 0);
if (ch == '#' && (vector_length != -1)) {
/* Not a vector after all: a graph reference */
@ -2301,7 +2307,8 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
static Scheme_Object *
_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cant_fail,
int recur, int expose_comment, int extra_char, Scheme_Object *init_readtable,
int recur, int expose_comment, int extra_char,
Scheme_Object *init_readtable,
Scheme_Object *magic_sym, Scheme_Object *magic_val,
Scheme_Object *delay_load_info, int get_info)
{
@ -2472,14 +2479,15 @@ static void *scheme_internal_read_k(void)
Scheme_Object *
scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail,
int recur, int expose_comment, int pre_char, Scheme_Object *init_readtable,
int recur, int expose_comment, int pre_char,
Scheme_Object *init_readtable,
Scheme_Object *magic_sym, Scheme_Object *magic_val,
Scheme_Object *delay_load_info)
{
Scheme_Thread *p = scheme_current_thread;
if (cantfail) {
return _internal_read(port, stxsrc, crc, cantfail, recur, expose_comment, -1, NULL,
return _internal_read(port, stxsrc, crc, cantfail, recur, expose_comment, -1, NULL,
magic_sym, magic_val, delay_load_info, 0);
} else {
if (magic_sym)
@ -2500,12 +2508,12 @@ scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int ca
Scheme_Object *scheme_read(Scheme_Object *port)
{
return scheme_internal_read(port, NULL, -1, 0, 0, 0, -1, NULL, NULL, NULL, 0);
return scheme_internal_read(port, NULL, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
}
Scheme_Object *scheme_read_syntax(Scheme_Object *port, Scheme_Object *stxsrc)
{
return scheme_internal_read(port, stxsrc, -1, 0, 0, 0, -1, NULL, NULL, NULL, 0);
return scheme_internal_read(port, stxsrc, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
}
Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj)
@ -2667,7 +2675,7 @@ read_list(Scheme_Object *port,
int opener, int closer, int shape, int use_stack,
Scheme_Hash_Table **ht,
Scheme_Object *indentation,
ReadParams *params)
ReadParams *params, Readtable *table)
{
Scheme_Object *list = NULL, *last = NULL, *car, *cdr, *pair, *infixed = NULL, *prefetched = NULL;
int ch = 0, got_ch_already = 0, effective_ch;
@ -2701,7 +2709,7 @@ read_list(Scheme_Object *port,
else if (got_ch_already)
got_ch_already = 0;
else
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params);
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table);
if ((ch == EOF) && (closer != EOF)) {
char *suggestion = "";
@ -2726,7 +2734,7 @@ read_list(Scheme_Object *port,
return NULL;
}
effective_ch = readtable_effective_char(params->table, ch);
effective_ch = readtable_effective_char(table, ch);
if (effective_ch == closer) {
if (shape == mz_shape_hash_elem) {
@ -2752,7 +2760,7 @@ read_list(Scheme_Object *port,
&& !(effective_ch == '{' && params->curly_braces_are_parens)) {
intptr_t xl, xc, xp;
const char *sbname, *cbname;
/* If it's a special or we have a readtable, we need to read ahead
to make sure that it's not a comment. For consistency, always
read ahead. */
@ -2781,7 +2789,7 @@ read_list(Scheme_Object *port,
scheme_tell_all(port, &xl, &xc, &xp);
car = read_list(port, stxsrc, xl, xc, xp,
ch, ((effective_ch == '(') ? ')' : ((effective_ch == '[') ? ']' : '}')),
mz_shape_hash_elem, use_stack, ht, indentation, params);
mz_shape_hash_elem, use_stack, ht, indentation, params, table);
/* car is guaranteed to have an appropriate shape */
}
} else {
@ -2809,8 +2817,8 @@ read_list(Scheme_Object *port,
retry_before_dot:
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params);
effective_ch = readtable_effective_char(params->table, ch);
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table);
effective_ch = readtable_effective_char(table, ch);
if (effective_ch == closer) {
if (shape == mz_shape_hash_elem) {
scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation,
@ -2855,10 +2863,11 @@ read_list(Scheme_Object *port,
dot_ch);
return NULL;
}
/* can't be eof, due to check above: */
cdr = read_inner(port, stxsrc, ht, indentation, params, 0);
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params);
effective_ch = readtable_effective_char(params->table, ch);
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table);
effective_ch = readtable_effective_char(table, ch);
if ((effective_ch != closer) || (shape == mz_shape_vec_plus_infix)) {
if (params->can_read_infix_dot
&& (effective_ch == '.')
@ -2886,8 +2895,8 @@ read_list(Scheme_Object *port,
last = pair;
/* Make sure there's not a closing paren immediately after the dot: */
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params);
effective_ch = readtable_effective_char(params->table, ch);
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table);
effective_ch = readtable_effective_char(table, ch);
if ((effective_ch == closer) || (ch == EOF)) {
scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation,
"read: illegal use of `%c'", ch);
@ -2919,7 +2928,7 @@ read_list(Scheme_Object *port,
}
} else {
if ((ch == SCHEME_SPECIAL)
|| (params->table && (ch != EOF) && (shape != mz_shape_hash_list))) {
|| (table && (ch != EOF) && (shape != mz_shape_hash_list))) {
/* We have to try the read, because it might be a comment. */
scheme_ungetc(ch, port);
prefetched = read_inner(port, stxsrc, ht, indentation, params,
@ -3065,11 +3074,11 @@ static Scheme_Object *
read_string(int is_byte, Scheme_Object *port,
Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos,
Scheme_Hash_Table **ht,
Scheme_Object *indentation, ReadParams *params,
Scheme_Object *indentation, ReadParams *params, Readtable *table,
int err_ok)
{
mzchar *buf, *oldbuf, onstack[32];
int i, j, n, n1, ch, closer = '"';
int i, j, n, n1, ch, effective_ch, closer = '"';
intptr_t size = 31, oldsize, in_pos, init_span;
Scheme_Object *result;
@ -3078,7 +3087,12 @@ read_string(int is_byte, Scheme_Object *port,
i = 0;
buf = onstack;
while ((ch = scheme_getc_special_ok(port)) != closer) {
while (1) {
ch = scheme_getc_special_ok(port);
effective_ch = readtable_effective_char(table, ch);
if (effective_ch == closer)
break;
if (ch == EOF) {
if (err_ok)
scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), ch, indentation,
@ -3338,7 +3352,7 @@ Scheme_Object *scheme_read_byte_string(Scheme_Object *port)
return read_string(1, port,
NULL, 0, 0, 0,
NULL,
NULL, NULL,
NULL, NULL, NULL,
0);
}
@ -3534,7 +3548,7 @@ read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port,
if (!skip_rt && table) {
/* If the readtable provides a "symbol" reader, then use it: */
if (table->symbol_parser) {
return readtable_call(1, init_ch, table->symbol_parser, params,
return readtable_call(1, init_ch, table->symbol_parser, params,
port, stxsrc, line, col, pos, 0, ht, NULL);
/* Special-comment result is handled in main loop. */
}
@ -4059,12 +4073,13 @@ static Scheme_Object *read_hash(Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos,
int opener, char closer, int kind,
Scheme_Hash_Table **ht,
Scheme_Object *indentation, ReadParams *params)
Scheme_Object *indentation,
ReadParams *params, Readtable *table)
{
Scheme_Object *l;
/* using mz_shape_hash_list ensures that l is a list of pairs */
l = read_list(port, stxsrc, line, col, pos, opener, closer, mz_shape_hash_list, 0, ht, indentation, params);
l = read_list(port, stxsrc, line, col, pos, opener, closer, mz_shape_hash_list, 0, ht, indentation, params, table);
if (stxsrc) {
Scheme_Object *key, *val;
@ -4142,7 +4157,8 @@ Scheme_Object *scheme_read_intern(Scheme_Object *o)
static int
skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
Scheme_Hash_Table **ht, Scheme_Object *indentation, ReadParams *params)
Scheme_Hash_Table **ht, Scheme_Object *indentation,
ReadParams *params, Readtable *table)
{
int ch;
int blockc_1, blockc_2;
@ -4152,9 +4168,9 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
start_over:
if (params->table) {
if (table) {
while ((ch = scheme_getc_special_ok(port), NOT_EOF_OR_SPECIAL(ch))) {
if (!(readtable_kind(params->table, ch, params) & READTABLE_WHITESPACE))
if (!(readtable_kind(table, ch, params) & READTABLE_WHITESPACE))
break;
}
return ch;
@ -5990,7 +6006,7 @@ static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, Re
Scheme_Hash_Table **ht, Scheme_Object *modpath_stx)
{
int cnt, add_srcloc = 0;
Scheme_Object *a[6], *v;
Scheme_Object *a[7], *v;
Scheme_Cont_Frame_Data cframe;
if (w_char) {
@ -6160,6 +6176,16 @@ static Scheme_Object *readtable_handle_hash(Readtable *t, int ch, int *_use_defa
return v;
}
static void check_proc_either_arity(const char *who, int a1, int a2, int which, int argc, Scheme_Object **argv)
{
if (!scheme_check_proc_arity(NULL, a1, which, argc, argv)
&& !scheme_check_proc_arity(NULL, a2, which, argc, argv)) {
char buffer[60];
sprintf(buffer, "(or (procedure-arity-includes/c %d) (procedure-arity-includes/c %d))", a1, a2);
scheme_wrong_contract(who, buffer, which, argc, argv);
}
}
static Scheme_Object *make_readtable(int argc, Scheme_Object **argv)
{
Scheme_Object *sym, *val;
@ -6237,11 +6263,11 @@ static Scheme_Object *make_readtable(int argc, Scheme_Object **argv)
}
if (SCHEME_FALSEP(argv[i])) {
scheme_check_proc_arity("make-readtable", 6, i+2, argc, argv);
check_proc_either_arity("make-readtable", 6, 7, i+2, argc, argv);
t->symbol_parser = argv[i + 2];
} else if (SAME_OBJ(sym, dispatch_macro_symbol)) {
ch = SCHEME_CHAR_VAL(argv[i]);
scheme_check_proc_arity("make-readtable", 6, i+2, argc, argv);
check_proc_either_arity("make-readtable", 6, 7, i+2, argc, argv);
scheme_hash_set(t->mapping, scheme_make_integer(-ch), argv[i+2]);
} else {
if (SCHEME_CHARP(sym)) {
@ -6266,7 +6292,7 @@ static Scheme_Object *make_readtable(int argc, Scheme_Object **argv)
val = scheme_make_pair(scheme_make_integer(READTABLE_MAPPED), scheme_make_integer(sch));
} else {
int kind;
scheme_check_proc_arity("make-readtable", 6, i+2, argc, argv);
check_proc_either_arity("make-readtable", 6, 7, i+2, argc, argv);
kind = (SAME_OBJ(sym, non_terminating_macro_symbol)
? READTABLE_CONTINUING
: READTABLE_TERMINATING);

6
racket/src/racket/src/read_vector.inc
View File

@ -7,7 +7,9 @@ FUNC_NAME (Scheme_Object *port,
int opener, char closer,
intptr_t requestLength, const mzchar *reqBuffer,
Scheme_Hash_Table **ht,
Scheme_Object *indentation, ReadParams *params, int allow_infix)
Scheme_Object *indentation,
ReadParams *params, Readtable *table,
int allow_infix)
/* requestLength == -1 => no request
requestLength == -2 => overflow */
{
@ -22,7 +24,7 @@ FUNC_NAME (Scheme_Object *port,
lresult = read_list(port, stxsrc, line, col, pos, opener, closer,
MZ_SHAPE,
1, ht, indentation, params);
1, ht, indentation, params, table);
if (requestLength == -2) {
scheme_raise_out_of_memory("read", "making %s of size %5", vtype_str, reqBuffer);