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

expans #reader/#lang protocol so that a #lang result can have more appropriate srclocs; fix up syntax/module-reader to use the new protocol; re-enable arrows to the language position in Check Syntax

Browse Source 
svn: r9174
This commit is contained in:
Matthew Flatt 2008-04-06 23:31:58 +00:00
parent 1a5cb7ed64
commit 53cc426d30
8 changed files with 138 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/drscheme/syncheck.ss
View File

@ -1588,8 +1588,6 @@ If the namespace does not, they are colored the unbound color.
(annotate-raw-keyword sexp varrefs) (annotate-raw-keyword sexp varrefs)
((annotate-require-open user-namespace user-directory) (syntax lang)) ((annotate-require-open user-namespace user-directory) (syntax lang))
;; temporarily removed until Matthew fixes whatever.
#;
(hash-table-put! requires (hash-table-put! requires
(syntax->datum (syntax lang)) (syntax->datum (syntax lang))
(cons (syntax lang) (cons (syntax lang)

11
collects/r6rs/lang/reader.ss
View File

@ -6,13 +6,14 @@
[*read-syntax read-syntax])) [*read-syntax read-syntax]))
(define (*read in) (define (*read in)
(wrap in read)) (wrap in read #f #f #f #f #f))
(define (*read-syntax src in) (define (*read-syntax src in modpath line col pos)
(wrap in (lambda (in) (wrap in (lambda (in)
(read-syntax src in)))) (read-syntax src in))
modpath src line col pos))
(define (wrap in read) (define (wrap in read modpath src line col pos)
(with-r6rs-reader-parameters (with-r6rs-reader-parameters
(lambda () (lambda ()
(wrap-read-all 'r6rs in read)))) (wrap-read-all 'r6rs in read modpath src line col pos))))

2
collects/scribble/manual.ss
View File

@ -175,7 +175,7 @@
(unless (andmap string? strs) (unless (andmap string? strs)
(raise-type-error 'litchar "strings" strs)) (raise-type-error 'litchar "strings" strs))
(let ([s (apply string-append (let ([s (apply string-append
(map (lambda (s) (if (string=? s "\n") " " s)) (map (lambda (s) (regexp-replace* "\n" s " "))
strs))]) strs))])
(if (regexp-match? #rx"^ *$" s) (if (regexp-match? #rx"^ *$" s)
(make-element "schemeinputbg" (list (hspace (string-length s)))) (make-element "schemeinputbg" (list (hspace (string-length s))))

2
collects/scribblings/reference/contracts.scrbl
View File

@ -549,7 +549,7 @@ earlier fields.}
As an example, consider the following module: As an example, consider the following module:
@(begin @(begin
#readerscribble/comment-reader #reader scribble/comment-reader
[schemeblock [schemeblock
(module product mzscheme (module product mzscheme
(require mzlib/contract) (require mzlib/contract)

34
collects/scribblings/reference/reader.scrbl
View File

@ -771,15 +771,25 @@ with either @scheme['read] or @scheme['read-syntax] (depending on
whether the reader is in @scheme[read] or @scheme[read-syntax] whether the reader is in @scheme[read] or @scheme[read-syntax]
mode). mode).
The resulting procedure should accept the same arguments as The arity of the resulting procedure determines whether it accepts
@scheme[read] or @scheme[read-syntax] in the case that all optional extra source-location information: a @schemeidfont{read} procedure
arguments are provided. The procedure is given the port whose stream accepts either one argument (an input port) or five, and a
contained @litchar{#reader}, and it should produce a datum result. If @schemeidfont{read-syntax} procedure accepts either two arguments (a
the result is a syntax object in @scheme[read] mode, then it is name value and an input port) or six. In either case, the four
converted to a datum using @scheme[syntax->datum]; if the optional arguments are the module path (as a syntax object in
result is not a syntax object in @scheme[read-syntax] mode, then it is @scheme[read-syntax] mode) followed by the line (positive exact
converted to one using @scheme[datum->syntax]. See also integer or @scheme[#f]), column (non-negative exact integer or
@secref["reader-procs"] for information on the procedure's results. @scheme[#f]), and position (positive exact integer or @scheme[#f]) of
the start of the @litchar{#reader} form. The input port is the one
whose stream contained @litchar{#reader}, where the stream position is
immediately after the recursively-read module path.
The procedure should produce a datum result. If the result is a
syntax object in @scheme[read] mode, then it is converted to a datum
using @scheme[syntax->datum]; if the result is not a syntax object in
@scheme[read-syntax] mode, then it is converted to one using
@scheme[datum->syntax]. See also @secref["reader-procs"] for
information on the procedure's results.
If the @scheme[read-accept-reader] @tech{parameter} is set to If the @scheme[read-accept-reader] @tech{parameter} is set to
@scheme[#f], then if the reader encounters @litchar{#reader}, the @scheme[#f], then if the reader encounters @litchar{#reader}, the
@ -794,8 +804,10 @@ of alphanumeric ASCII, @litchar{+}, @litchar{-}, @litchar{_}, and/or
@litchar{/} characters terminated by @litchar{/} characters terminated by
@schemelink[char-whitespace?]{whitespace} or an end-of-file. The @schemelink[char-whitespace?]{whitespace} or an end-of-file. The
sequence must not start or end with @litchar{/}. A sequence sequence must not start or end with @litchar{/}. A sequence
@litchar{#lang }@nonterm{name} is equivalent to @litchar{#reader @litchar{#lang }@nonterm{name} is equivalent to @litchar["#reader
}@nonterm{name}@litchar{/lang/reader}. "]@nonterm{name}@litchar{/lang/reader}, except that the terminating
whitespace (if any) is consumed before the external reading procedure
is called.
Finally, @as-index{@litchar{#!}} followed by alphanumeric ASCII, Finally, @as-index{@litchar{#!}} followed by alphanumeric ASCII,
@litchar{+}, @litchar{-}, or @litchar{_} is a synonym for @litchar{+}, @litchar{-}, or @litchar{_} is a synonym for

39
collects/syntax/module-reader.ss
View File

@ -10,13 +10,14 @@
(#%provide (rename *read read) (#%provide (rename *read read)
(rename *read-syntax read-syntax)) (rename *read-syntax read-syntax))
(define (*read in) (define (*read in modpath line col pos)
(wrap 'lib in read)) (wrap 'lib in read modpath #f line col pos))
(define (*read-syntax src in) (define (*read-syntax src in modpath line col pos)
(wrap 'lib in (lambda (in) (read-syntax src in)))))])) (wrap 'lib in (lambda (in) (read-syntax src in))
modpath src line col pos)))]))
(define (wrap lib port read) (define (wrap lib port read modpath src line col pos)
(let ([body (let ([body
(let loop ([a null]) (let loop ([a null])
(let ([v (read port)]) (let ([v (read port)])
@ -25,12 +26,28 @@
(loop (cons v a)))))]) (loop (cons v a)))))])
(let* ([p-name (object-name port)] (let* ([p-name (object-name port)]
[name (if (path? p-name) [name (if (path? p-name)
(let-values ([(base name dir?) (split-path p-name)]) (let-values ([(base name dir?) (split-path p-name)])
(string->symbol (string->symbol
(path->string (path-replace-suffix name #"")))) (path->string (path-replace-suffix name #""))))
'page)] 'page)]
[id 'doc]) [id 'doc]
`(module ,name ,lib [tag-src (lambda (v)
(if (syntax? modpath)
(datum->syntax #f
v
(vector src line col pos
(- (or (syntax-position modpath)
(add1 pos))
pos)))
v))]
[lib-src (lambda (v)
(if (syntax? modpath)
(datum->syntax #f
lib
modpath
modpath)
v))])
`(,(tag-src 'module) ,(tag-src name) ,(lib-src lib)
. ,body)))) . ,body))))
) )

5
src/mzscheme/src/module.c
View File

@ -4754,7 +4754,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Env *menv; Scheme_Env *menv;
Scheme_Comp_Env *benv; Scheme_Comp_Env *benv;
Scheme_Module *m; Scheme_Module *m;
Scheme_Object *mbval; Scheme_Object *mbval, *orig_ii;
int saw_mb, check_mb = 0; int saw_mb, check_mb = 0;
int restore_confusing_name = 0; int restore_confusing_name = 0;
@ -4810,6 +4810,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
m->ii_src = ii; m->ii_src = ii;
orig_ii = ii;
ii = scheme_syntax_to_datum(ii, 0, NULL); ii = scheme_syntax_to_datum(ii, 0, NULL);
if (!scheme_is_module_path(ii)) { if (!scheme_is_module_path(ii)) {
@ -4954,7 +4955,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
formname = SCHEME_STX_CAR(form); formname = SCHEME_STX_CAR(form);
fm = cons(formname, fm = cons(formname,
cons(nm, cons(nm,
cons(ii, cons(fm, scheme_null)))); cons(orig_ii, cons(fm, scheme_null))));
fm = scheme_datum_to_syntax(fm, form, form, 0, 2); fm = scheme_datum_to_syntax(fm, form, form, 0, 2);

104
src/mzscheme/src/read.c
View File

@ -102,6 +102,9 @@ static MZ_INLINE long SPAN(Scheme_Object *port, long pos) {
return cpos - pos + 1; return cpos - pos + 1;
} }
/* For cases where we'd rather report the location as just the relevant prefix: */
#define MINSPAN(port, pos, span) (span)
#define SRCLOC_TMPL " in %q[%L%ld]" #define SRCLOC_TMPL " in %q[%L%ld]"
#define mz_shape_cons 0 #define mz_shape_cons 0
@ -241,7 +244,7 @@ static int skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
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, long line, long col, long pos, Scheme_Object *port, Scheme_Object *src, long line, long col, long pos,
Scheme_Hash_Table **ht); Scheme_Hash_Table **ht, Scheme_Object *modpath_stx);
#define READTABLE_WHITESPACE 0x1 #define READTABLE_WHITESPACE 0x1
#define READTABLE_CONTINUING 0x2 #define READTABLE_CONTINUING 0x2
@ -1097,7 +1100,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
Scheme_Object *skipped; Scheme_Object *skipped;
skipped = read_inner(port, stxsrc, ht, indentation, params, 0); skipped = read_inner(port, stxsrc, ht, indentation, params, 0);
if (SCHEME_EOFP(skipped)) if (SCHEME_EOFP(skipped))
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), EOF, indentation, scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation,
"read: expected a commented-out element for `#;' (found end-of-file)"); "read: expected a commented-out element for `#;' (found end-of-file)");
/* For resolving graphs introduced in #; : */ /* For resolving graphs introduced in #; : */
if (*ht) { if (*ht) {
@ -1376,7 +1379,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
ch = scheme_getc_special_ok(port); ch = scheme_getc_special_ok(port);
if (ch == EOF) if (ch == EOF)
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 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 (ch == SCHEME_SPECIAL)
scheme_get_ready_read_special(port, stxsrc, ht); scheme_get_ready_read_special(port, stxsrc, ht);
@ -1809,6 +1812,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
if (ch == '=' && (vector_length != -1)) { if (ch == '=' && (vector_length != -1)) {
/* Not a vector after all: a graph definition */ /* Not a vector after all: a graph definition */
Scheme_Object *v, *ph; Scheme_Object *v, *ph;
long in_pos;
if (stxsrc) if (stxsrc)
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,
@ -1840,9 +1844,11 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
scheme_hash_set(*ht, scheme_make_integer(vector_length), (void *)ph); scheme_hash_set(*ht, scheme_make_integer(vector_length), (void *)ph);
scheme_tell_all(port, NULL, NULL, &in_pos);
v = read_inner(port, stxsrc, ht, indentation, params, 0); v = read_inner(port, stxsrc, ht, indentation, params, 0);
if (SCHEME_EOFP(v)) if (SCHEME_EOFP(v))
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), EOF, indentation, scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, in_pos-pos), EOF, indentation,
"read: expected an element for graph (found end-of-file)"); "read: expected an element for graph (found end-of-file)");
SCHEME_PTR_VAL(ph) = v; SCHEME_PTR_VAL(ph) = v;
@ -2574,9 +2580,10 @@ read_list(Scheme_Object *port,
int ch = 0, got_ch_already = 0, effective_ch; int ch = 0, got_ch_already = 0, effective_ch;
int brackets = params->square_brackets_are_parens; int brackets = params->square_brackets_are_parens;
int braces = params->curly_braces_are_parens; int braces = params->curly_braces_are_parens;
long start, startcol, startline, dotpos, dotcol, dotline, dot2pos, dot2line, dot2col; long start, startcol, startline, dotpos, dotcol, dotline, dot2pos, dot2line, dot2col, init_span;
scheme_tell_all(port, &startline, &startcol, &start); scheme_tell_all(port, &startline, &startcol, &start);
init_span = 1;
if (stxsrc) { if (stxsrc) {
/* Push onto the indentation stack: */ /* Push onto the indentation stack: */
@ -2618,7 +2625,7 @@ read_list(Scheme_Object *port,
} }
} }
scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), EOF, indentation, scheme_read_err(port, stxsrc, startline, startcol, start, MINSPAN(port, start, init_span), EOF, indentation,
"read: expected a %s%s", closer_name(params, closer), suggestion); "read: expected a %s%s", closer_name(params, closer), suggestion);
return NULL; return NULL;
} }
@ -2971,15 +2978,18 @@ read_string(int is_byte, int is_honu_char, Scheme_Object *port,
{ {
mzchar *buf, *oldbuf, onstack[32]; mzchar *buf, *oldbuf, onstack[32];
int i, j, n, n1, ch, closer = (is_honu_char ? '\'' : '"'); int i, j, n, n1, ch, closer = (is_honu_char ? '\'' : '"');
long size = 31, oldsize; long size = 31, oldsize, in_pos, init_span;
Scheme_Object *result; Scheme_Object *result;
scheme_tell_all(port, NULL, NULL, &in_pos);
init_span = in_pos - pos + 1;
i = 0; i = 0;
buf = onstack; buf = onstack;
while ((ch = scheme_getc_special_ok(port)) != closer) { while ((ch = scheme_getc_special_ok(port)) != closer) {
if ((ch == EOF) || (is_honu_char && (i > 0))) { if ((ch == EOF) || (is_honu_char && (i > 0))) {
if (err_ok) if (err_ok)
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation, scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), ch, indentation,
"read: expected a closing %s%s", "read: expected a closing %s%s",
is_honu_char ? "'" : "'\"'", is_honu_char ? "'" : "'\"'",
(ch == EOF) ? "" : " after one character"); (ch == EOF) ? "" : " after one character");
@ -2998,7 +3008,7 @@ read_string(int is_byte, int is_honu_char, Scheme_Object *port,
ch = scheme_getc_special_ok(port); ch = scheme_getc_special_ok(port);
if (ch == EOF) { if (ch == EOF) {
if (err_ok) if (err_ok)
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), EOF, indentation, scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), EOF, indentation,
"read: expected a closing %s", "read: expected a closing %s",
is_honu_char ? "'" : "'\"'"); is_honu_char ? "'" : "'\"'");
return NULL; return NULL;
@ -3196,8 +3206,12 @@ read_here_string(Scheme_Object *port, Scheme_Object *stxsrc,
{ {
int tlen = 0, len = 0, size = 12; int tlen = 0, len = 0, size = 12;
mzchar *tag, *naya, *s, buf[12], c; mzchar *tag, *naya, *s, buf[12], c;
long in_pos, init_span;
Scheme_Object *str; Scheme_Object *str;
scheme_tell_all(port, NULL, NULL, &in_pos);
init_span = in_pos - pos + 1;
tag = buf; tag = buf;
while (1) { while (1) {
c = scheme_getc(port); c = scheme_getc(port);
@ -3228,7 +3242,7 @@ read_here_string(Scheme_Object *port, Scheme_Object *stxsrc,
while (1) { while (1) {
c = scheme_getc(port); c = scheme_getc(port);
if (c == EOF) { if (c == EOF) {
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), EOF, indentation, scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, init_span), EOF, indentation,
"read: found end-of-file before terminating %u%s", "read: found end-of-file before terminating %u%s",
tag, tag,
(tlen > 50) ? 50 : tlen, (tlen > 50) ? 50 : tlen,
@ -3407,7 +3421,7 @@ read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port,
/* 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, ht); port, stxsrc, line, col, pos, ht, NULL);
/* Special-comment result is handled in main loop. */ /* Special-comment result is handled in main loop. */
} }
} }
@ -4099,7 +4113,7 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
ch = scheme_getc_special_ok(port); ch = scheme_getc_special_ok(port);
if (ch == EOF) if (ch == EOF)
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 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 (ch == SCHEME_SPECIAL)
scheme_get_ready_read_special(port, stxsrc, ht); scheme_get_ready_read_special(port, stxsrc, ht);
@ -4129,7 +4143,7 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
skipped = read_inner(port, stxsrc, ht, indentation, params, 0); skipped = read_inner(port, stxsrc, ht, indentation, params, 0);
if (SCHEME_EOFP(skipped)) if (SCHEME_EOFP(skipped))
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), EOF, indentation, scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation,
"read: expected a commented-out element for `#;' (found end-of-file)"); "read: expected a commented-out element for `#;' (found end-of-file)");
/* For resolving graphs introduced in #; : */ /* For resolving graphs introduced in #; : */
@ -5614,9 +5628,9 @@ static int readtable_kind(Readtable *t, int ch, ReadParams *params)
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, long line, long col, long pos, Scheme_Object *port, Scheme_Object *src, long line, long col, long pos,
Scheme_Hash_Table **ht) Scheme_Hash_Table **ht, Scheme_Object *modpath_stx)
{ {
int cnt; int cnt, add_srcloc = 0;
Scheme_Object *a[6], *v; Scheme_Object *a[6], *v;
Scheme_Cont_Frame_Data cframe; Scheme_Cont_Frame_Data cframe;
@ -5629,21 +5643,35 @@ static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, Re
} else { } else {
cnt = 6; cnt = 6;
a[2] = (src ? src : scheme_false); a[2] = (src ? src : scheme_false);
a[3] = (line > 0) ? scheme_make_integer(line) : scheme_false; add_srcloc = 3;
a[4] = (col > 0) ? scheme_make_integer(col-1) : scheme_false;
a[5] = (pos > 0) ? scheme_make_integer(pos) : scheme_false;
} }
} else { } else {
if (src) { if (src) {
cnt = 2;
a[0] = src; a[0] = src;
a[1] = port; a[1] = port;
if (modpath_stx) {
a[2] = modpath_stx;
add_srcloc = 3;
cnt = 6;
} else
cnt = 2;
} else { } else {
cnt = 1;
a[0] = port; a[0] = port;
if (modpath_stx) {
a[1] = modpath_stx;
add_srcloc = 2;
cnt = 5;
} else
cnt = 1;
} }
} }
if (add_srcloc) {
a[add_srcloc + 0] = (line > 0) ? scheme_make_integer(line) : scheme_false;
a[add_srcloc + 1] = (col > 0) ? scheme_make_integer(col-1) : scheme_false;
a[add_srcloc + 2] = (pos > 0) ? scheme_make_integer(pos) : scheme_false;
}
if (src) { if (src) {
/* fresh ht in case nested uses recursive `read' instead of recursive `read-syntax': */ /* fresh ht in case nested uses recursive `read' instead of recursive `read-syntax': */
ht = MALLOC_N(Scheme_Hash_Table *, 1); ht = MALLOC_N(Scheme_Hash_Table *, 1);
@ -5719,7 +5747,7 @@ static Scheme_Object *readtable_handle(Readtable *t, int *_ch, int *_use_default
v = SCHEME_CDR(v); v = SCHEME_CDR(v);
v = readtable_call(1, ch, v, params, port, src, line, col, pos, ht); v = readtable_call(1, ch, v, params, port, src, line, col, pos, ht, NULL);
return v; return v;
} }
@ -5755,7 +5783,7 @@ static Scheme_Object *readtable_handle_hash(Readtable *t, int ch, int *_use_defa
*_use_default = 0; *_use_default = 0;
v = readtable_call(1, ch, v, params, port, src, line, col, pos, ht); v = readtable_call(1, ch, v, params, port, src, line, col, pos, ht, NULL);
if (scheme_special_comment_value(v)) if (scheme_special_comment_value(v))
return NULL; return NULL;
@ -5995,13 +6023,18 @@ static Scheme_Object *current_reader_guard(int argc, Scheme_Object **argv)
1, NULL, NULL, 0); 1, NULL, NULL, 0);
} }
static Scheme_Object *do_reader(Scheme_Object *modpath, static Scheme_Object *do_reader(Scheme_Object *modpath_stx,
Scheme_Object *port, Scheme_Object *port,
Scheme_Object *stxsrc, long line, long col, long pos, Scheme_Object *stxsrc, long line, long col, long pos,
Scheme_Hash_Table **ht, Scheme_Hash_Table **ht,
Scheme_Object *indentation, ReadParams *params) Scheme_Object *indentation, ReadParams *params)
{ {
Scheme_Object *name, *a[2], *proc, *v; Scheme_Object *modpath, *name, *a[2], *proc, *v;
if (stxsrc)
modpath = scheme_syntax_to_datum(modpath_stx, 0, NULL);
else
modpath = modpath_stx;
proc = scheme_get_param(scheme_current_config(), MZCONFIG_READER_GUARD); proc = scheme_get_param(scheme_current_config(), MZCONFIG_READER_GUARD);
@ -6018,16 +6051,21 @@ static Scheme_Object *do_reader(Scheme_Object *modpath,
proc = scheme_dynamic_require(2, a); proc = scheme_dynamic_require(2, a);
a[0] = proc; a[0] = proc;
if (!scheme_check_proc_arity(NULL, stxsrc ? 2 : 1, 0, 1, a)) { if (scheme_check_proc_arity(NULL, stxsrc ? 6 : 5, 0, 1, a)) {
/* provide modpath_stx to reader */
} else if (scheme_check_proc_arity(NULL, stxsrc ? 2 : 1, 0, 1, a)) {
/* don't provide modpath_stx to reader */
modpath_stx = NULL;
} else {
scheme_wrong_type("#reader", scheme_wrong_type("#reader",
(stxsrc ? "procedure (arity 2)" : "procedure (arity 1)"), (stxsrc ? "procedure (arity 2 or 6)" : "procedure (arity 1 or 5)"),
-1, -1, a); -1, -1, a);
return NULL; return NULL;
} }
v = readtable_call(0, 0, proc, params, v = readtable_call(0, 0, proc, params,
port, stxsrc, line, col, pos, port, stxsrc, line, col, pos,
ht); ht, modpath_stx);
if (scheme_special_comment_value(v)) if (scheme_special_comment_value(v))
return NULL; return NULL;
@ -6043,7 +6081,10 @@ static Scheme_Object *read_reader(Scheme_Object *port,
{ {
Scheme_Object *modpath; Scheme_Object *modpath;
modpath = scheme_read(port); if (stxsrc)
modpath = scheme_read_syntax(port, stxsrc);
else
modpath = scheme_read(port);
if (SCHEME_EOFP(modpath)) { if (SCHEME_EOFP(modpath)) {
scheme_read_err(port, stxsrc, line, col, pos, 1, EOF, indentation, scheme_read_err(port, stxsrc, line, col, pos, 1, EOF, indentation,
@ -6066,6 +6107,7 @@ static Scheme_Object *read_lang(Scheme_Object *port,
char *buf, *naya; char *buf, *naya;
int ch = 0; int ch = 0;
Scheme_Object *modpath; Scheme_Object *modpath;
long name_line = -1, name_col = -1, name_pos = -1;
size = 32; size = 32;
buf = MALLOC_N_ATOMIC(char, size); buf = MALLOC_N_ATOMIC(char, size);
@ -6076,6 +6118,8 @@ static Scheme_Object *read_lang(Scheme_Object *port,
ch = init_ch; ch = init_ch;
} else } else
ch = scheme_getc_special_ok(port); ch = scheme_getc_special_ok(port);
if (!len)
scheme_tell_all(port, &name_line, &name_col, &name_pos);
if (ch == EOF) { if (ch == EOF) {
break; break;
} else if (ch == SCHEME_SPECIAL) { } else if (ch == SCHEME_SPECIAL) {
@ -6138,6 +6182,10 @@ static Scheme_Object *read_lang(Scheme_Object *port,
buf[len] = 0; buf[len] = 0;
modpath = scheme_intern_symbol(buf); modpath = scheme_intern_symbol(buf);
if (stxsrc) {
modpath = scheme_make_stx_w_offset(modpath, name_line, name_col, name_pos,
SPAN(port, name_pos) - 1, stxsrc, STX_SRCTAG);
}
return do_reader(modpath, port, stxsrc, line, col, pos, ht, indentation, params); return do_reader(modpath, port, stxsrc, line, col, pos, ht, indentation, params);
} }