add internal-definition-context-{binding-identifier,track}

When an internal-definition context is used with `local-expand`, the
any binding added to the context affect expansion, but the binding do
not appear in the expansion. As a result, Check Syntax was unable to
draw an arrow from the `s` use to its binding in

 (class object%
   (define-struct s ())
   s)

The general solution is to add the internal-definition context's
bindings to the expansion as a 'disappeared-bindings property. The new
`internal-definitionc-context-track` function does that using a new
`internal-definition-context-binding-identifier` primitive.

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.3.0.3")
+(define version "6.3.0.4")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/reference/stx-trans.scrbl

@@ -5,7 +5,8 @@
                      racket/require-syntax
                      racket/provide-transform
                      racket/provide-syntax
-                     racket/keyword-transform))
+                     racket/keyword-transform
+                     syntax/intdef))
 
 @(define stx-eval (make-base-eval))
 @(interaction-eval #:eval stx-eval (require (for-syntax racket/base)))
@@ -298,6 +299,13 @@ context is meant to splice into an immediately enclosing context, then
 when @racket[syntax-local-context] produces a list, @racket[cons] the
 generated value onto that list.
 
+When expressions are expanded via @racket[local-expand] with an
+internal-definition context @racket[intdef-ctx], and when the expanded
+expressions are incorporated into an overall form @racket[_new-stx],
+then typically @racket[internal-definition-context-track] should be
+applied to @racket[intdef-ctx] and @racket[_new-stx] to provide
+expansion history to external tools.
+
 @transform-time[]
 
 @examples[#:eval stx-eval
@@ -456,6 +464,18 @@ match the number of identifiers, otherwise the
 @transform-time[]}
 
 
+@defproc[(internal-definition-context-binding-identifiers
+          [intdef-ctx internal-definition-context?])
+         (listof identifier?)]{
+
+Returns a list of all binding identifiers registered for
+@racket[intdef-ctx] through @racket[syntax-local-bind-syntaxes]. Each
+identifier in the returned list includes the @tech{internal-definition
+context}'s @tech{scope}.
+
+@history[#:added "6.3.0.4"]}
+
+
 @defproc[(internal-definition-context-introduce [intdef-ctx internal-definition-context?]
                                                 [stx syntax?]
                                                 [mode (or/c 'flip 'add 'remove) 'flip])
@@ -489,6 +509,8 @@ provided for backward compatibility; the more general
 @history[#:changed "6.3" @elem{Simplified the operation to @tech{scope} removal.}]}
 
 
+
+
 @defthing[prop:expansion-contexts struct-type-property?]{
 
 A @tech{structure type property} to constrain the use of macro

pkgs/racket-doc/syntax/scribblings/intdef.scrbl

@@ -0,0 +1,22 @@
+#lang scribble/doc
+@(require "common.rkt" (for-label syntax/intdef))
+
+@title[#:tag "intdef"]{Internal-Definition Context Helpers}
+
+@defmodule[syntax/intdef]
+
+@history[#:added "6.3.0.4"]
+
+@defproc[(internal-definition-context-track
+          [intdef-ctx internal-definition-context?]
+          [stx syntax?])
+         syntax?]{
+
+Adjusts the @tech[#:doc refman]{syntax properties} of @racket[stx] to
+record that parts of @racket[stx] were expanded via
+@racket[intdef-ctx].
+
+Specifically, the identifiers produced by
+@racket[(internal-definition-context-binding-identifiers intdef-ctx)]
+are added to the @racket['disappeared-bindings] property of
+@racket[stx].}

pkgs/racket-doc/syntax/scribblings/syntax.scrbl

@@ -35,4 +35,6 @@
 
 @include-section["macro-testing.scrbl"]
 
+@include-section["intdef.scrbl"]
+
 @index-section[]

pkgs/racket-test-core/tests/racket/object.rktl

@@ -2153,6 +2153,53 @@
                (class c% (super-new) (field [x 0])))
              exn:fail?)
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check for Check-Syntax support for a `struct`
+;; form in `class`, which depends on proper handling
+;; of bindings from an internal-definition context
+
+(let ()
+  (define binds null)
+  (define refs null)
+  
+  (define (inspect stx)
+    (when (and (identifier? stx)
+               (eq? 's (syntax-e stx)))
+      (set! refs (cons stx refs)))
+    (cond
+     [(syntax? stx)
+      (check stx 'disappeared-binding)
+      (inspect (syntax-e stx))
+      (inspect (syntax-property stx 'origin))]
+     [(pair? stx)
+      (inspect (car stx))
+      (inspect (cdr stx))]))
+  
+  (define (check stx prop)
+    (define v (syntax-property stx prop))
+    (when (and v (get-s v))
+      (set! binds (cons (get-s v) binds))))
+
+  (define (get-s e)
+    (or (and (identifier? e)
+             (eq? 's (syntax-e e))
+             e)
+        (and (pair? e)
+             (or (get-s (car e))
+                 (get-s (cdr e))))
+        (and (syntax? e)
+             (get-s (syntax-e e)))))
+
+  (inspect (expand #'(module m racket/base
+                       (require racket/class)
+                       (class object%
+                         (define-struct s ())
+                         s))))
+  
+  (for ([r (in-list refs)])
+    (test #t 'has-binding-match? (for/or ([b (in-list binds)])
+                                   (free-identifier=? r b)))))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

racket/collects/racket/block.rkt

@@ -4,7 +4,8 @@
                          "private/stx.rkt"
                          "private/small-scheme.rkt"
                          "private/stxcase-scheme.rkt"
-                         "private/qqstx.rkt"))
+                         "private/qqstx.rkt"
+                         syntax/intdef))
 
 (#%provide block)
 
@@ -59,12 +60,14 @@
                [prev-exprs null])
       (cond
         [(null? exprs)
-         #`(letrec-syntaxes+values
+         (internal-definition-context-track
-            #,(map stx-cdr (reverse prev-stx-defns))
+          def-ctx
-            #,(map stx-cdr (reverse prev-defns))
+          #`(letrec-syntaxes+values
-            #,@(if (null? prev-exprs)
+             #,(map stx-cdr (reverse prev-stx-defns))
-                 (list #'(void))
+             #,(map stx-cdr (reverse prev-defns))
-                 (reverse prev-exprs)))]
+             #,@(if (null? prev-exprs)
+                    (list #'(void))
+                    (reverse prev-exprs))))]
         [(and (stx-pair? (car exprs))
               (identifier? (stx-car (car exprs)))
               (free-identifier=? #'define-syntaxes (stx-car (car exprs))))

racket/collects/racket/private/class-internal.rkt

@@ -19,6 +19,7 @@
                      syntax/flatten-begin
                      syntax/private/boundmap
                      syntax/parse
+                     syntax/intdef
                      "classidmap.rkt"))
 
 (define insp (current-inspector)) ; for all opaque structures
@@ -958,23 +959,25 @@
               ;; of a class). It doesn't use syntax-track-origin because there is
               ;; no residual code that it would make sense to be the result of expanding
               ;; those away. So, instead we only look at a few properties (as below).
+              ;; Also, add 'disappeared-binding properties from `ctx`.
               (define (add-decl-props stx)
-                (for/fold ([stx stx])
+                (internal-definition-context-track
-                          ([decl (in-list (append inspect-decls decls))])
+                 def-ctx
-                  (define (copy-prop src dest stx)
+                 (for/fold ([stx stx])
-                    (syntax-property 
+                           ([decl (in-list (append inspect-decls decls))])
-                     stx
+                   (define (copy-prop src dest stx)
-                     dest
+                     (syntax-property 
-                     (cons (syntax-property decl src)
+                      stx
-                           (syntax-property stx dest))))
+                      dest
-                  (copy-prop
+                      (cons (syntax-property decl src)
-                   'origin 'disappeared-use
+                            (syntax-property stx dest))))
                    (copy-prop
-                    'disappeared-use 'disappeared-use
+                    'origin 'disappeared-use
                     (copy-prop
-                     'disappeared-binding 'disappeared-binding
+                     'disappeared-use 'disappeared-use
-                     stx)))))
+                     (copy-prop
-              
+                      'disappeared-binding 'disappeared-binding
+                      stx))))))
               ;; At most one inspect:
               (unless (or (null? inspect-decls)
                           (null? (cdr inspect-decls)))

racket/collects/racket/unit.rkt

@@ -12,6 +12,7 @@
                      racket/struct-info
                      syntax/stx
                      syntax/location
+                     syntax/intdef
                      "private/unit-contract-syntax.rkt"
                      "private/unit-compiletime.rkt"
                      "private/unit-syntax.rkt"))
@@ -1203,7 +1204,9 @@
                                                    (apply append (map do-one ids tmps))))]
                                           [else (list defn-or-expr)]))
                                       expanded-body))])
-             #'(block defn-or-expr ...))))))))
+             (internal-definition-context-track
+              def-ctx
+              #'(block defn-or-expr ...)))))))))
 
 (define-for-syntax (redirect-imports/exports import?)
   (lambda (table-stx

racket/collects/syntax/intdef.rkt

@@ -0,0 +1,14 @@
+(module intdef '#%kernel
+  (#%provide internal-definition-context-track)
+
+  (define-values (internal-definition-context-track)
+    (lambda (intdef stx)
+      (if (internal-definition-context? intdef)
+          (if (syntax? stx)
+              (let-values ([(ids) (internal-definition-context-binding-identifiers intdef)])
+                (if (null? ids)
+                    stx
+                    (let-values ([(v) (syntax-property stx 'disappeared-binding)])
+                      (syntax-property stx 'disappeared-binding (if v (cons ids v) ids)))))
+              (raise-argument-error 'internal-definition-context-track "syntax?" 1 intdef stx))
+          (raise-argument-error 'internal-definition-context-track "internal-definition-context?" 0 intdef stx)))))

racket/src/racket/src/env.c

@@ -102,6 +102,7 @@ static Scheme_Object *local_make_intdef_context(int argc, Scheme_Object *argv[])
 static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]);
 static Scheme_Object *intdef_context_intro(int argc, Scheme_Object *argv[]);
 static Scheme_Object *intdef_context_p(int argc, Scheme_Object *argv[]);
+static Scheme_Object *intdef_context_ids(int argc, Scheme_Object *argv[]);
 static Scheme_Object *id_intdef_remove(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_introduce(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_get_shadower(int argc, Scheme_Object *argv[]);
@@ -781,6 +782,7 @@ static void make_kernel_env(void)
   GLOBAL_PRIM_W_ARITY("internal-definition-context-seal", intdef_context_seal, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("internal-definition-context-introduce", intdef_context_intro, 2, 3, env);
   GLOBAL_PRIM_W_ARITY("internal-definition-context?", intdef_context_p, 1, 1, env);
+  GLOBAL_PRIM_W_ARITY("internal-definition-context-binding-identifiers", intdef_context_ids, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("identifier-remove-from-definition-context", id_intdef_remove, 2, 2, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-get-shadower", local_get_shadower, 1, 2, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-introduce", local_introduce, 1, 1, env);
@@ -2564,6 +2566,16 @@ id_intdef_remove(int argc, Scheme_Object *argv[])
   return res;
 }
 
+static Scheme_Object *intdef_context_ids(int argc, Scheme_Object *argv[])
+{
+  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type))
+    scheme_wrong_contract("internal-definition-context-binding-identifiers",
+                          "internal-definition-context?", 
+                          0, argc, argv);
+  
+  return scheme_intdef_bind_identifiers(argv[0]);
+}
+
 static Scheme_Object *
 local_introduce(int argc, Scheme_Object *argv[])
 {

racket/src/racket/src/eval.c

@@ -5894,6 +5894,26 @@ local_eval(int argc, Scheme_Object **argv)
   return scheme_void;
 }
 
+Scheme_Object *scheme_intdef_bind_identifiers(Scheme_Object *intdef)
+{
+  Scheme_Comp_Env *stx_env, *init_env;
+  Scheme_Object *l = scheme_null;
+  int i;
+  
+  update_intdef_chain(intdef);
+  stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(intdef))[0];
+  init_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(intdef))[3];
+
+  while (stx_env != init_env) {
+    for (i = stx_env->num_bindings; i--; ) {
+      l = scheme_make_pair(stx_env->binders[i], l);
+    }
+    stx_env = stx_env->next;
+  }
+
+  return l;
+}
+
 /*========================================================================*/
 /*                       cloning prefix information                       */
 /*========================================================================*/

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1135
+#define EXPECTED_PRIM_COUNT 1136
 #define EXPECTED_UNSAFE_COUNT 106
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_EXTFL_COUNT 45

racket/src/racket/src/schpriv.h

@@ -2979,6 +2979,8 @@ Scheme_Native_Closure_Data *scheme_generate_case_lambda(Scheme_Case_Lambda *cl);
 
 void scheme_delay_load_closure(Scheme_Closure_Data *data);
 
+Scheme_Object *scheme_intdef_bind_identifiers(Scheme_Object *intdef);
+  
 #define scheme_add_good_binding(i,v,f) (f->values[i] = v)
 
 Scheme_Object *scheme_compiled_void(void);

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.3.0.3"
+#define MZSCHEME_VERSION "6.3.0.4"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 3
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 3
+#define MZSCHEME_VERSION_W 4
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)