allow #f as shift for `syntax-shift-phase-level'

collects/compiler/zo-structs.rkt

@@ -193,7 +193,7 @@
                                                              (or/c
                                                               (cons/c symbol? (or/c symbol? #f))
                                                               free-id-info?)))))])) 
-(define-form-struct (phase-shift wrap) ([amt exact-integer?] [src (or/c module-path-index? #f)] [dest (or/c module-path-index? #f)]))
+(define-form-struct (phase-shift wrap) ([amt (or/c exact-integer? #f)] [src (or/c module-path-index? #f)] [dest (or/c module-path-index? #f)]))
 (define-form-struct (wrap-mark wrap) ([val exact-integer?]))
 (define-form-struct (prune wrap) ([sym any/c]))
 

collects/scribblings/raco/zo-struct.scrbl

@@ -529,7 +529,7 @@ structures that are produced by @racket[zo-parse] and consumed by
 
 
 @defstruct+[(phase-shift wrap)
-            ([amt exact-integer?]
+            ([amt (or/c exact-integer? #f)]
              [src module-path-index?]
              [dest module-path-index?])]{
   Shifts module bindings later in the wrap set.}

collects/scribblings/reference/stx-ops.scrbl

@@ -265,13 +265,14 @@ if a former representative becomes otherwise unreachable, then
 
 
 @defproc[(syntax-shift-phase-level [stx syntax?]
-                                   [shift exact-integer?])
+                                   [shift (or/c exact-integer? #f)])
          syntax?]{
 
 Returns a syntax object that is like @racket[stx], but with all of its
 top-level and module binding shifted by @racket[shift] @tech{phase
-levels}. If @racket[shift] is @racket[0], then the result is
+levels}. If @racket[shift] is @racket[#f], then only bindings
-@racket[stx].}
+at @tech{phase level} 0 are shifted to the @tech{label phase level}.
+If @racket[shift] is @racket[0], then the result is @racket[stx].}
 
 
 @defproc[(generate-temporaries [stx-pair (or syntax? list?)]) 

collects/tests/racket/stx.rktl

@@ -516,6 +516,22 @@
     (test '(lib "lang/htdp-intermediate.rkt") values nominal)
     (test 'cons cadddr b)))
 
+(let ()
+  (define (check wrap)
+    (test #f identifier-binding (wrap (datum->syntax #f 'lambda)))
+    (test #f identifier-template-binding (wrap #'lambda))
+    (test (identifier-binding #'lambda) identifier-template-binding (wrap (syntax-shift-phase-level #'lambda -1)))
+    (test #f identifier-label-binding (wrap #'lambda))
+    (test (identifier-binding #'lambda) identifier-label-binding (wrap (syntax-shift-phase-level #'lambda #f)))
+    (test #f identifier-binding (wrap (syntax-shift-phase-level #'lambda #f)))
+    (test #f identifier-template-binding (wrap (syntax-shift-phase-level #'lambda #f))))
+  (check values)
+  (check (lambda (s)
+           (define-values (i o) (make-pipe))
+           (write (compile-syntax #`(quote-syntax #,s)) o)
+           (parameterize ([read-accept-compiled #t])
+             (eval (read i))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; eval versus eval-syntax, etc.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

src/racket/src/syntax.c

@@ -271,8 +271,8 @@ XFORM_NONGCING static int is_member(Scheme_Object *a, Scheme_Object *l)
          simple lexical renames (not ribs) and marks, only, and it's
          inserted into a chain heuristically
 
-   - A wrap-elem (box (vector <num> <midx> <midx> <export-registry> <insp>))
+   - A wrap-elem (box (vector <num-or #f> <midx> <midx> <export-registry> <insp>))
-         is a phase shift by <num>, remapping the first <midx> to the 
+         is a phase shift by <num-or-#f>, remapping the first <midx> to the 
          second <midx>; the <export-registry> part is for finding
          modules to unmarshal import renamings
 
@@ -1178,7 +1178,8 @@ static int same_phase(Scheme_Object *a, Scheme_Object *b)
   if (SAME_OBJ(a, b))
     return 1;
   else if (SCHEME_INTP(a) || SCHEME_INTP(b)
-           || SCHEME_FALSEP(a) || SCHEME_FALSEP(b))
+           || SCHEME_FALSEP(a) || SCHEME_FALSEP(b)
+           || SCHEME_VOIDP(a) || SCHEME_VOIDP(b))
     return 0;
   else
     return scheme_eqv(a, b);
@@ -2193,8 +2194,8 @@ static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv)
 {
   if (!SCHEME_STXP(argv[0]))
     scheme_wrong_type("syntax-shift-phase-level", "syntax", 0, argc, argv);
-  if (!scheme_exact_p(argv[1]))
+  if (SCHEME_TRUEP(argv[1]) && !scheme_exact_p(argv[1]))
-    scheme_wrong_type("syntax-shift-phase-level", "exact integer", 0, argc, argv);
+    scheme_wrong_type("syntax-shift-phase-level", "exact integer or #f", 0, argc, argv);
 
   if (SCHEME_INTP(argv[1]) && !SCHEME_INT_VAL(argv[1]))
     return argv[0];
@@ -3123,6 +3124,21 @@ XFORM_NONGCING static int is_from_rib(Scheme_Object *other_env)
     return 0;
 }
 
+static Scheme_Object *reverse_phase_shift(Scheme_Object *phase, Scheme_Object *n)
+{
+  if (SCHEME_TRUEP(n) && !SCHEME_VOIDP(phase)) {
+    if (SCHEME_TRUEP(phase))
+      phase = scheme_bin_minus(phase, n);
+  } else {
+    /* phase shift to #f shifts only phase-0 bindings: */
+    if (SCHEME_FALSEP(phase))
+      phase = scheme_make_integer(0);
+    else
+      phase = scheme_void; /* don't match any phase */
+  }
+  return phase;
+}
+
 static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env)
 /* Compares the marks in two wraps lists. The `barrier_env' argument cuts
    off the mark list if a rib containing a `barrier_env' renaming is found;
@@ -4055,8 +4071,7 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase,
 
       EXPLAIN(fprintf(stderr, "%d phase shift by %d\n", depth, SCHEME_INT_VAL(n)));
 
-      if (SCHEME_TRUEP(phase))
+      phase = reverse_phase_shift(phase, n);
-        phase = scheme_bin_minus(phase, n);
      
       src = SCHEME_VEC_ELS(vec)[1];
       dest = SCHEME_VEC_ELS(vec)[2];
@@ -4454,8 +4469,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
       Scheme_Object *n, *vec;
       vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps));
       n = SCHEME_VEC_ELS(vec)[0];
-      if (SCHEME_TRUEP(phase))
+      phase = reverse_phase_shift(phase, n);
-        phase = scheme_bin_minus(phase, n);
     } else if (!no_lexical
                && (SCHEME_VECTORP(WRAP_POS_FIRST(wraps))
                    || SCHEME_RIBP(WRAP_POS_FIRST(wraps)))) {
@@ -6064,11 +6078,8 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum,
                   redundant = 1;
                   break;
                 }
-              } else if (SCHEME_BOXP(la)) {
+              } else if (SCHEME_BOXP(la))
-                if (SCHEME_TRUEP(phase))
+                phase = reverse_phase_shift(phase, SCHEME_VEC_ELS(SCHEME_BOX_VAL(la))[0]);
-                  phase = scheme_bin_minus(phase,
-                                           SCHEME_VEC_ELS(SCHEME_PTR_VAL(WRAP_POS_FIRST(l)))[0]);
-              }
             }
           }