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].) prefix multiple characters, use @racket[input-port-append].)
The @racket[readtable] argument is used for top-level parsing to 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 read the elements of a list) instead uses the current readtable as
determined by the @racket[current-readtable] parameter. A reader determined by the @racket[current-readtable] parameter. A reader
macro might call @racket[read/recursive] with a character and 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. value before the outermost @racket[read] returns.
See @secref["readtables"] for an extended example that uses 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)] @defproc[(read-syntax/recursive [source-name any/c (object-name in)]
[in input-port? (current-input-port)] [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). when the input stream starts with a comment (after whitespace).
See @secref["readtables"] for an extended example that uses 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)] @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) (Section 'readtable)
(require (only-in racket/port (require (only-in racket/port
[relocate-input-port relocate-input-port])) relocate-input-port
input-port-append))
(define (shift-rt-port p deltas) (define (shift-rt-port p deltas)
(let ([p (relocate-input-port p (let ([p (relocate-input-port p
(add1 (car deltas)) (add1 (car deltas))
@ -165,34 +166,77 @@
(for-each try-as-plain (string->list "()[]{}|\\ \r\n\t\v',\"#"))) (for-each try-as-plain (string->list "()[]{}|\\ \r\n\t\v',\"#")))
;; Check /recursive functions with pre char and initial readtable ;; Check /recursive functions with pre char and initial readtable
(for-each (for-each
(lambda (base-readtable swap?) (lambda (base-readtable swap?)
(for-each (for-each
(lambda (read/recursive) (lambda (read/recursive)
(let ([t (make-readtable #f (let ([t (make-readtable #f
#\~ 'terminating-macro (lambda (ch port src line col pos) #\~ 'terminating-macro (lambda (ch port src line col pos)
(define read/rec ;; Use `read/recur` or `read-syntax/recur`:
(if src (define read/rec
(lambda (port char readtable) (if src
(read-syntax/recursive (lambda (port char readtable graph?)
src port (read-syntax/recursive
char readtable)) src port
read/recursive)) char readtable graph?))
(if (eq? (char=? #\! (peek-char port)) (not swap?)) read/recursive))
(read/rec port #\( base-readtable) (define (parse-vector ch port src line col pos)
(read/rec port #\{ base-readtable))))]) ;; We want to add a `(` to the front of `port`; that's
(parameterize ([current-readtable t]) ;; complicated if we also want to preserve source locations
(test-read "~!a (b))" `((!a (b)))) (define p2 (input-port-append #f
(test-read "~?a (b)}" `((?a (b))))))) (open-input-string "(")
(list read/recursive (lambda (port char readtable) port))
(read-syntax/recursive 'ok port char readtable))))) (define-values (line col pos) (port-next-location port))
(list #f (make-readtable #f (define p3 (if line
#\! 'terminating-macro (lambda (ch port src line col pos) (error 'ack)) (begin
#\? 'terminating-macro (lambda (ch port src line col pos) (error 'ack)) (port-count-lines! p2)
#\( #\{ #f (relocate-input-port p2
#\{ #\( #f)) line
(list #f #t)) (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))))) (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, int shape, int use_stack,
Scheme_Hash_Table **ht, Scheme_Hash_Table **ht,
Scheme_Object *indentation, Scheme_Object *indentation,
ReadParams *params); ReadParams *params,
Readtable *table);
static Scheme_Object *read_string(int is_byte, static Scheme_Object *read_string(int is_byte,
Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos, intptr_t line, intptr_t col, intptr_t pos,
Scheme_Hash_Table **ht, Scheme_Hash_Table **ht,
Scheme_Object *indentation, 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, static Scheme_Object *read_here_string(Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos, intptr_t line, intptr_t col, intptr_t pos,
Scheme_Object *indentation, Scheme_Object *indentation,
@ -216,21 +218,24 @@ static Scheme_Object *read_vector(Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t reqLen, const mzchar *reqBuffer, intptr_t reqLen, const mzchar *reqBuffer,
Scheme_Hash_Table **ht, Scheme_Hash_Table **ht,
Scheme_Object *indentation, 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, static Scheme_Object *read_flvector (Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos, intptr_t line, intptr_t col, intptr_t pos,
int opener, char closer, int opener, char closer,
intptr_t requestLength, const mzchar *reqBuffer, intptr_t requestLength, const mzchar *reqBuffer,
Scheme_Hash_Table **ht, Scheme_Hash_Table **ht,
Scheme_Object *indentation, Scheme_Object *indentation,
ReadParams *params, int allow_infix); ReadParams *params, Readtable *table,
int allow_infix);
static Scheme_Object *read_fxvector (Scheme_Object *port, Scheme_Object *stxsrc, static Scheme_Object *read_fxvector (Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos, intptr_t line, intptr_t col, intptr_t pos,
int opener, char closer, int opener, char closer,
intptr_t requestLength, const mzchar *reqBuffer, intptr_t requestLength, const mzchar *reqBuffer,
Scheme_Hash_Table **ht, Scheme_Hash_Table **ht,
Scheme_Object *indentation, Scheme_Object *indentation,
ReadParams *params, int allow_infix); ReadParams *params, Readtable *table,
int allow_infix);
static Scheme_Object *read_number(int init_ch, static Scheme_Object *read_number(int init_ch,
Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos, 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, int opener, char closer, int kind,
Scheme_Hash_Table **ht, Scheme_Hash_Table **ht,
Scheme_Object *indentation, Scheme_Object *indentation,
ReadParams *params); ReadParams *params, Readtable *table);
static Scheme_Object *read_reader(Scheme_Object *port, Scheme_Object *stxsrc, static Scheme_Object *read_reader(Scheme_Object *port, Scheme_Object *stxsrc,
intptr_t line, intptr_t col, intptr_t pos, intptr_t line, intptr_t col, intptr_t pos,
Scheme_Hash_Table **ht, 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, 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); ReadParams *params, Readtable *table);
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,
@ -878,7 +883,8 @@ static Scheme_Object *read_inner_inner_k(void)
p->ku.k.p4 = NULL; p->ku.k.p4 = NULL;
p->ku.k.p5 = 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 #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); unexpected_closer(ch, port, stxsrc, line, col, pos, indentation, params);
return NULL; return NULL;
case '(': 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 '[': case '[':
if (!params->square_brackets_are_parens) { if (!params->square_brackets_are_parens) {
scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open square bracket"); scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open square bracket");
return NULL; return NULL;
} else } 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 '{': case '{':
if (!params->curly_braces_are_parens) { if (!params->curly_braces_are_parens) {
scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open curly brace"); scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of open curly brace");
return NULL; return NULL;
} else } 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 '|': case '|':
special_value = read_symbol(ch, 1, port, stxsrc, line, col, pos, ht, indentation, params, table); special_value = read_symbol(ch, 1, port, stxsrc, line, col, pos, ht, indentation, params, table);
break; break;
case '"': 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 '\'': case '\'':
return read_quote("quoting '", quote_symbol, 1, port, stxsrc, line, col, pos, ht, indentation, params); return read_quote("quoting '", quote_symbol, 1, port, stxsrc, line, col, pos, ht, indentation, params);
case '`': 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); return read_keyword(-1, port, stxsrc, line, col, pos, ht, indentation, params, table);
break; break;
case '(': 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; break;
case '[': case '[':
if (!params->square_brackets_are_parens) { if (!params->square_brackets_are_parens) {
scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#['"); scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#['");
return NULL; return NULL;
} else } 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; break;
case '{': case '{':
if (!params->curly_braces_are_parens) { if (!params->curly_braces_are_parens) {
scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#{'"); scheme_read_err(port, stxsrc, line, col, pos, 2, 0, indentation, "read: bad syntax `#{'");
return NULL; return NULL;
} else } 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 '\\': case '\\':
{ {
Scheme_Object *chr; Scheme_Object *chr;
@ -1295,9 +1301,9 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
switch (effective_ch) { switch (effective_ch) {
case '(': case '(':
if (next == 'l') 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 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; break;
case '[': case '[':
if (!params->square_brackets_are_parens) { if (!params->square_brackets_are_parens) {
@ -1305,9 +1311,9 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
return NULL; return NULL;
} else } else
if (next == 'l') 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 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; break;
case '{': case '{':
if (!params->curly_braces_are_parens) { if (!params->curly_braces_are_parens) {
@ -1315,9 +1321,9 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
return NULL; return NULL;
} else } else
if (next == 'l') 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 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; break;
default: default:
scheme_read_err(port, stxsrc, line, col, pos, 3, effective_ch, indentation, 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 == '{') else if (effective_ch == '{')
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) if (stxsrc)
v = SCHEME_STX_VAL(v); 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); 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; str->type = SCHEME_PLATFORM_PATH_KIND;
@ -1643,7 +1649,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
/* Skip #rx[#]: */ /* Skip #rx[#]: */
scheme_tell_all(port, &sline, &scol, &spos); 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) if (stxsrc)
str = SCHEME_STX_VAL(str); str = SCHEME_STX_VAL(str);
@ -1760,11 +1766,11 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
kind = 2; kind = 2;
if (effective_ch == '(') 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) 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) 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. */ /* 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; break;
case '"': 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; break;
case '<': case '<':
if (scheme_peekc_special_ok(port) == '<') { 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); effective_ch = read_vector_length(port, table, &ch, tagbuf, vecbuf, &vector_length, &digits, &overflow);
if (effective_ch == '(') 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) 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) 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)) { if (ch == '#' && (vector_length != -1)) {
/* Not a vector after all: a graph reference */ /* Not a vector after all: a graph reference */
@ -2301,7 +2307,8 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
static Scheme_Object * static Scheme_Object *
_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cant_fail, _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 *magic_sym, Scheme_Object *magic_val,
Scheme_Object *delay_load_info, int get_info) Scheme_Object *delay_load_info, int get_info)
{ {
@ -2472,14 +2479,15 @@ static void *scheme_internal_read_k(void)
Scheme_Object * Scheme_Object *
scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail, 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 *magic_sym, Scheme_Object *magic_val,
Scheme_Object *delay_load_info) Scheme_Object *delay_load_info)
{ {
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
if (cantfail) { 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); magic_sym, magic_val, delay_load_info, 0);
} else { } else {
if (magic_sym) 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) 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) 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) 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, int opener, int closer, int shape, int use_stack,
Scheme_Hash_Table **ht, Scheme_Hash_Table **ht,
Scheme_Object *indentation, Scheme_Object *indentation,
ReadParams *params) ReadParams *params, Readtable *table)
{ {
Scheme_Object *list = NULL, *last = NULL, *car, *cdr, *pair, *infixed = NULL, *prefetched = NULL; Scheme_Object *list = NULL, *last = NULL, *car, *cdr, *pair, *infixed = NULL, *prefetched = NULL;
int ch = 0, got_ch_already = 0, effective_ch; int ch = 0, got_ch_already = 0, effective_ch;
@ -2701,7 +2709,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); ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table);
if ((ch == EOF) && (closer != EOF)) { if ((ch == EOF) && (closer != EOF)) {
char *suggestion = ""; char *suggestion = "";
@ -2726,7 +2734,7 @@ read_list(Scheme_Object *port,
return NULL; return NULL;
} }
effective_ch = readtable_effective_char(params->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) {
@ -2752,7 +2760,7 @@ read_list(Scheme_Object *port,
&& !(effective_ch == '{' && params->curly_braces_are_parens)) { && !(effective_ch == '{' && params->curly_braces_are_parens)) {
intptr_t xl, xc, xp; intptr_t xl, xc, xp;
const char *sbname, *cbname; const char *sbname, *cbname;
/* If it's a special or we have a readtable, we need to read ahead /* 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 to make sure that it's not a comment. For consistency, always
read ahead. */ read ahead. */
@ -2781,7 +2789,7 @@ read_list(Scheme_Object *port,
scheme_tell_all(port, &xl, &xc, &xp); scheme_tell_all(port, &xl, &xc, &xp);
car = read_list(port, stxsrc, xl, xc, xp, car = read_list(port, stxsrc, xl, xc, xp,
ch, ((effective_ch == '(') ? ')' : ((effective_ch == '[') ? ']' : '}')), 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 */ /* car is guaranteed to have an appropriate shape */
} }
} else { } else {
@ -2809,8 +2817,8 @@ read_list(Scheme_Object *port,
retry_before_dot: retry_before_dot:
ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params); ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table);
effective_ch = readtable_effective_char(params->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) {
scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation,
@ -2855,10 +2863,11 @@ read_list(Scheme_Object *port,
dot_ch); dot_ch);
return NULL; return NULL;
} }
/* 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); ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table);
effective_ch = readtable_effective_char(params->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
&& (effective_ch == '.') && (effective_ch == '.')
@ -2886,8 +2895,8 @@ 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); ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table);
effective_ch = readtable_effective_char(params->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);
@ -2919,7 +2928,7 @@ read_list(Scheme_Object *port,
} }
} else { } else {
if ((ch == SCHEME_SPECIAL) 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. */ /* 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,
@ -3065,11 +3074,11 @@ static Scheme_Object *
read_string(int is_byte, Scheme_Object *port, read_string(int is_byte, Scheme_Object *port,
Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos,
Scheme_Hash_Table **ht, Scheme_Hash_Table **ht,
Scheme_Object *indentation, ReadParams *params, Scheme_Object *indentation, ReadParams *params, Readtable *table,
int err_ok) int err_ok)
{ {
mzchar *buf, *oldbuf, onstack[32]; 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; intptr_t size = 31, oldsize, in_pos, init_span;
Scheme_Object *result; Scheme_Object *result;
@ -3078,7 +3087,12 @@ read_string(int is_byte, Scheme_Object *port,
i = 0; i = 0;
buf = onstack; 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 (ch == EOF) {
if (err_ok) if (err_ok)
scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), ch, indentation, 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, return read_string(1, port,
NULL, 0, 0, 0, NULL, 0, 0, 0,
NULL, NULL,
NULL, NULL, NULL, NULL, NULL,
0); 0);
} }
@ -3534,7 +3548,7 @@ read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port,
if (!skip_rt && table) { if (!skip_rt && table) {
/* If the readtable provides a "symbol" reader, then use it: */ /* If the readtable provides a "symbol" reader, then use it: */
if (table->symbol_parser) { 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); port, stxsrc, line, col, pos, 0, ht, NULL);
/* Special-comment result is handled in main loop. */ /* 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, intptr_t line, intptr_t col, intptr_t pos,
int opener, char closer, int kind, int opener, char closer, int kind,
Scheme_Hash_Table **ht, Scheme_Hash_Table **ht,
Scheme_Object *indentation, ReadParams *params) Scheme_Object *indentation,
ReadParams *params, Readtable *table)
{ {
Scheme_Object *l; Scheme_Object *l;
/* using mz_shape_hash_list ensures that l is a list of pairs */ /* 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) { if (stxsrc) {
Scheme_Object *key, *val; Scheme_Object *key, *val;
@ -4142,7 +4157,8 @@ 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, ReadParams *params) Scheme_Hash_Table **ht, Scheme_Object *indentation,
ReadParams *params, Readtable *table)
{ {
int ch; int ch;
int blockc_1, blockc_2; int blockc_1, blockc_2;
@ -4152,9 +4168,9 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
start_over: start_over:
if (params->table) { if (table) {
while ((ch = scheme_getc_special_ok(port), NOT_EOF_OR_SPECIAL(ch))) { 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; break;
} }
return ch; 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) Scheme_Hash_Table **ht, Scheme_Object *modpath_stx)
{ {
int cnt, add_srcloc = 0; int cnt, add_srcloc = 0;
Scheme_Object *a[6], *v; Scheme_Object *a[7], *v;
Scheme_Cont_Frame_Data cframe; Scheme_Cont_Frame_Data cframe;
if (w_char) { if (w_char) {
@ -6160,6 +6176,16 @@ static Scheme_Object *readtable_handle_hash(Readtable *t, int ch, int *_use_defa
return v; 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) static Scheme_Object *make_readtable(int argc, Scheme_Object **argv)
{ {
Scheme_Object *sym, *val; Scheme_Object *sym, *val;
@ -6237,11 +6263,11 @@ static Scheme_Object *make_readtable(int argc, Scheme_Object **argv)
} }
if (SCHEME_FALSEP(argv[i])) { 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]; t->symbol_parser = argv[i + 2];
} else if (SAME_OBJ(sym, dispatch_macro_symbol)) { } else if (SAME_OBJ(sym, dispatch_macro_symbol)) {
ch = SCHEME_CHAR_VAL(argv[i]); 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]); scheme_hash_set(t->mapping, scheme_make_integer(-ch), argv[i+2]);
} else { } else {
if (SCHEME_CHARP(sym)) { 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)); val = scheme_make_pair(scheme_make_integer(READTABLE_MAPPED), scheme_make_integer(sch));
} else { } else {
int kind; 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) kind = (SAME_OBJ(sym, non_terminating_macro_symbol)
? READTABLE_CONTINUING ? READTABLE_CONTINUING
: READTABLE_TERMINATING); : 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, int opener, char closer,
intptr_t requestLength, const mzchar *reqBuffer, intptr_t requestLength, const mzchar *reqBuffer,
Scheme_Hash_Table **ht, 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 == -1 => no request
requestLength == -2 => overflow */ requestLength == -2 => overflow */
{ {
@ -22,7 +24,7 @@ FUNC_NAME (Scheme_Object *port,
lresult = read_list(port, stxsrc, line, col, pos, opener, closer, lresult = read_list(port, stxsrc, line, col, pos, opener, closer,
MZ_SHAPE, MZ_SHAPE,
1, ht, indentation, params); 1, ht, indentation, params, table);
if (requestLength == -2) { if (requestLength == -2) {
scheme_raise_out_of_memory("read", "making %s of size %5", vtype_str, reqBuffer); scheme_raise_out_of_memory("read", "making %s of size %5", vtype_str, reqBuffer);