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

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

@@ -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

@@ -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

@@ -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)])))

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;
+    name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL, 0);
-    rec[drec].value_name = scheme_false;
-    
-    name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL);
-
-    rec[drec].value_name = vname;
 
     /* 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

@@ -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);

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

@@ -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,