[racket-dev] [plt] Push #27930: master branch updated
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, <mflatt at 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 <mflatt at 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]
>
> - at defproc[(syntax-local-infer-name [stx syntax?]) any/c]{
> + at 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,
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.racket-lang.org/dev/archive/attachments/20131216/bd77a48c/attachment-0001.html>
![[logo]](/logo.png){kind=logo}