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

more repairs to function-name inference

Browse Source 
The main change is to add an option to `syntax-local-infer-name` to
select whether `syntax-local-name` is used, and to use the new option
to disable `syntax-local-name` for the function expression in a
keyword `#%app`.

Improvements in the expander/compiler generalize a previous repair.

Merge to v6.0
This commit is contained in:
Matthew Flatt 2013-12-16 08:16:31 -07:00
parent 37dd4fc2b0
commit 1ceca069c8
8 changed files with 81 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/racket-pkgs/racket-doc/syntax/scribblings/name.scrbl
View File

@ -5,12 +5,16 @@
@defmodule[syntax/name]
@defproc[(syntax-local-infer-name [stx syntax?]) any/c]{
@defproc[(syntax-local-infer-name [stx syntax?] [use-local? any/c #t]) any/c]{
Similar to @racket[syntax-local-name] except that @racket[stx] is
Similar to @racket[syntax-local-name], except that @racket[stx] is
checked for an @racket['inferred-name] property (which overrides any
inferred name). If neither @racket[syntax-local-name] nor
@racket['inferred-name] produce a name, or if the
@racket['inferred-name] property value is @|void-const|, then a name
is constructed from the source-location information in @racket[stx],
if any. If no name can be constructed, the result is @racket[#f].}
if any. If no name can be constructed, the result is @racket[#f].
If @racket[use-local?] is @racket[#f], then @racket[syntax-local-name] is
not used. Provide @racket[use-local?] as @racket[#f] to construct a name
for a syntax object that is not an expression currently being expanded.}

23
pkgs/racket-pkgs/racket-test/tests/racket/name.rktl
View File

@ -107,5 +107,28 @@
(err/rt-test (let ([unmentionable ((lambda (x #:a a) 1) 1 2)]) 5)
(lambda (exn) (not (regexp-match? #rx"unmentionable" (exn-message exn)))))
(err/rt-test (let ([unmentionable ((lambda (x #:a a) 1) #:q 1 2)]) 5)
(lambda (exn) (not (regexp-match? #rx"unmentionable" (exn-message exn)))))
(err/rt-test (let ([mentionable (let ()
(define v 1)
(lambda (x #:a a) v))])
(mentionable 1 2))
(lambda (exn) (regexp-match? #rx"mentionable" (exn-message exn))))
(err/rt-test (let ([mentionable (let ()
(define v 1)
(lambda (x #:a a) v))])
(mentionable #:q 1 2))
(lambda (exn) (regexp-match? #rx"mentionable" (exn-message exn))))
(syntax-test #'(let-syntax ([fail (lambda (stx)
(raise-syntax-error 'fail
(format "~s" (syntax-local-name))))])
(let ([unmentionable (let ()
(fail)
10)])
5))
#rx"^(?!.*unmentionable)")
(report-errs)

2
racket/collects/racket/private/kw.rkt
View File

@ -918,7 +918,7 @@
(loop (cddr l)))])]
[else
(cons (car l) (loop (cdr l)))])))])
(let ([ids (cons (or (syntax-local-infer-name stx)
(let ([ids (cons (or (syntax-local-infer-name stx #f)
'procedure)
(generate-temporaries exprs))])
(let loop ([l (cdr l)]

10
racket/collects/racket/private/name.rkt
View File

@ -3,12 +3,15 @@
(#%require "define.rkt" "small-scheme.rkt")
(#%provide syntax-local-infer-name)
(define (syntax-local-infer-name stx)
(define syntax-local-infer-name
(case-lambda
[(stx use-local?)
(let-values ([(prop) (syntax-property stx 'inferred-name)])
(or (and prop
(not (void? prop))
prop)
(let ([n (and (not (void? prop))
(let ([n (and use-local?
(not (void? prop))
(syntax-local-name))])
(or n
(let ([s (syntax-source stx)])
@ -26,4 +29,5 @@
(if l
(string->symbol (format "~a:~a:~a" s l c))
(let ([p (syntax-position stx)])
(string->symbol (format "~a::~a" s p)))))))))))))
(string->symbol (format "~a::~a" s p)))))))))))]
[(stx) (syntax-local-infer-name stx #t)])))

29
racket/src/racket/src/compile.c
View File

@ -2770,7 +2770,7 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms,
Scheme_Object *first, *val;
first = SCHEME_STX_CAR(forms);
first = scheme_check_immediate_macro(first, env, rec, drec, 1, &val, NULL, NULL);
first = scheme_check_immediate_macro(first, env, rec, drec, 1, &val, NULL, NULL, 0);
if (SAME_OBJ(val, scheme_begin_syntax) && SCHEME_STX_PAIRP(first)) {
/* Flatten begin: */
@ -4270,7 +4270,8 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
int internel_def_pos,
Scheme_Object **current_val,
Scheme_Comp_Env **_xenv,
Scheme_Object *ctx)
Scheme_Object *ctx,
int keep_name)
{
Scheme_Object *name, *val;
Scheme_Comp_Env *xenv = (_xenv ? *_xenv : NULL);
@ -4337,7 +4338,7 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
{
scheme_init_expand_recs(rec, drec, &erec1, 1);
erec1.depth = 1;
erec1.value_name = rec[drec].value_name;
erec1.value_name = (keep_name ? rec[drec].value_name : scheme_false);
first = scheme_expand_expr(first, xenv, &erec1, 0);
}
break; /* break to outer loop */
@ -4933,16 +4934,11 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env,
/* naya will be prefixed and returned... */
}
} else if (rec[drec].comp) {
Scheme_Object *name, *origname, *gval, *orig_rest_form, *rest_form, *vname;
Scheme_Object *name, *origname, *gval, *orig_rest_form, *rest_form;
name = SCHEME_STX_CAR(form);
origname = name;
vname = rec[drec].value_name;
rec[drec].value_name = scheme_false;
name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL);
rec[drec].value_name = vname;
name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL, 0);
/* look for ((lambda (x ...) ....) ....) or ((lambda x ....) ....) */
if (SAME_OBJ(gval, scheme_lambda_syntax)) {
@ -5054,13 +5050,13 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env,
if (scheme_stx_module_eq(name, cwv_stx, 0)) {
Scheme_Object *first, *orig_first;
orig_first = SCHEME_STX_CAR(at_first);
first = scheme_check_immediate_macro(orig_first, env, rec, drec, 0, &gval, NULL, NULL);
first = scheme_check_immediate_macro(orig_first, env, rec, drec, 0, &gval, NULL, NULL, 0);
if (SAME_OBJ(gval, scheme_lambda_syntax)
&& SCHEME_STX_PAIRP(first)
&& (arg_count(first, env) == 0)) {
Scheme_Object *second, *orig_second;
orig_second = SCHEME_STX_CAR(at_second);
second = scheme_check_immediate_macro(orig_second, env, rec, drec, 0, &gval, NULL, NULL);
second = scheme_check_immediate_macro(orig_second, env, rec, drec, 0, &gval, NULL, NULL, 0);
if (SAME_OBJ(gval, scheme_lambda_syntax)
&& SCHEME_STX_PAIRP(second)
&& (arg_count(second, env) >= 0)) {
@ -5577,13 +5573,15 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
{
Scheme_Object *gval, *result;
int more = 1;
int more = 1, is_last;
is_last = SCHEME_STX_NULLP(SCHEME_STX_CDR(forms));
result = forms;
/* Check for macro expansion, which could mask the real
define-values, define-syntax, etc.: */
first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx);
first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx, is_last);
if (SAME_OBJ(gval, scheme_begin_syntax)) {
/* Inline content */
@ -5808,7 +5806,8 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer,old_first,first);
}
first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx);
is_last = SCHEME_STX_NULLP(SCHEME_STX_CDR(result));
first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx, is_last);
more = 1;
if (NOT_SAME_OBJ(gval, scheme_define_values_syntax)
&& NOT_SAME_OBJ(gval, scheme_define_syntaxes_syntax)) {

7
racket/src/racket/src/eval.c
View File

@ -3982,7 +3982,8 @@ static void *compile_k(void)
scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false);
form = scheme_check_immediate_macro(form,
cenv, &rec, 0,
0, &gval, NULL, NULL);
0, &gval, NULL, NULL,
1);
if (SAME_OBJ(gval, scheme_begin_syntax)) {
if (scheme_stx_proper_list_length(form) > 1){
form = SCHEME_STX_CDR(form);
@ -4467,7 +4468,7 @@ static void *expand_k(void)
if (just_to_top) {
Scheme_Object *gval;
obj = scheme_check_immediate_macro(obj, env, &erec1, 0, 0, &gval, NULL, NULL);
obj = scheme_check_immediate_macro(obj, env, &erec1, 0, 0, &gval, NULL, NULL, 1);
} else
obj = scheme_expand_expr(obj, env, &erec1, 0);
@ -5036,7 +5037,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
drec[0].comp_flags = comp_flags;
}
xl = scheme_check_immediate_macro(l, env, drec, 0, 0, &gval, NULL, NULL);
xl = scheme_check_immediate_macro(l, env, drec, 0, 0, &gval, NULL, NULL, 1);
if (SAME_OBJ(xl, l) && !for_expr) {
SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, xl);

2
racket/src/racket/src/module.c
View File

@ -7363,7 +7363,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
if (!check_mb) {
fm = scheme_check_immediate_macro(fm, benv, rec, drec, 0, &mbval, NULL, NULL);
fm = scheme_check_immediate_macro(fm, benv, rec, drec, 0, &mbval, NULL, NULL, 1);
/* If expansion is not the primitive `#%module-begin', add local one: */
if (!SAME_OBJ(mbval, modbeg_syntax)) {

3
racket/src/racket/src/schpriv.h
View File

@ -2707,7 +2707,8 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
int int_def_pos,
Scheme_Object **current_val,
Scheme_Comp_Env **_xenv,
Scheme_Object *ctx);
Scheme_Object *ctx,
int keep_name);
Scheme_Object *scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
Scheme_Object *f, Scheme_Object *code,