add `prop:liberal-define-context'

collects/racket/block.rkt

@@ -13,12 +13,18 @@
 
 (#%provide block)
 
+(define-values-for-syntax (make-context)
+  (let-values ([(struct: mk ? ref set)
+                (make-struct-type 'in-liberal-define-context #f 0 0 #f
+                                  (list (cons prop:liberal-define-context #t)))])
+    mk))
+
 (define-syntax (block stx)
   ;; Body can have mixed exprs and defns. Wrap expressions with
   ;; `(define-values () ... (values))' as needed, and add a (void)
   ;; at the end if needed.
   (let* ([def-ctx (syntax-local-make-definition-context)]
-         [ctx (list (gensym 'intdef))]
+         [ctx (list (make-context))]
          ;; [kernel-forms (kernel-form-identifier-list)]
          [stoplist (list #'begin #'define-syntaxes #'define-values)]
          [init-exprs (let ([v (syntax->list stx)])

collects/racket/package.rkt

@@ -4,7 +4,8 @@
                      syntax/kerncase
                      syntax/boundmap
                      syntax/define
-                     syntax/flatten-begin))
+                     syntax/flatten-begin
+                     syntax/context))
 
 (provide define-package
          package-begin
@@ -141,11 +142,7 @@
                                          stx
                                          exports)])])
          (let* ([def-ctx (syntax-local-make-definition-context)]
-                [ctx (cons (gensym 'intdef)
+                [ctx (generate-expand-context #t)]
-                           (let ([orig-ctx (syntax-local-context)])
-                             (if (pair? orig-ctx)
-                                 orig-ctx
-                                 null)))]
                 [pre-package-id (lambda (id def-ctxes)
                                   (identifier-remove-from-definition-context 
                                    id 

collects/racket/private/kw.rkt

@@ -785,7 +785,10 @@
                        (define #,id #,rhs)))])
         (syntax-case rhs ()
           [(lam-id . _)
-           (and (memq (syntax-local-context) '(top-level module module-begin))
+           (and (let ([ctx (syntax-local-context)])
+                  (or (memq ctx '(top-level module module-begin))
+                      (and (list? ctx)
+                           (andmap liberal-define-context? ctx))))
                 (identifier? #'lam-id)
                 (or (free-identifier=? #'lam-id #'new-lambda)
                     (free-identifier=? #'lam-id #'new-λ)))

collects/scribblings/reference/stx-trans.scrbl

@@ -194,9 +194,8 @@ with an empty context is used, instead.}
 Expands @racket[stx] in the lexical context of the expression
 currently being expanded. The @racket[context-v] argument is used as
 the result of @racket[syntax-local-context] for immediate expansions;
-for a particular @tech{internal-definition context}, generate a unique
+a list indicates an @tech{internal-definition context}, and more
-value and @racket[cons] it onto the current result of
+information on the form of the list is below.
-@racket[syntax-local-context] if it is a list.
 
 When an identifier in @racket[stop-ids] is encountered by the expander
 in a sub-expression, expansions stops for the sub-expression. If
@@ -226,6 +225,17 @@ internal definitions is added to @racket[stx] before it is expanded
 also added to the expansion result (because the expansion might
 introduce bindings or references to internal-definition bindings).
 
+For a particular @tech{internal-definition context}, generate a unique
+value and put it into a list for @racket[context-v]. To allow
+@tech{liberal expansion} of @racket[define] forms, the generated value
+should be an instance of a structure with a true value for
+@racket[prop:liberal-define-context]. If the internal-definition
+context is meant to be self-contained, the list for @racket[context-c]
+should contain only the generated value; if the internal-definition
+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.
+
 @transform-time[]
 
 @examples[#:eval stx-eval
@@ -777,6 +787,24 @@ includes the identifier by its internal name. Use
 @racket[identifier-binding] to obtain more information about the
 identifier.}
 
+@deftogether[(
+@defthing[prop:liberal-define-context struct-type-property?]
+@defproc[(liberal-define-context? [v any/c]) boolean?]
+)]{
+
+An instance of a structure type with a true value for the
+@racket[prop:liberal-define-context] property can be used as an
+element of an @tech{internal-definition context} representation in the
+result of @racket[syntax-local-context] for the second argument of
+@racket[local-expand]. Such a value indicates that the context
+supports @deftech{liberal expansion} of @racket[define] forms into
+potentially multiple @racket[define-values] and
+@racket[define-syntaxes] forms.
+
+The @racket[liberal-define-context?] predicate returns @racket[#t] if
+@arcket[v] is an instance of a structure with a true value for the
+@racket[prop:liberal-define-context] property, @racket[#f] otherwise.}
+
 @; ----------------------------------------------------------------------
 
 @section[#:tag "require-trans"]{@racket[require] Transformers}

collects/syntax/context.rkt

@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
 
 (provide build-expand-context
          generate-expand-context)
@@ -9,6 +9,10 @@
         (cons v c)
         (list v))))
 
-(define (generate-expand-context)
+(struct in-liberal-define-context ()
-  (build-expand-context (gensym 'internal-define)))
+  #:property prop:liberal-define-context #t)
 
+(define (generate-expand-context [liberal-definitions? #f])
+  (build-expand-context (if liberal-definitions?
+                            (in-liberal-define-context)
+                            (gensym 'internal-define))))

src/racket/src/compile.c

@@ -5369,7 +5369,8 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
   d[0] = env;
   SCHEME_PTR1_VAL(ctx) = d;
   SCHEME_PTR2_VAL(ctx) = rib;
-  ectx = scheme_make_pair(ctx, scheme_null);
+  ectx = scheme_make_pair(scheme_make_struct_instance(scheme_liberal_def_ctx_type, 0, NULL), 
+                          scheme_null);
   scheme_begin_dup_symbol_check(&r, env);
 
  try_again:

src/racket/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1027
+#define EXPECTED_PRIM_COUNT 1029
 #define EXPECTED_UNSAFE_COUNT 78
 #define EXPECTED_FLFXNUM_COUNT 68
 #define EXPECTED_FUTURES_COUNT 11

src/racket/src/schpriv.h

@@ -388,6 +388,8 @@ extern Scheme_Object *scheme_raise_arity_error_proc;
 extern Scheme_Object *scheme_date;
 #endif
 
+extern Scheme_Object *scheme_liberal_def_ctx_type;
+
 extern Scheme_Object *scheme_module_stx;
 extern Scheme_Object *scheme_begin_stx;
 extern Scheme_Object *scheme_module_begin_stx;

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.1.2.3"
+#define MZSCHEME_VERSION "5.1.2.4"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 1
 #define MZSCHEME_VERSION_Z 2
-#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)

src/racket/src/struct.c

@@ -40,6 +40,7 @@ READ_ONLY Scheme_Object *scheme_recur_symbol;
 READ_ONLY Scheme_Object *scheme_display_symbol;
 READ_ONLY Scheme_Object *scheme_write_special_symbol;
 READ_ONLY Scheme_Object *scheme_app_mark_impersonator_property;
+READ_ONLY Scheme_Object *scheme_liberal_def_ctx_type;;
 
 READ_ONLY static Scheme_Object *location_struct;
 READ_ONLY static Scheme_Object *write_property;
@@ -99,6 +100,8 @@ static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Schem
 static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_checked_proc_property_value_ok(int argc, Scheme_Object *argv[]);
 
+static Scheme_Object *unary_acc(int argc, Scheme_Object **argv, Scheme_Object *self);
+
 static Scheme_Object *make_struct_type(int argc, Scheme_Object *argv[]);
 
 static Scheme_Object *make_struct_field_accessor(int argc, Scheme_Object *argv[]);
@@ -171,6 +174,8 @@ static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[]);
 
 static Scheme_Object *make_chaperone_property_from_c(Scheme_Object *name);
 
+static Scheme_Object *is_liberal_def_ctx(int argc, Scheme_Object **argv, Scheme_Object *self);
+
 #define PRE_REDIRECTS 2
 
 #ifdef MZ_PRECISE_GC
@@ -294,7 +299,13 @@ scheme_init_struct (Scheme_Env *env)
                                                       scheme_struct_property_type);
     scheme_add_global_constant("prop:custom-write", write_property, env);
     scheme_add_global_constant("custom-write?", pred, env);
-    scheme_add_global_constant("custom-write-accessor", access, env);
+
+    a[0] = access;
+    scheme_add_global_constant("custom-write-accessor", 
+                               scheme_make_prim_closure_w_arity(unary_acc, 1, a, 
+                                                                "custom-write-accessor",
+                                                                1, 1),
+                               env);
   }
 
   REGISTER_SO(print_attribute_property);
@@ -310,7 +321,13 @@ scheme_init_struct (Scheme_Env *env)
                                                                 scheme_struct_property_type);
     scheme_add_global_constant("prop:custom-print-quotable", print_attribute_property, env);
     scheme_add_global_constant("custom-print-quotable?", pred, env);
-    scheme_add_global_constant("custom-print-quotable-accessor", access, env);
+
+    a[0] = access;
+    scheme_add_global_constant("custom-print-quotable-accessor", 
+                               scheme_make_prim_closure_w_arity(unary_acc, 1, a, 
+                                                                "custom-print-quotable-accessor",
+                                                                1, 1),
+                               env);
   }
   
   REGISTER_SO(evt_property);
@@ -419,6 +436,27 @@ scheme_init_struct (Scheme_Env *env)
     scheme_add_global_constant("prop:checked-procedure", scheme_checked_proc_property, env);
   }
 
+  REGISTER_SO(scheme_liberal_def_ctx_type);
+  {
+    Scheme_Object *a[1], *prop, *pred, *access;
+    
+    a[0] = scheme_intern_symbol("liberal-define-context");
+    prop = make_struct_type_property_from_c(1, a, &pred, &access,
+                                            scheme_struct_property_type);
+    scheme_add_global_constant("prop:liberal-define-context", prop, env);
+
+    a[0] = prop;
+    scheme_add_global_constant("liberal-define-context?", 
+                               scheme_make_prim_closure_w_arity(is_liberal_def_ctx, 1, a, 
+                                                                "liberal-define-context?",
+                                                                1, 1),
+                               env);
+
+    scheme_liberal_def_ctx_type = scheme_make_struct_type_from_string("liberal-define-context", NULL, 0, 
+                                                                      cons(cons(prop, scheme_true), scheme_null),
+                                                                      NULL, 1);
+  }
+
   REGISTER_SO(not_free_id_symbol);
   not_free_id_symbol = scheme_intern_symbol("not-free-identifier=?");
 
@@ -1107,7 +1145,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
   memcpy(name, SCHEME_SYM_VAL(argv[0]), len);
   memcpy(name + len, "-accessor", 10);
 
-  v = scheme_make_folding_prim_closure(prop_accessor, 1, a, name, 1, 2, 0);
+  v = scheme_make_prim_closure_w_arity(prop_accessor, 1, a, name, 1, 2);
   ((Scheme_Closed_Primitive_Proc *)v)->pp.flags |= (SCHEME_PRIM_IS_STRUCT_OTHER
                                                     | SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER);
   
@@ -1602,6 +1640,13 @@ Scheme_Object *scheme_print_attribute_ref(Scheme_Object *s)
   return scheme_struct_type_property_ref(print_attribute_property, s);
 }
 
+static Scheme_Object *unary_acc(int argc, Scheme_Object **argv, Scheme_Object *self)
+{
+  Scheme_Object *acc = SCHEME_PRIM_CLOSURE_ELS(self)[0];
+
+  return _scheme_apply(acc, argc, argv);
+}
+
 /*========================================================================*/
 /*                  rename and set! transformer properties                */
 /*========================================================================*/
@@ -1788,6 +1833,22 @@ Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv)
   return _scheme_apply(argv[2], 3, a);
 }
 
+/*========================================================================*/
+/*                             liberal-define                             */
+/*========================================================================*/
+
+static Scheme_Object *is_liberal_def_ctx(int argc, Scheme_Object **argv, Scheme_Object *self)
+{
+  Scheme_Object *prop = SCHEME_PRIM_CLOSURE_ELS(self)[0], *val;
+  
+  val = scheme_struct_type_property_ref(prop, argv[0]);
+
+  if (!val || SCHEME_FALSEP(val))
+    return scheme_false;
+  else
+    return scheme_true;
+}
+
 /*========================================================================*/
 /*                             struct ops                                 */
 /*========================================================================*/