Is this really important enough to request addition to 6.0 given that it likely won't be included in the testing builds?
Robby On Mon, Dec 16, 2013 at 10:07 AM, <mfl...@racket-lang.org> wrote: > mflatt has updated `master' from 37dd4fc2b0 to 1ceca069c8. > http://git.racket-lang.org/plt/37dd4fc2b0..1ceca069c8 > > =====[ 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 <mfl...@racket-lang.org> 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, >
_________________________ Racket Developers list: http://lists.racket-lang.org/dev