<div dir="ltr">Is this really important enough to request addition to 6.0 given that it likely won't be included in the testing builds?<div> </div><div>Robby</div></div><div class="gmail_extra"> <div class="gmail_quote"> On Mon, Dec 16, 2013 at 10:07 AM, <<a href="mailto:mflatt@racket-lang.org" target="_blank">mflatt@racket-lang.org</a>> wrote: <blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex"> mflatt has updated `master' from 37dd4fc2b0 to 1ceca069c8. <a href="http://git.racket-lang.org/plt/37dd4fc2b0..1ceca069c8" target="_blank">http://git.racket-lang.org/plt/37dd4fc2b0..1ceca069c8</a> =====[ One Commit ]===================================================== Directory summary: 8.8% pkgs/racket-pkgs/racket-doc/syntax/scribblings/ 19.4% pkgs/racket-pkgs/racket-test/tests/racket/ 47.6% racket/collects/racket/private/ 24.1% racket/src/racket/src/ ~~~~~~~~~~ 1ceca06 Matthew Flatt <<a href="mailto:mflatt@racket-lang.org">mflatt@racket-lang.org</a>> 2013-12-16 08:16 : | more repairs to function-name inference | | 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 : M racket/collects/racket/private/kw.rkt | 2 +- M racket/collects/racket/private/name.rkt | 52 +++++++++++--------- M .../racket-doc/syntax/scribblings/name.scrbl | 10 ++-- M racket/src/racket/src/compile.c | 29 ++++++----- M racket/src/racket/src/eval.c | 9 ++-- M racket/src/racket/src/module.c | 2 +- M racket/src/racket/src/schpriv.h | 3 +- M .../racket-test/tests/racket/name.rktl | 23 +++++++++ =====[ Overall Diff ]=================================================== pkgs/racket-pkgs/racket-doc/syntax/scribblings/name.scrbl ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- OLD/pkgs/racket-pkgs/racket-doc/syntax/scribblings/name.scrbl +++ NEW/pkgs/racket-pkgs/racket-doc/syntax/scribblings/name.scrbl @@ -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.} pkgs/racket-pkgs/racket-test/tests/racket/name.rktl ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- OLD/pkgs/racket-pkgs/racket-test/tests/racket/name.rktl +++ NEW/pkgs/racket-pkgs/racket-test/tests/racket/name.rktl @@ -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) racket/collects/racket/private/kw.rkt ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- OLD/racket/collects/racket/private/kw.rkt +++ NEW/racket/collects/racket/private/kw.rkt @@ -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)] racket/collects/racket/private/name.rkt ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- OLD/racket/collects/racket/private/name.rkt +++ NEW/racket/collects/racket/private/name.rkt @@ -3,27 +3,31 @@ (#%require "define.rkt" "small-scheme.rkt") (#%provide syntax-local-infer-name) - (define (syntax-local-infer-name stx) - (let-values ([(prop) (syntax-property stx 'inferred-name)]) - (or (and prop - (not (void? prop)) - prop) - (let ([n (and (not (void? prop)) - (syntax-local-name))]) - (or n - (let ([s (syntax-source stx)]) - (and s - (let ([s (let ([s (format - "~a" - (cond - [(path? s) (path->string s)] - [else s]))]) - (if ((string-length s) . > . 20) - (string-append "..." (substring s (- (string-length s) 20))) - s))] - [l (syntax-line stx)] - [c (syntax-column stx)]) - (if l - (string->symbol (format "~a:~a:~a" s l c)) - (let ([p (syntax-position stx)]) - (string->symbol (format "~a::~a" s p))))))))))))) + (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 use-local? + (not (void? prop)) + (syntax-local-name))]) + (or n + (let ([s (syntax-source stx)]) + (and s + (let ([s (let ([s (format + "~a" + (cond + [(path? s) (path->string s)] + [else s]))]) + (if ((string-length s) . > . 20) + (string-append "..." (substring s (- (string-length s) 20))) + s))] + [l (syntax-line stx)] + [c (syntax-column stx)]) + (if l + (string->symbol (format "~a:~a:~a" s l c)) + (let ([p (syntax-position stx)]) + (string->symbol (format "~a::~a" s p)))))))))))] + [(stx) (syntax-local-infer-name stx #t)]))) racket/src/racket/src/compile.c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- OLD/racket/src/racket/src/compile.c +++ NEW/racket/src/racket/src/compile.c @@ -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)) { racket/src/racket/src/eval.c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- OLD/racket/src/racket/src/eval.c +++ NEW/racket/src/racket/src/eval.c @@ -3980,9 +3980,10 @@ static void *compile_k(void) while (1) { scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false); - form = scheme_check_immediate_macro(form, + 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); racket/src/racket/src/module.c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- OLD/racket/src/racket/src/module.c +++ NEW/racket/src/racket/src/module.c @@ -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)) { racket/src/racket/src/schpriv.h ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- OLD/racket/src/racket/src/schpriv.h +++ NEW/racket/src/racket/src/schpriv.h @@ -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, </blockquote></div> </div>