301.12

svn: r2556

src/mred/mred.cxx

@@ -3581,7 +3581,7 @@ static void pre_het(void *d)
   HiEventTramp *het = (HiEventTramp *)d;
 
   het->old_param = scheme_get_param(het->config, mred_het_param);
-  scheme_set_param(het->config, mred_het_param, scheme_make_pair((Scheme_Object *)het, scheme_null));
+  scheme_set_param(het->config, mred_het_param, scheme_make_raw_pair((Scheme_Object *)het, scheme_null));
 }
 
 static Scheme_Object *act_het(void *d)
@@ -3739,7 +3739,7 @@ int mred_het_run_some(HiEventTrampProc do_f, void *do_data)
   {
     Scheme_Object *v;
     v = scheme_get_param(scheme_current_thread->init_config, mred_het_param);
-    if (SCHEME_PAIRP(v))
+    if (SCHEME_RPAIRP(v))
       het = (HiEventTramp *)SCHEME_CAR(v);
     else
       het = NULL;

src/mzscheme/gc2/compact.c

@@ -4424,6 +4424,97 @@ int GC_is_tagged(void *p)
   return page && (page->type == MTYPE_TAGGED);
 }
 
+static void *next_tagged_start(void *p, int stop_at_p)
+{
+  MPage *page;
+  void **p2, **top;
+  int prev_was_p = 0;
+
+  page = find_page(p);
+  if (page && (page->type == MTYPE_TAGGED)) {
+    p2 = (void **)page->block_start;
+
+    if (page->flags & MFLAG_CONTINUED)
+      return NULL;
+    if (page->flags & MFLAG_BIGBLOCK) {
+      if (p == (void *)p2) {
+	if (stop_at_p)
+	  return p;
+      }
+      return NULL;
+    }
+
+    top = p2 + MPAGE_WORDS;
+    
+    while (p2 < top) {
+      Type_Tag tag;
+      long size;
+
+      if (stop_at_p) {
+	if ((void *)p2 == p)
+	  return p;
+	if ((unsigned long)p2 > (unsigned long)p)
+	  break;
+      }
+      
+      tag = *(Type_Tag *)p2;
+
+      if (tag == TAGGED_EOM)
+	break;
+
+#if ALIGN_DOUBLES
+      if (tag == SKIP) {
+	p2++;
+      } else {
+#endif
+	if (prev_was_p)
+	  return (void *)p2;
+
+	{
+	  Size_Proc size_proc;
+	
+	  size_proc = size_table[tag];
+	  if (((long)size_proc) < 100)
+	    size = (long)size_proc;
+	  else
+	    size = size_proc(p2);
+	}
+
+	prev_was_p = (p == p2);
+      
+	p2 += size;
+#if ALIGN_DOUBLES
+      }
+#endif
+    }
+  }
+  
+  return NULL;
+}
+
+int GC_is_tagged_start(void *p)
+{
+  if (next_tagged_start(p, 1))
+    return 1;
+  else
+    return 0;
+}
+
+void *GC_next_tagged_start(void *p)
+{
+  void *p2;
+
+  while (1) {
+    p2 = next_tagged_start(p, 0);
+    if (p2)
+      return p2;
+
+    p = (void *)(((long)p & MPAGE_START) + MPAGE_SIZE);
+    if (!p)
+      return NULL;
+  }
+}
+
 void *print_out_pointer(const char *prefix, void *p)
 {
   MPage *page;

src/mzscheme/include/mzscheme.exp

@@ -98,6 +98,7 @@ scheme_tail_call_waiting
 scheme_multiple_values
 scheme_uchar_table
 scheme_uchar_cases_table
+scheme_uchar_cats_table
 scheme_uchar_ups
 scheme_uchar_downs
 scheme_uchar_titles
@@ -196,6 +197,7 @@ scheme_make_closed_prim_w_everything
 scheme_prim_is_method
 scheme_make_pair
 scheme_make_immutable_pair
+scheme_make_raw_pair
 scheme_make_byte_string
 scheme_make_sized_byte_string
 scheme_make_sized_offset_byte_string

src/mzscheme/include/mzscheme3m.exp

@@ -98,6 +98,7 @@ scheme_tail_call_waiting
 scheme_multiple_values
 scheme_uchar_table
 scheme_uchar_cases_table
+scheme_uchar_cats_table
 scheme_uchar_ups
 scheme_uchar_downs
 scheme_uchar_titles
@@ -203,6 +204,7 @@ scheme_make_closed_prim_w_everything
 scheme_prim_is_method
 scheme_make_pair
 scheme_make_immutable_pair
+scheme_make_raw_pair
 scheme_make_byte_string
 scheme_make_sized_byte_string
 scheme_make_sized_offset_byte_string

src/mzscheme/include/mzwin.def

@@ -100,6 +100,7 @@ EXPORTS
  scheme_multiple_values
  scheme_uchar_table
  scheme_uchar_cases_table
+ scheme_uchar_cats_table
  scheme_uchar_ups
  scheme_uchar_downs
  scheme_uchar_titles
@@ -188,6 +189,7 @@ EXPORTS
  scheme_prim_is_method
  scheme_make_pair
  scheme_make_immutable_pair
+ scheme_make_raw_pair
  scheme_make_byte_string
  scheme_make_sized_byte_string
  scheme_make_sized_offset_byte_string

src/mzscheme/include/scheme.h

@@ -402,6 +402,8 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
 #define SCHEME_IMMUTABLE_PAIRP(obj)    (SCHEME_PAIRP(obj) && SCHEME_IMMUTABLEP(obj))
 #define SCHEME_LISTP(obj)    (SCHEME_NULLP(obj) || SCHEME_PAIRP(obj))
 
+#define SCHEME_RPAIRP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_raw_pair_type)
+
 #define SCHEME_BOXP(obj)     SAME_TYPE(SCHEME_TYPE(obj), scheme_box_type)
 #define SCHEME_MUTABLE_BOXP(obj)  (SCHEME_BOXP(obj) && SCHEME_MUTABLEP(obj))
 #define SCHEME_IMMUTABLE_BOXP(obj)  (SCHEME_BOXP(obj) && SCHEME_IMMUTABLEP(obj))
@@ -538,7 +540,7 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
 #define scheme_ispunc(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x4)
 #define scheme_iscontrol(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x8)
 #define scheme_isspace(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x10)
-#define scheme_isxdigit(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x20)
+/* #define scheme_isSOMETHING(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x20) - not yet used */
 #define scheme_isdigit(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x40)
 #define scheme_isalpha(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x80)
 #define scheme_istitle(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x100)
@@ -558,6 +560,9 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
 #define scheme_tofold(x) (x + scheme_uchar_folds[scheme_uchar_find(scheme_uchar_cases_table, x)])
 #define scheme_combining_class(x) (scheme_uchar_combining_classes[scheme_uchar_find(scheme_uchar_cases_table, x)])
 
+#define scheme_general_category(x) ((scheme_uchar_find(scheme_uchar_cats_table, x)) & 0x1F)
+/* Note: 3 bits available in the cats table */
+
 /*========================================================================*/
 /*                          procedure values                              */
 /*========================================================================*/

src/mzscheme/src/char.c

@@ -58,9 +58,12 @@ static Scheme_Object *char_upcase (int argc, Scheme_Object *argv[]);
 static Scheme_Object *char_downcase (int argc, Scheme_Object *argv[]);
 static Scheme_Object *char_titlecase (int argc, Scheme_Object *argv[]);
 static Scheme_Object *char_foldcase (int argc, Scheme_Object *argv[]);
+static Scheme_Object *char_general_category (int argc, Scheme_Object *argv[]);
 static Scheme_Object *char_utf8_length (int argc, Scheme_Object *argv[]);
 static Scheme_Object *char_map_list (int argc, Scheme_Object *argv[]);
 
+static Scheme_Object *general_category_symbols[NUM_GENERAL_CATEGORIES];
+
 void scheme_init_portable_case(void)
 {
   init_uchar_table();
@@ -72,6 +75,7 @@ void scheme_init_char (Scheme_Env *env)
   int i;
 
   REGISTER_SO(scheme_char_constants);
+  REGISTER_SO(general_category_symbols);
 
   scheme_char_constants = 
     (Scheme_Object **)scheme_malloc_eternal(256 * sizeof(Scheme_Object*));
@@ -229,6 +233,11 @@ void scheme_init_char (Scheme_Env *env)
 						      "char-foldcase", 
 						      1, 1, 1),
 			     env);
+  scheme_add_global_constant("char-general-category", 
+			     scheme_make_folding_prim(char_general_category, 
+						      "char-general-category", 
+						      1, 1, 1),
+			     env);
 
   scheme_add_global_constant("char-utf-8-length", 
 			     scheme_make_folding_prim(char_utf8_length, 
@@ -386,6 +395,25 @@ GEN_RECASE(char_downcase, "char-downcase", scheme_tolower)
 GEN_RECASE(char_titlecase, "char-titlecase", scheme_totitle)
 GEN_RECASE(char_foldcase, "char-foldcase", scheme_tofold)
 
+static Scheme_Object *char_general_category (int argc, Scheme_Object *argv[])
+{
+  mzchar c;
+  int cat;
+
+  if (!SCHEME_CHARP(argv[0]))
+    scheme_wrong_type("char-general-category", "character", 0, argc, argv);
+
+  c = SCHEME_CHAR_VAL(argv[0]);
+  cat = scheme_general_category(c);
+  if (!general_category_symbols[cat]) {
+    Scheme_Object *s;
+    s = scheme_make_symbol(general_category_names[cat]);
+    general_category_symbols[cat] = s;
+  }
+
+  return general_category_symbols[cat];
+}
+
 static Scheme_Object *char_utf8_length (int argc, Scheme_Object *argv[])
 {
   mzchar wc;

src/mzscheme/src/env.c

@@ -987,7 +987,8 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo)
 				  n, n,
 				  env->module->self_modidx,
 				  n,
-				  env->mod_phase);
+				  env->mod_phase,
+				  0);
     }
   }
 
@@ -1579,7 +1580,7 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid
 Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def)
 /* The `env' argument can actually be a hash table. */
 {
-  Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match;
+  Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm;
   int best_match_skipped, ms;
   Scheme_Hash_Table *marked_names;
 
@@ -1627,6 +1628,12 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def)
 
   best_match = NULL;
   best_match_skipped = scheme_list_length(marks);
+  if (best_match_skipped == 1) {
+    /* A mark list of length 1 is the common case.
+       Since the list is otherwise marshaled into .zo, etc.,
+       simplify by extracting just the mark: */
+    marks = SCHEME_CAR(marks);
+  }
 
   /* Find a mapping that matches the longest tail of marks */
   for (l = map; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
@@ -1638,12 +1645,28 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def)
 	break;
       }
     } else {
+      if (!SCHEME_PAIRP(marks)) {
+	/* To be better than nothing, could only match exactly: */
+	if (SAME_OBJ(amarks, marks)) {
+	  best_match = SCHEME_CDR(a);
+	  best_match_skipped = 0;
+	}
+      } else {
+	/* amarks can match a tail of marks: */
 	for (m = marks, ms = 0; 
 	     SCHEME_PAIRP(m) && (ms < best_match_skipped);
 	     m = SCHEME_CDR(m), ms++) {
 
-	if (scheme_equal(amarks, m)) {
+	  cm = m;
-	  if (ms < best_match_skipped) {
+	  if (!SCHEME_PAIRP(amarks)) {
+	    /* If we're down to the last element
+	       of marks, then extract it to try to
+	       match the symbol amarks. */
+	    if (SCHEME_NULLP(SCHEME_CDR(m)))
+	      cm = SCHEME_CAR(m);
+	  }
+  
+	  if (scheme_equal(amarks, cm)) {
 	    best_match = SCHEME_CDR(a);
 	    best_match_skipped = ms;
 	    break;

src/mzscheme/src/error.c

@@ -1214,7 +1214,12 @@ void scheme_arg_mismatch(const char *name, const char *msg, Scheme_Object *o)
   char *s;
   int slen;
 
+  if (o)
     s = scheme_make_provided_string(o, 1, &slen);
+  else {
+    s = "";
+    slen = 0;
+  }
 
   scheme_raise_exn(MZEXN_FAIL_CONTRACT,
 		   "%s: %s%t",

src/mzscheme/src/eval.c

@@ -201,6 +201,8 @@ static Scheme_Object *write_with_cont_mark(Scheme_Object *obj);
 static Scheme_Object *read_with_cont_mark(Scheme_Object *obj);
 static Scheme_Object *write_syntax(Scheme_Object *obj);
 static Scheme_Object *read_syntax(Scheme_Object *obj);
+static Scheme_Object *write_quote_syntax(Scheme_Object *obj);
+static Scheme_Object *read_quote_syntax(Scheme_Object *obj);
 
 static Scheme_Object *define_values_symbol, *letrec_values_symbol, *lambda_symbol;
 static Scheme_Object *unknown_symbol, *void_link_symbol, *quote_symbol;
@@ -329,6 +331,8 @@ scheme_init_eval (Scheme_Env *env)
   scheme_install_type_reader(scheme_branch_type, read_branch);
   scheme_install_type_writer(scheme_with_cont_mark_type, write_with_cont_mark);
   scheme_install_type_reader(scheme_with_cont_mark_type, read_with_cont_mark);
+  scheme_install_type_writer(scheme_quote_syntax_type, write_quote_syntax);
+  scheme_install_type_reader(scheme_quote_syntax_type, read_quote_syntax);
   scheme_install_type_writer(scheme_syntax_type, write_syntax);
   scheme_install_type_reader(scheme_syntax_type, read_syntax);
   
@@ -1447,18 +1451,20 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info)
     return scheme_resolve_toplevel(info, expr);
   case scheme_compiled_quote_syntax_type:
     {
-      Scheme_Object *obj;
+      Scheme_Quote_Syntax *qs;
       int i, c, p;
 
       i = SCHEME_LOCAL_POS(expr);
       c = scheme_resolve_toplevel_pos(info);
       p = scheme_resolve_quote_syntax_pos(info);
 
-      obj = scheme_make_pair(scheme_make_integer(i),
+      qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax);
-			     scheme_make_pair(scheme_make_integer(c),
+      qs->so.type = scheme_quote_syntax_type;
-					      scheme_make_integer(p)));
+      qs->depth = c;
+      qs->position = i;
+      qs->midpoint = p;
 
-      return scheme_make_syntax_resolved(QUOTE_SYNTAX_EXPD, obj);
+      return (Scheme_Object *)qs;
     }
   case scheme_variable_type:
   case scheme_module_variable_type:
@@ -5289,7 +5295,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
 
     if (SCHEME_INTP(obj)) {
       v = obj;
-      goto returnv;
+      goto returnv_never_multi;
     }
 
     type = _SCHEME_TYPE(obj);
@@ -5309,17 +5315,17 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
 	  prefix tmp
 
 	  global_lookup(v = , obj, v);  
-	  goto returnv;
+	  goto returnv_never_multi;
 	}
       case scheme_local_type:
 	{
 	  v = RUNSTACK[SCHEME_LOCAL_POS(obj)];
-	  goto returnv;
+	  goto returnv_never_multi;
 	}
       case scheme_local_unbox_type:
 	{
 	  v = SCHEME_ENVBOX_VAL(RUNSTACK[SCHEME_LOCAL_POS(obj)]);
-	  goto returnv;
+	  goto returnv_never_multi;
 	}
       case scheme_syntax_type:
 	{
@@ -5596,7 +5602,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
       case scheme_unclosed_procedure_type:
 	UPDATE_THREAD_RSPTR();
 	v = scheme_make_closure(p, obj, 1);
-	goto returnv;
+	goto returnv_never_multi;
 
       case scheme_let_value_type:
 	{
@@ -5801,9 +5807,31 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
 	  goto eval_top;
 	}
 
+      case scheme_quote_syntax_type:
+	{
+	  GC_CAN_IGNORE Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj;
+	  Scheme_Object **globs;
+	  int i, c, p;
+
+	  i = qs->position;
+	  c = qs->depth;
+	  p = qs->midpoint;
+
+	  globs = (Scheme_Object **)RUNSTACK[c];
+	  v = globs[i+p+1];
+	  if (!v) {
+	    v = globs[p];
+	    v = scheme_add_rename(((Scheme_Object **)SCHEME_CDR(v))[i], 
+				  SCHEME_CAR(v));
+	    globs[i+p+1] = v;
+	  }
+
+	  goto returnv_never_multi;
+	}
+      
       default:
 	v = obj;
-	goto returnv;
+	goto returnv_never_multi;
       }
   }
 
@@ -5834,6 +5862,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
       return NULL;
     }
 
+ returnv_never_multi:
+
   MZ_RUNSTACK = old_runstack;
   MZ_CONT_MARK_STACK = old_cont_mark_stack;
   MZ_CONT_MARK_POS -= 2;
@@ -6725,10 +6755,9 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
       v = scheme_stx_phase_shift_as_rename(now_phase - src_phase, src_modidx, now_modidx);
       if (v) {
 	/* Put lazy-shift info in a[i]: */
-	v = scheme_make_pair(v, (Scheme_Object *)rp->stxes);
+	v = scheme_make_raw_pair(v, (Scheme_Object *)rp->stxes);
 	a[i] = v;
-	/* Rest of a left zeroed, to be filled in lazily by
+	/* Rest of a left zeroed, to be filled in lazily by quote-syntax evaluation */
-	   QUOTE_SYNTAX_EXPD handler */
       } else {
 	/* No shift, so fill in stxes immediately */
 	i++;
@@ -6914,6 +6943,21 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, char *stack,
       goto top;
     }
     break;
+  case scheme_quote_syntax_type:
+    {
+      Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)expr;
+      int c = qs->depth;
+      int i = qs->position;
+      int p = qs->midpoint;
+      int d = c + delta;
+
+      if ((c < 0) || (p < 0) || (d >= depth)
+	  || (stack[d] != VALID_TOPLEVELS) 
+	  || (p != num_toplevels)
+	  || (i >= num_stxes))
+	scheme_ill_formed_code(port);
+    }
+    break;
   case scheme_unclosed_procedure_type:
     {
       Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr;
@@ -7075,19 +7119,6 @@ void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
   scheme_validate_expr(port, expr, stack, depth, delta, delta, num_toplevels, num_stxes);
 }
 
-void scheme_validate_quote_syntax(int c, int p, int i, Mz_CPort *port,
-				  char *stack, int depth, int delta, 
-				  int num_toplevels, int num_stxes)
-{
-  int d = c + delta;
-
-  if ((c < 0) || (p < 0) || (d >= depth)
-      || (stack[d] != VALID_TOPLEVELS) 
-      || (p != num_toplevels)
-      || (i >= num_stxes))
-    scheme_ill_formed_code(port);
-}
-
 void scheme_validate_boxenv(int p, Mz_CPort *port, char *stack, int depth, int delta)
 {
   p += delta;
@@ -7258,6 +7289,44 @@ static Scheme_Object *read_syntax(Scheme_Object *obj)
   return scheme_make_syntax_resolved(SCHEME_INT_VAL(idx), first);
 }
 
+static Scheme_Object *write_quote_syntax(Scheme_Object *obj)
+{
+  Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj;
+
+  return cons(scheme_make_integer(qs->depth),
+	      cons(scheme_make_integer(qs->position),
+		   scheme_make_integer(qs->midpoint)));
+}
+
+static Scheme_Object *read_quote_syntax(Scheme_Object *obj)
+{
+  Scheme_Quote_Syntax *qs;
+  Scheme_Object *a;
+  int c, i, p;
+  
+  if (!SCHEME_PAIRP(obj)) return NULL;
+
+  a = SCHEME_CAR(obj);
+  c = SCHEME_INT_VAL(a);
+
+  obj = SCHEME_CDR(obj);
+  if (!SCHEME_PAIRP(obj)) return NULL;
+  
+  a = SCHEME_CAR(obj);
+  i = SCHEME_INT_VAL(a);
+
+  a = SCHEME_CDR(obj);
+  p = SCHEME_INT_VAL(a);
+
+  qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax);
+  qs->so.type = scheme_quote_syntax_type;
+  qs->depth = c;
+  qs->position = i;
+  qs->midpoint = p;  
+
+  return (Scheme_Object *)qs;
+}
+
 /*========================================================================*/
 /*                         precise GC traversers                          */
 /*========================================================================*/

src/mzscheme/src/fun.c

@@ -3589,7 +3589,7 @@ internal_call_cc (int argc, Scheme_Object *argv[])
     /* For copying cont marks back in, we need a list of sub_conts,
        deepest to shallowest: */
     for (sub_cont = cont->buf.cont; sub_cont; sub_cont = sub_cont->buf.cont) {
-      sub_conts = scheme_make_pair((Scheme_Object *)sub_cont, sub_conts);
+      sub_conts = scheme_make_raw_pair((Scheme_Object *)sub_cont, sub_conts);
     }
     
     /* For dynamic-winds after the "common" intersection

src/mzscheme/src/jit.c

@@ -56,8 +56,6 @@ static void *shared_non_tail_code[3][MAX_SHARED_CALL_RANDS][2];
 #define MAX_SHARED_ARITY_CHECK 25
 static void *shared_arity_check[MAX_SHARED_ARITY_CHECK][2][2];
 
-static void *jump_to_native_code;
-static void *jump_to_native_arity_code;
 static void *bad_result_arity_code;
 static void *unbound_global_code;
 static void *quote_syntax_code;
@@ -753,16 +751,15 @@ static void _jit_prolog_again(mz_jit_state *jitter, int n, int ret_addr_reg)
 # define __END_SHORT_JUMPS__(cond) /* empty */
 #endif
 
-/* Note: Things like
+/* In
-
+      jit_jmpi(code);
-      refm = jit_jmpi(jit_forward());
+   or
-      jit_patch_at(refm, jump_to_native_code);
+      jit_blti_i(code, v);
-
+   with short jumps enabled, the generated instructions can depend on
-   appear in the code because the generated instructions can depend on
+   the relative location between the instruction address and the
-   the actual value supplied to jit_jmpi, and it can depend on the
+   actual value. Do not enable short jumps if the relative offset can
-   relative location between the instruction address and the actual
+   change between the initial sizing pass and the final pass. Of course,
-   value.  Using jit_patch ensures that the generated instructions
+   also don't enable short umps if the jump is potentially too long. */
-   always have the same size. */
 
 /*========================================================================*/
 /*                         bytecode properties                            */
@@ -783,8 +780,7 @@ static int is_short(Scheme_Object *obj, int fuel)
     {
       int t;
       t = SCHEME_PINT_VAL(obj); 
-      if ((t == CASE_LAMBDA_EXPD)
+      if (t == CASE_LAMBDA_EXPD)
-	  || (t == QUOTE_SYNTAX_EXPD))
 	return fuel - 1;
       else
 	return 0;
@@ -837,6 +833,7 @@ static int is_short(Scheme_Object *obj, int fuel)
       return is_short(branch->fbranch, fuel);
     }
   case scheme_toplevel_type:
+  case scheme_quote_syntax_type:
   case scheme_local_type:
   case scheme_local_unbox_type:
   case scheme_unclosed_procedure_type:
@@ -922,8 +919,7 @@ static int is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_st
     {
       int t;
       t = SCHEME_PINT_VAL(obj); 
-      return ((t == CASE_LAMBDA_EXPD)
+      return (t == CASE_LAMBDA_EXPD);
-	      || (t == QUOTE_SYNTAX_EXPD));
     }
     break;
 
@@ -977,6 +973,7 @@ static int is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_st
     break;
     
   case scheme_toplevel_type:
+  case scheme_quote_syntax_type:
   case scheme_local_type:
   case scheme_local_unbox_type:
   case scheme_unclosed_procedure_type:
@@ -1190,19 +1187,7 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc
   jit_str_i(JIT_R1, JIT_R2);
 #endif
   
-  /* Fast inlined-native jump ok (proc will check argc); */
+  /* Fast inlined-native jump ok (proc will check argc, if necessary) */
-#if 0
-  mz_prepare(3);
-  jit_pusharg_p(JIT_RUNSTACK);
-  jit_movi_i(JIT_R1, num_rands);
-  jit_pusharg_i(JIT_R1);
-  jit_pusharg_p(JIT_V1);
-  if (direct_native) {
-    (void)mz_finish(jump_to_native_code);
-  } else {
-    (void)mz_finish(jump_to_native_arity_code);
-  }
-#else
   {
     jit_insn *refr;
     refr = jit_movi_p(JIT_R0, jit_forward());
@@ -1223,7 +1208,6 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc
     jit_jmpr(JIT_V1);
     jit_patch_movi(refr, (_jit.x.pc));
   }
-#endif
   CHECK_LIMIT();
   jit_retval(JIT_R0);
   if (!multi_ok) {
@@ -3078,26 +3062,6 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 	  END_JIT_DATA(9);
 	}
 	break;
-      case QUOTE_SYNTAX_EXPD:
-	{
-	    int i, c, p;
-	    START_JIT_DATA();
-
-	    LOG_IT(("quote-syntax\n"));
-
-	    obj = SCHEME_IPTR_VAL(obj);
-	    i = SCHEME_INT_VAL(SCHEME_CAR(obj));
-	    c = mz_remap(SCHEME_INT_VAL(SCHEME_CADR(obj)));
-	    p = SCHEME_INT_VAL(SCHEME_CDDR(obj));
-	    
-	    jit_movi_i(JIT_R0, WORDS_TO_BYTES(c));
-	    jit_movi_i(JIT_R1, WORDS_TO_BYTES(i + p + 1));
-	    jit_movi_i(JIT_R2, WORDS_TO_BYTES(p));
-	    (void)jit_calli(quote_syntax_code);
-
-	    END_JIT_DATA(10);
-	}
-	break;
       default:
 	{
 	  JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
@@ -3516,6 +3480,27 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 	
       return generate(wcm->body, jitter, is_tail, multi_ok);
     }
+  case scheme_quote_syntax_type:
+    {
+      Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj;
+      int i, c, p;
+      START_JIT_DATA();
+      
+      LOG_IT(("quote-syntax\n"));
+      
+      i = qs->position;
+      c = mz_remap(qs->depth);
+      p = qs->midpoint;
+	    
+      jit_movi_i(JIT_R0, WORDS_TO_BYTES(c));
+      jit_movi_i(JIT_R1, WORDS_TO_BYTES(i + p + 1));
+      jit_movi_i(JIT_R2, WORDS_TO_BYTES(p));
+      (void)jit_calli(quote_syntax_code);
+      
+      END_JIT_DATA(10);
+
+      return 1;
+    }
   default:
     {
       int retptr;
@@ -3642,37 +3627,6 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
   int in, i;
   GC_CAN_IGNORE jit_insn *ref, *ref2;
 
-  /* *** jump_to_native_[arity_]code *** */
-  /* Called as a function: */
-  for (i = 0; i < 2; i++) {
-    if (!i)
-      jump_to_native_code = jit_get_ip().ptr;
-    else
-      jump_to_native_arity_code = jit_get_ip().ptr;
-    jit_prolog(3);
-    in = jit_arg_p();
-    jit_getarg_p(JIT_R0, in); /* closure */
-    in = jit_arg_p();
-    jit_getarg_i(JIT_R1, in); /* argc */
-    in = jit_arg_p();
-    jit_getarg_i(JIT_R2, in); /* argv */
-    CHECK_LIMIT();
-    jit_movr_p(JIT_RUNSTACK, JIT_R2);
-    jit_movr_p(JIT_RUNSTACK_BASE, JIT_R1);
-    jit_lshi_ul(JIT_RUNSTACK_BASE, JIT_RUNSTACK_BASE, JIT_LOG_WORD_SIZE);
-    jit_addr_p(JIT_RUNSTACK_BASE, JIT_RUNSTACK_BASE, JIT_RUNSTACK);
-    mz_push_locals();
-    mz_set_local_p(JIT_RUNSTACK, JIT_LOCAL1);
-    jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Native_Closure *)0x0)->code);
-    if (!i) {
-      jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Native_Closure_Data *)0x0)->u.tail_code);
-    } else {
-      jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Native_Closure_Data *)0x0)->arity_code);
-    }
-    jit_jmpr(JIT_V1);
-    CHECK_LIMIT();
-  }
-
   /* *** check_arity_code *** */
   /* Called as a function: */
   check_arity_code = (Native_Check_Arity_Proc)jit_get_ip().ptr;
@@ -4541,7 +4495,7 @@ Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *data, in
 {
   Scheme_Native_Closure_Data *ndata;
 
-  if (!jump_to_native_code) {
+  if (!check_arity_code) {
     /* Create shared code used for stack-overflow handling, etc.: */
     generate_one(NULL, do_generate_common, NULL, 0, NULL, NULL);
   }

src/mzscheme/src/list.c

@@ -532,6 +532,15 @@ Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr)
 {
   Scheme_Object *cons;
 
+#if 0
+  if (!car || !cdr
+      || (SCHEME_TYPE(car) < 0)
+      || (SCHEME_TYPE(cdr) < 0)
+      || (SCHEME_TYPE(car) >= (_scheme_last_type_ + 10)) /* +10 leaves room of external types */
+      || (SCHEME_TYPE(cdr) >= (_scheme_last_type_ + 10)))
+    *(long *)0x0 = 1;
+#endif
+
   cons = scheme_alloc_object();
   cons->type = scheme_pair_type;
   SCHEME_CAR(cons) = car;
@@ -539,6 +548,21 @@ Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr)
   return cons;
 }
 
+Scheme_Object *scheme_make_raw_pair(Scheme_Object *car, Scheme_Object *cdr)
+{
+  Scheme_Object *cons;
+
+  /* A raw pair is like a pair, but some of our low-level debugging
+     tools expect pairs to always contain tagged values. A raw pair
+     contains arbitrary pointers. */
+
+  cons = scheme_alloc_object();
+  cons->type = scheme_raw_pair_type;
+  SCHEME_CAR(cons) = car;
+  SCHEME_CDR(cons) = cdr;
+  return cons;
+}
+
 Scheme_Object *scheme_make_immutable_pair(Scheme_Object *car, Scheme_Object *cdr)
 {
   Scheme_Object *cons;

src/mzscheme/src/mk-uchar.ss

@@ -7,8 +7,8 @@
 
 ;; Run as
 ;;   mzscheme -r mk-uchar.ss
-;; in the script's directory, and have a copy of UnicodeData.txt
+;; in the script's directory, and have a copy of UnicodeData.txt, etc.
-;; in the same directory. The file schuchar.inc will be
+;; in the "Unicode" directory. The file schuchar.inc will be
 ;; overwritten.
 
 (require (lib "list.ss"))
@@ -20,6 +20,7 @@
 (define space-cats '("Zl" "Zs" "Zp"))
 (define punc-cats '("Pc" "Pd" "Ps" "Pe" "Pi" "Pf" "Po"))
 (define sym-cats '("Sm" "Sc" "Sk" "So"))
+(define sympart-non-cats '("Ps" "Pe" "Pi" "Pf" "Zl" "Zs" "Zp"))
 (define graphic-cats (append mark-cats
 			     letter-cats
 			     digit-cats
@@ -52,6 +53,15 @@
 (define (combine-case up down title fold combining)
   (indirect cases (list up down title fold combining) 256))
 
+(define general-categories (make-hash-table 'equal))
+(hash-table-put! general-categories "Cn" 0)
+(define (combine-cat cat)
+  (hash-table-get general-categories cat
+		  (lambda ()
+		    (let ([v (hash-table-count general-categories)])
+		      (hash-table-put! general-categories cat v)
+		      v))))
+
 (define hexes (map char->integer (string->list "0123456789abcdefABCDEF")))
 
 (define combining-class-ht (make-hash-table))
@@ -69,22 +79,25 @@
 
 (define top (make-vector hi-count #f))
 (define top2 (make-vector hi-count #f))
+(define top3 (make-vector hi-count #f))
 
 (define range-bottom 0)
 (define range-top -1)
 (define range-v -1)
 (define range-v2 -1)
+(define range-v3 -1)
 (define ranges null)
 
 (define ccount 0)
 
-(define (map1 c v v2 cc)
+(define (map1 c v v2 v3 cc)
   (hash-table-put! combining-class-ht c cc)
   (set! ccount (add1 ccount))
   (if (= c (add1 range-top))
       (begin
 	(unless (and (= v range-v)
-		     (= v2 range-v2))
+		     (= v2 range-v2)
+		     (= v3 range-v3))
 	  (set! range-v -1))
 	(set! range-top c))
       (begin
@@ -104,25 +117,31 @@
 	(set! range-bottom c)
 	(set! range-top c)
 	(set! range-v v)
-	(set! range-v2 v2)))
+	(set! range-v2 v2)
+	(set! range-v3 v3)))
   (let ([top-index (arithmetic-shift c (- low-bits))])
     (let ([vec (vector-ref top top-index)]
-	  [vec2 (vector-ref top2 top-index)])
+	  [vec2 (vector-ref top2 top-index)]
+	  [vec3 (vector-ref top3 top-index)])
       (unless vec
 	(vector-set! top top-index (make-vector (add1 low))))
       (unless vec2
 	(vector-set! top2 top-index (make-vector (add1 low))))
+      (unless vec3
+	(vector-set! top3 top-index (make-vector (add1 low))))
       (let ([vec (vector-ref top top-index)]
-	    [vec2 (vector-ref top2 top-index)])
+	    [vec2 (vector-ref top2 top-index)]
+	    [vec3 (vector-ref top3 top-index)])
 	(vector-set! vec (bitwise-and c low) v)
-	(vector-set! vec2 (bitwise-and c low) v2)))))
+	(vector-set! vec2 (bitwise-and c low) v2)
+	(vector-set! vec3 (bitwise-and c low) v3)))))
 
-(define (mapn c from v v2 cc)
+(define (mapn c from v v2 v3 cc)
   (if (= c from)
-      (map1 c v v2 cc)
+      (map1 c v v2 v3 cc)
       (begin
-	(map1 from v v2 cc)
+	(map1 from v v2 v3 cc)
-	(mapn c (add1 from) v v2 cc))))
+	(mapn c (add1 from) v v2 v3 cc))))
 
 (define (set-compose-initial! c)
   (let ([top-index (arithmetic-shift c (- low-bits))])
@@ -131,7 +150,7 @@
       (vector-set! vec i (bitwise-ior #x8000 (vector-ref vec i))))))
 
 (define midletters
-  (call-with-input-file "WordBreakProperty.txt"
+  (call-with-input-file "Unicode/WordBreakProperty.txt"
     (lambda (i)
       (let loop ()
 	(let ([re (regexp-match #rx"\n([0-9A-F]+)  *; *MidLetter" i)])
@@ -150,7 +169,7 @@
 ;; This code assumes that Final_Sigma is the only condition that we care about:
 (define case-foldings (make-hash-table 'equal))
 (define special-case-foldings (make-hash-table 'equal))
-(call-with-input-file "CaseFolding.txt"
+(call-with-input-file "Unicode/CaseFolding.txt"
   (lambda (i)
     (let loop ()
       (let ([l (read-line i)])
@@ -168,7 +187,7 @@
 ;; This code assumes that Final_Sigma is the only condition that we care about:
 (define special-casings (make-hash-table 'equal))
 (define-struct special-casing (lower upper title folding final-sigma?))
-(call-with-input-file "SpecialCasing.txt"
+(call-with-input-file "Unicode/SpecialCasing.txt"
   (lambda (i)
     (let loop ()
       (let ([l (read-line i)])
@@ -188,7 +207,7 @@
 (define lower-case  (make-hash-table 'equal))
 (define upper-case  (make-hash-table 'equal))
 
-(with-input-from-file "DerivedCoreProperties.txt"
+(with-input-from-file "Unicode/DerivedCoreProperties.txt"
   (lambda ()
     (let loop ()
       (let ([l (read-line)])
@@ -213,7 +232,7 @@
 (define compose-map (make-hash-table 'equal))
 (define do-not-compose-ht (make-hash-table 'equal))
 
-(with-input-from-file "CompositionExclusions.txt"
+(with-input-from-file "Unicode/CompositionExclusions.txt"
   (lambda ()
     (let loop ()
       (let ([l (read-line)])
@@ -257,7 +276,7 @@
 	      (hash-table-put! k-decomp-ht code seq)
 	      #t)))))
 
-(call-with-input-file "UnicodeData.txt"
+(call-with-input-file "Unicode/UnicodeData.txt"
   (lambda (i)
     (let loop ([prev-code 0])
       (let ([l (read-line i)])
@@ -312,8 +331,8 @@
 		     (member cat letter-cats)
 		     ;; digit
 		     (member cat digit-cats)
-		     ;; hex digit
+		     ;; SOMETHING - this bit not yet used
-		     (member code hexes)
+		     #f
 		     ;; whitespace
 		     (or (member cat space-cats)
 			 (member code '(#x9 #xa #xb #xc #xd)))
@@ -335,6 +354,8 @@
 		     (let ([case-fold (hash-table-get case-foldings code (lambda () #f))])
 		       (if case-fold (- case-fold code) 0))
 		     combining)
+		    ;; Category
+		    (combine-cat cat)
 		    ;; Combining class - used again to filter initial composes
 		    combining)
 	      (loop code))))))))
@@ -402,11 +423,11 @@
 
 (define vectors (make-hash-table 'equal))
 (define vectors2 (make-hash-table 'equal))
+(define vectors3 (make-hash-table 'equal))
 
 (define pos 0)
 (define pos2 0)
 (define pos3 0)
-(define pos4 0)
 
 (current-output-port (open-output-file "schuchar.inc" 'truncate/replace))
 
@@ -422,6 +443,7 @@
 
 (hash-vectors! top vectors (lambda () pos) (lambda (v) (set! pos v)))
 (hash-vectors! top2 vectors2 (lambda () pos2) (lambda (v) (set! pos2 v)))
+(hash-vectors! top3 vectors3 (lambda () pos3) (lambda (v) (set! pos3 v)))
 
 ;; copy folding special cases to the special-cases table, if not there already:
 (hash-table-for-each special-case-foldings
@@ -447,6 +469,8 @@
 	      (* 2 (add1 (length (hash-table-map vectors cons)))))
 	   (* (add1 low) 
 	      (* 1 (add1 (length (hash-table-map vectors2 cons)))))
+	   (* (add1 low) 
+	      (* 1 (add1 (length (hash-table-map vectors3 cons)))))
 	   (* (hash-table-count decomp-ht)
 	      8)
 	   (* (hash-table-count compose-map)
@@ -466,6 +490,9 @@
 (printf "\n/* Character case mapping as index into scheme_uchar_ups, etc.: */\n")
 (printf "unsigned char *scheme_uchar_cases_table[~a];~n" hi-count)
 
+(printf "\n/* Character general categories: */\n")
+(printf "unsigned char *scheme_uchar_cats_table[~a];~n" hi-count)
+
 (printf "\n/* The udata... arrays are used by init_uchar_table to fill the above mappings.*/\n\n")
 
 (define print-row
@@ -494,6 +521,7 @@
 (print-table "short" "" vectors pos #t)
 (printf "\n")
 (print-table "char" "_cases" vectors2 pos2 #f)
+(print-table "char" "_cats" vectors3 pos3 #f)
 
 (printf "~n/* Case mapping size: ~a */\n" (hash-table-count (car cases)))
 (printf "/* Find an index into the ups, downs, etc. table for a character\n")
@@ -521,6 +549,19 @@
 (print-shift (car cases) (unbox (cdr cases)) cadddr "int" "folds")
 (print-shift (car cases) (unbox (cdr cases)) (lambda (x) (cadddr (cdr x))) "unsigned char" "combining_classes")
 
+(let ([l (quicksort (hash-table-map general-categories cons)
+		    (lambda (a b)
+		      (< (cdr a) (cdr b))))])
+  (printf "\n#define NUM_GENERAL_CATEGORIES ~a\n" (length l))
+  (printf "static const char *general_category_names[] = {")
+  (for-each (lambda (c)
+	      (printf (if (zero? (cdr c))
+			  "\n  ~s"
+			  ",\n  ~s")
+		      (string-downcase (car c))))
+	    l)
+  (printf "\n};\n"))
+
 (set! ranges (cons (list range-bottom range-top (range-v . > . -1))
 		   ranges))
 
@@ -574,6 +615,7 @@
 	    (loop (add1 i)))))))
 (print-init top vectors "")
 (print-init top2 vectors2 "_cases")
+(print-init top3 vectors3 "_cats")
 (printf "}~n")
 
 ;; ----------------------------------------

src/mzscheme/src/module.c

@@ -443,7 +443,7 @@ void scheme_finish_kernel(Scheme_Env *env)
 
   rn = scheme_make_module_rename(0, mzMOD_RENAME_NORMAL, NULL);
   for (i = kernel->num_provides; i--; ) {
-    scheme_extend_module_rename(rn, kernel_symbol, exs[i], exs[i], kernel_symbol, exs[i], 0);
+    scheme_extend_module_rename(rn, kernel_symbol, exs[i], exs[i], kernel_symbol, exs[i], 0, 0);
   }
 
   scheme_sys_wraps(NULL);
@@ -541,7 +541,7 @@ void scheme_require_from_original_env(Scheme_Env *env, int syntax_only)
   c = kernel->num_provides;
   i = (syntax_only ? kernel->num_var_provides : 0);
   for (; i < c; i++) {
-    scheme_extend_module_rename(rn, kernel_symbol, exs[i], exs[i], kernel_symbol, exs[i], 0);
+    scheme_extend_module_rename(rn, kernel_symbol, exs[i], exs[i], kernel_symbol, exs[i], 0, 0);
   }
 }
 
@@ -1156,7 +1156,7 @@ static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[])
 	past_to_modchains = SCHEME_CDR(past_to_modchains);
 	phase--;
       } else {
-	past_checkeds = cons((Scheme_Object *)prev_checked, past_checkeds);
+	past_checkeds = scheme_make_raw_pair((Scheme_Object *)prev_checked, past_checkeds);
 	prev_checked = checked;
 
 	todo = next_phase_todo;
@@ -1205,7 +1205,7 @@ static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[])
   }
   while (phase > 0) {
     prev_checked = (Scheme_Hash_Table *)SCHEME_CAR(past_checkeds);
-    future_checkeds = scheme_make_pair((Scheme_Object *)prev_checked, future_checkeds);
+    future_checkeds = scheme_make_raw_pair((Scheme_Object *)prev_checked, future_checkeds);
     
     past_checkeds = SCHEME_CDR(past_checkeds);
     --phase;
@@ -1321,7 +1321,7 @@ static Scheme_Object *namespace_unprotect_module(int argc, Scheme_Object *argv[]
 static int add_require_renames(Scheme_Object *rn, Scheme_Module *im, Scheme_Object *idx)
 {
   int i, saw_mb;
-  Scheme_Object **exs, **exss, **exsns, *midx;
+  Scheme_Object **exs, **exss, **exsns, *midx, *info;
 
   saw_mb = 0;
 
@@ -1333,7 +1333,7 @@ static int add_require_renames(Scheme_Object *rn, Scheme_Module *im, Scheme_Obje
       midx = scheme_modidx_shift(exss[i], im->src_modidx, idx);
     else
       midx = idx;
-    scheme_extend_module_rename(rn, midx, exs[i], exsns[i], idx, exs[i], 0);
+    scheme_extend_module_rename(rn, midx, exs[i], exsns[i], idx, exs[i], 0, 1);
     if (SAME_OBJ(exs[i], module_begin_symbol))
       saw_mb = 1;
   }
@@ -1343,6 +1343,9 @@ static int add_require_renames(Scheme_Object *rn, Scheme_Module *im, Scheme_Obje
     saw_mb = 1;
   }
 
+  info = cons(idx, cons(scheme_null, scheme_false));
+  scheme_save_module_rename_unmarshal(rn, info);
+
   return saw_mb;
 }
 
@@ -1403,13 +1406,13 @@ static Scheme_Object *module_to_namespace(int argc, Scheme_Object *argv[])
 	for (i = 0; i < m->num_provides; i++) {
 	  if (SCHEME_FALSEP(m->provide_srcs[i])) {
 	    name = m->provides[i];
-	    scheme_extend_module_rename(rn, m->self_modidx, name, name, m->self_modidx, name, 0);
+	    scheme_extend_module_rename(rn, m->self_modidx, name, name, m->self_modidx, name, 0, 0);
 	  }
 	}
 	/* Local, not provided: */
 	for (i = 0; i < m->num_indirect_provides; i++) {
 	  name = m->indirect_provides[i];
-	  scheme_extend_module_rename(rn, m->self_modidx, name, name, m->self_modidx, name, 0);
+	  scheme_extend_module_rename(rn, m->self_modidx, name, name, m->self_modidx, name, 0, 0);
 	}
 
 	/* Required: */
@@ -3771,7 +3774,7 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id,
   scheme_add_global_symbol(name, scheme_undefined, env->genv);
   
   /* Add a renaming: */
-  scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0);
+  scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, 0);
 
   id = scheme_add_rename(*_id, rn);
   *_id = id;
@@ -4063,9 +4066,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 
 	    /* Add a renaming: */
 	    if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name))
-	      scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0);
+	      scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, 0);
 	    else
-	      scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0);	      
+	      scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, 0);
 	    
 	    vars = SCHEME_STX_CDR(vars);
 	  }
@@ -4138,10 +4141,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 
 	    if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name))
 	      scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name,
-					  for_stx ? 1 : 0);
+					  for_stx ? 1 : 0, 0);
 	    else
 	      scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name,
-					  for_stx ? 1 : 0);
+					  for_stx ? 1 : 0, 0);
 
 	    count++;
 	  }
@@ -5220,6 +5223,248 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob
 /*                         top-level require                           */
 /**********************************************************************/
 
+void add_single_require(Scheme_Module *m, /* from module */
+			Scheme_Object *idx, /* from module's idx; may be used to find m on unmarshal */
+			Scheme_Env *env, /* env for mark_src or copy_vars */
+			Scheme_Object *rn, /* add requires to this rename when no mark_src */
+			Scheme_Object *post_ex_rn, /* add requires to this rename when mark_src */
+			Scheme_Object *exns, /* NULL or [syntax] list of [syntax] symbols not to import */
+			Scheme_Hash_Table *onlys, /* NULL or hash table of names to import */
+			Scheme_Object *prefix, /* NULL or prefix symbol */
+			Scheme_Object *iname, /* NULL or symbol for a single import */
+			Scheme_Object *ename, /* NULL or symbol for a single import */
+			Scheme_Object *mark_src, /* default mark_src; if onlys, each is also mark_src */
+			int unpack_kern, int copy_vars, int for_unmarshal,
+			int *all_simple,
+			Check_Func ck, /* NULL or called for each addition */
+			void *data, Scheme_Object *form, Scheme_Object *cki /* ck args */
+			)
+{
+  int j, var_count;
+  Scheme_Object **exs, **exsns, **exss;
+  Scheme_Object *orig_idx = idx;
+  int is_kern, has_context, save_marshal_info = 0, can_save_marshal = 1;
+  Scheme_Object *nominal_modidx, *one_exn, *prnt_iname, *name;
+  
+  if (mark_src) {
+    /* Check whether there's context for this import (which
+       leads to generated local names). */
+    Scheme_Object *l;
+    l = scheme_stx_extract_marks(mark_src);
+    has_context = !SCHEME_NULLP(l);
+    if (has_context) {
+      if (all_simple)
+	*all_simple = 0;
+    }
+  } else
+    has_context = 0; /* computed later */
+
+  if (iname || ename || onlys || for_unmarshal || unpack_kern || has_context)
+    can_save_marshal = 0;
+    
+  is_kern = (SAME_OBJ(idx, kernel_symbol)
+	     && !exns
+	     && !onlys
+	     && !prefix
+	     && !iname
+	     && !unpack_kern
+	     && !has_context);
+
+  one_exn = NULL;
+
+  nominal_modidx = idx;
+
+  while (1) { /* loop to handle kernel re-provides... */
+    int break_if_iname_null = !!iname;
+
+    exs = m->provides;
+    exsns = m->provide_src_names;
+    exss = m->provide_srcs;
+    var_count = m->num_var_provides;
+
+    for (j = m->num_provides; j--; ) {
+      Scheme_Object *modidx;
+	
+      if (ename) {
+	if (!SAME_OBJ(SCHEME_STX_VAL(ename), exs[j]))
+	  continue;  /* we don't want this one. */
+      } else if (onlys) {
+	name = scheme_hash_get(onlys, exs[j]);
+	if (!name)
+	  continue;  /* we don't want this one. */
+	mark_src = name;
+	{
+	  Scheme_Object *l;
+	  l = scheme_stx_extract_marks(mark_src);
+	  has_context = !SCHEME_NULLP(l);
+	}
+	/* Remove to indicate that it's been imported: */
+	scheme_hash_set(onlys, exs[j], NULL);
+      } else {
+	if (exns) {
+	  Scheme_Object *l, *a;
+	  for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
+	    a = SCHEME_STX_CAR(l);
+	    if (SCHEME_STXP(a)) 
+	      a = SCHEME_STX_VAL(a);
+	    if (SAME_OBJ(a, exs[j]))
+	      break;
+	  }
+	  if (!SCHEME_STX_NULLP(l))
+	    continue; /* we don't want this one. */
+	}
+
+	if (one_exn) {
+	  if (SAME_OBJ(one_exn, exs[j]))
+	    continue; /* we don't want this one. */
+	}
+      }
+	
+      modidx = ((exss && !SCHEME_FALSEP(exss[j])) 
+		? scheme_modidx_shift(exss[j], m->src_modidx, idx)
+		: idx);
+      
+      if (!iname)
+	iname = exs[j];
+
+      if (SCHEME_SYM_WEIRDP(iname)) {
+	/* This shouldn't happen. In case it does, don't import a
+	   gensym or parallel symbol. The former is useless. The
+	   latter is supposed to be module-specific, and it could
+	   collide with local module-specific ids. */
+	iname = NULL;
+	continue;
+      }
+
+      if (prefix)
+	iname = scheme_symbol_append(prefix, iname);
+
+      prnt_iname = iname;
+      if (has_context) {
+	/* The `require' expression has a set of marks in its
+	   context, which means that we need to generate a name. */
+	iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0);
+	iname = scheme_tl_id_sym(env, iname, 2);
+      }
+
+      if (ck)
+	ck(prnt_iname, iname, nominal_modidx, modidx, exsns[j], (j < var_count), data, cki, form);
+	
+      if (!is_kern) {
+	if (copy_vars && (j < var_count) && !env->module && !env->phase) {
+	  Scheme_Env *menv;
+	  Scheme_Object *val;
+	  modidx = scheme_module_resolve(modidx);
+	  menv = scheme_module_access(modidx, env, 0);
+	  val = scheme_lookup_in_table(menv->toplevel, (char *)exsns[j]);
+	  scheme_add_global_symbol(iname, val, env);
+	} else if (!for_unmarshal || !has_context) {
+	  if (!save_marshal_info && !has_context && can_save_marshal)
+	    save_marshal_info = 1;
+	  scheme_extend_module_rename((has_context ? post_ex_rn : rn), 
+				      modidx, iname, exsns[j], nominal_modidx, exs[j], 0,
+				      for_unmarshal || (!has_context && can_save_marshal));
+	}
+      }
+
+      iname = NULL;
+	
+      if (ename) {
+	ename = NULL;
+	break;
+      }
+    }
+
+    if (ename) {
+      if (!m->reprovide_kernel) {
+	scheme_wrong_syntax(NULL, ename, form, "no such provided variable");
+	return;
+      }
+    }
+
+    if (is_kern)
+      scheme_extend_module_rename_with_kernel(rn, nominal_modidx);
+
+    if (break_if_iname_null && !iname)
+      break;
+
+    if (m->reprovide_kernel) {
+      idx = kernel_symbol;
+      one_exn = m->kernel_exclusion;
+      m = kernel;
+      is_kern = !prefix && !unpack_kern && !ename && !has_context;
+    } else
+      break;
+  }
+
+  if (save_marshal_info) {
+    Scheme_Object *info, *a;
+
+    if (exns) {
+      /* Convert to a list of symbols: */
+      info = scheme_null;
+      for (; SCHEME_STX_PAIRP(exns); exns = SCHEME_STX_CDR(exns)) {
+	a = SCHEME_STX_CAR(exns);
+	if (SCHEME_STXP(a))
+	  a = SCHEME_STX_VAL(a);
+	info = cons(a, info);
+      }
+      exns = info;
+    } else
+      exns = scheme_null;
+
+    /* The format of this data is checked in stxobj for unmarshaling
+       a Module_Renames. Also the idx must be first, to support shifting. */
+    info = cons(orig_idx, cons(exns, prefix ? prefix : scheme_false));
+
+    scheme_save_module_rename_unmarshal(rn, info);
+  }
+}
+
+void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
+				       Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to)
+{
+  Scheme_Object *orig_idx, *exns, *prefix, *idx, *name;
+  Scheme_Module *m;
+  Scheme_Env *env;
+
+  idx = SCHEME_CAR(info);
+  orig_idx = idx;
+  info = SCHEME_CDR(info);
+  exns = SCHEME_CAR(info);
+  prefix = SCHEME_CDR(info);
+
+  if (SCHEME_FALSEP(prefix))
+    prefix = NULL;
+  if (SCHEME_NULLP(exns))
+    exns = NULL;
+
+  if (modidx_shift_from)
+    idx = scheme_modidx_shift(idx,
+			      modidx_shift_from,
+			      modidx_shift_to);
+
+  env = scheme_get_env(scheme_current_config());
+  name = scheme_module_resolve(idx);
+  m = (Scheme_Module *)scheme_hash_get(env->module_registry, name);
+  if (!m) {
+    scheme_signal_error("broken compiled/expanded code or wrong namespace;"
+			" cannot find instance to restore imported renamings"
+			" from module: %s",
+			scheme_symbol_name(name));
+    return;
+  }
+
+  add_single_require(m, orig_idx, env,
+		     rn, NULL,
+		     exns, NULL, prefix, NULL, NULL,
+		     NULL,
+		     0, 0, 1,
+		     NULL,
+		     NULL,
+		     NULL, NULL, NULL);
+}
+
 Scheme_Object *parse_requires(Scheme_Object *form, 
 			      Scheme_Object *base_modidx,
 			      Scheme_Env *env,
@@ -5231,10 +5476,8 @@ Scheme_Object *parse_requires(Scheme_Object *form,
 {
   Scheme_Object *ll = form;
   Scheme_Module *m;
-  int j, var_count, is_kern, has_context;
+  Scheme_Object *idxstx, *idx, *name, *i, *exns, *prefix, *iname, *ename, *aa;
-  Scheme_Object **exs, **exsns, **exss;
+  Scheme_Object *imods, *mark_src;
-  Scheme_Object *idxstx, *idx, *name, *i, *exns, *one_exn, *prefix, *iname, *ename, *aa;
-  Scheme_Object *imods, *nominal_modidx, *mark_src, *prnt_iname;
   Scheme_Hash_Table *onlys;
 
   imods = scheme_null;
@@ -5432,25 +5675,6 @@ Scheme_Object *parse_requires(Scheme_Object *form,
     else if (expstart)
       expstart_module(m, env, 0, idx, 0, 0, scheme_null);
 
-    if (mark_src) {
-      /* Check whether there's context for this import (which
-	 leads to generated local names). */
-      Scheme_Object *l;
-      l = scheme_stx_extract_marks(mark_src);
-      has_context = !SCHEME_NULLP(l);
-      if (has_context && all_simple)
-	*all_simple = 0;
-    } else
-      has_context = 0; /* computed later */
-
-    is_kern = (SAME_OBJ(idx, kernel_symbol)
-	       && !exns
-	       && !onlys
-	       && !prefix
-	       && !iname
-	       && !unpack_kern
-	       && !has_context);
-
     /* Add name to require list, if it's not there: */
     {
       Scheme_Object *l, *last = NULL, *p;
@@ -5468,126 +5692,12 @@ Scheme_Object *parse_requires(Scheme_Object *form,
       }
     }
     
-    one_exn = NULL;
+    add_single_require(m, idx, env, rn, post_ex_rn,
-
+		       exns, onlys, prefix, iname, ename,
-    nominal_modidx = idx;
+		       mark_src, 
-      
+		       unpack_kern, copy_vars && start, 0,
-    while (1) { /* loop to handle kernel re-provides... */
+		       all_simple,
-      int break_if_iname_null = !!iname;
+		       ck, data, form, i);
-
-      exs = m->provides;
-      exsns = m->provide_src_names;
-      exss = m->provide_srcs;
-      var_count = m->num_var_provides;
-
-      for (j = m->num_provides; j--; ) {
-	Scheme_Object *modidx;
-	
-	if (ename) {
-	  if (!SAME_OBJ(SCHEME_STX_VAL(ename), exs[j]))
-	    continue;  /* we don't want this one. */
-	} else if (onlys) {
-	  name = scheme_hash_get(onlys, exs[j]);
-	  if (!name)
-	    continue;  /* we don't want this one. */
-	  mark_src = name;
-	  {
-	    Scheme_Object *l;
-	    l = scheme_stx_extract_marks(mark_src);
-	    has_context = !SCHEME_NULLP(l);
-	  }
-	  /* Remove to indicate that it's been imported: */
-	  scheme_hash_set(onlys, exs[j], NULL);
-	} else {
-	  if (exns) {
-	    Scheme_Object *l;
-	    for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
-	      if (SAME_OBJ(SCHEME_STX_VAL(SCHEME_STX_CAR(l)), exs[j]))
-		break;
-	    }
-	    if (!SCHEME_STX_NULLP(l))
-	      continue; /* we don't want this one. */
-	  }
-
-	  if (one_exn) {
-	    if (SAME_OBJ(one_exn, exs[j]))
-	      continue; /* we don't want this one. */
-	  }
-	}
-	
-	modidx = ((exss && !SCHEME_FALSEP(exss[j])) 
-		  ? scheme_modidx_shift(exss[j], m->src_modidx, idx)
-		  : idx);
-      
-	if (!iname)
-	  iname = exs[j];
-
-	if (SCHEME_SYM_WEIRDP(iname)) {
-	  /* This shouldn't happen. In case it does, don't import a
-	     gensym or parallel symbol. The former is useless. The
-	     latter is supposed to be module-specific, and it could
-	     collide with local module-specific ids. */
-	  iname = NULL;
-	  continue;
-	}
-
-	if (prefix)
- 	  iname = scheme_symbol_append(prefix, iname);
-
-	prnt_iname = iname;
-	if (has_context) {
-	  /* The `require' expression has a set of marks in its
-	     context, which means that we need to generate a name. */
-	  iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0);
-	  iname = scheme_tl_id_sym(env, iname, 2);
-	}
-
-	if (ck)
-	  ck(prnt_iname, iname, nominal_modidx, modidx, exsns[j], (j < var_count), data, i, form);
-	
-	if (!is_kern) {
-    	  if (copy_vars && start && (j < var_count) && !env->module && !env->phase) {
-	    Scheme_Env *menv;
-	    Scheme_Object *val;
-	    modidx = scheme_module_resolve(modidx);
-	    menv = scheme_module_access(modidx, env, 0);
-	    val = scheme_lookup_in_table(menv->toplevel, (char *)exsns[j]);
-	    scheme_add_global_symbol(iname, val, env);
-	  } else {
-	    scheme_extend_module_rename((has_context ? post_ex_rn : rn), 
-					modidx, iname, exsns[j], nominal_modidx, exs[j], 0);
-	  }
-	}
-
-	iname = NULL;
-	
-	if (ename) {
-	  ename = NULL;
-	  break;
-	}
-      }
-
-      if (ename) {
-	if (!m->reprovide_kernel) {
-	  scheme_wrong_syntax(NULL, ename, form, "no such provided variable");
-	  return NULL;
-	}
-      }
-
-      if (is_kern)
-	scheme_extend_module_rename_with_kernel(rn, nominal_modidx);
-
-      if (break_if_iname_null && !iname)
-	break;
-
-      if (m->reprovide_kernel) {
-	idx = kernel_symbol;
-	one_exn = m->kernel_exclusion;
-	m = kernel;
-	is_kern = !prefix && !unpack_kern && !ename && !has_context;
-      } else
-	break;
-    }
 
     if (onlys && onlys->count) {
       /* Something required in `only' wasn't provided by the module */

src/mzscheme/src/mzmark.c

@@ -131,6 +131,25 @@ static int toplevel_obj_FIXUP(void *p) {
 #define toplevel_obj_IS_CONST_SIZE 1
 
 
+static int quotesyntax_obj_SIZE(void *p) {
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Quote_Syntax));
+}
+
+static int quotesyntax_obj_MARK(void *p) {
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Quote_Syntax));
+}
+
+static int quotesyntax_obj_FIXUP(void *p) {
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Quote_Syntax));
+}
+
+#define quotesyntax_obj_IS_ATOMIC 1
+#define quotesyntax_obj_IS_CONST_SIZE 1
+
+
 static int cpointer_obj_SIZE(void *p) {
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Simple_Object));
@@ -4109,6 +4128,7 @@ static int mark_readtable_MARK(void *p) {
   Readtable *t = (Readtable *)p;
   gcMARK(t->mapping);
   gcMARK(t->fast_mapping);
+  gcMARK(t->symbol_parser);
   return
   gcBYTES_TO_WORDS(sizeof(Readtable));
 }
@@ -4117,6 +4137,7 @@ static int mark_readtable_FIXUP(void *p) {
   Readtable *t = (Readtable *)p;
   gcFIXUP(t->mapping);
   gcFIXUP(t->fast_mapping);
+  gcFIXUP(t->symbol_parser);
   return
   gcBYTES_TO_WORDS(sizeof(Readtable));
 }
@@ -4260,6 +4281,8 @@ static int mark_rename_table_SIZE(void *p) {
 static int mark_rename_table_MARK(void *p) {
   Module_Renames *rn = (Module_Renames *)p;
   gcMARK(rn->ht);
+  gcMARK(rn->nomarshal_ht);
+  gcMARK(rn->unmarshal_info);
   gcMARK(rn->plus_kernel_nominal_source);
   gcMARK(rn->marked_names);
   return
@@ -4269,6 +4292,8 @@ static int mark_rename_table_MARK(void *p) {
 static int mark_rename_table_FIXUP(void *p) {
   Module_Renames *rn = (Module_Renames *)p;
   gcFIXUP(rn->ht);
+  gcFIXUP(rn->nomarshal_ht);
+  gcFIXUP(rn->unmarshal_info);
   gcFIXUP(rn->plus_kernel_nominal_source);
   gcFIXUP(rn->marked_names);
   return

src/mzscheme/src/mzmarksrc.c

@@ -48,6 +48,12 @@ toplevel_obj {
   gcBYTES_TO_WORDS(sizeof(Scheme_Toplevel));
 }
 
+quotesyntax_obj {
+ mark:
+ size:
+  gcBYTES_TO_WORDS(sizeof(Scheme_Quote_Syntax));
+}
+
 cpointer_obj {
  mark:
   gcMARK(SCHEME_CPTR_VAL((Scheme_Object *)p));
@@ -1660,6 +1666,7 @@ mark_readtable {
   Readtable *t = (Readtable *)p;
   gcMARK(t->mapping);
   gcMARK(t->fast_mapping);
+  gcMARK(t->symbol_parser);
  size:
   gcBYTES_TO_WORDS(sizeof(Readtable));
 }
@@ -1726,6 +1733,8 @@ mark_rename_table {
  mark:
   Module_Renames *rn = (Module_Renames *)p;
   gcMARK(rn->ht);
+  gcMARK(rn->nomarshal_ht);
+  gcMARK(rn->unmarshal_info);
   gcMARK(rn->plus_kernel_nominal_source);
   gcMARK(rn->marked_names);
  size:

src/mzscheme/src/port.c

@@ -1554,7 +1554,7 @@ long scheme_get_byte_string_unless(const char *who,
 	    ip->unless_cache = scheme_false;
 	    ip->unless = unless;
 	  } else {
-	    unless = scheme_make_pair(NULL, NULL);
+	    unless = scheme_make_raw_pair(NULL, NULL);
 	    ip->unless = unless;
 	  }
 	  if (unless_evt)
@@ -1904,7 +1904,7 @@ int scheme_peeked_read_via_get(Scheme_Input_Port *ip,
       /* Some other thread is already trying to commit.
 	 Ask it to sync on our target, too */
       v = scheme_make_pair(scheme_make_integer(_size), target_evt);
-      l = scheme_make_pair(v, ip->input_extras);
+      l = scheme_make_raw_pair(v, ip->input_extras);
       ip->input_extras = l;
 
       scheme_post_sema_all(ip->input_giveup);
@@ -1941,12 +1941,12 @@ int scheme_peeked_read_via_get(Scheme_Input_Port *ip,
 	/* There are other threads trying to commit, and
 	   as main thread, we'll help them out. */
 	n = 3;
-	for (l = ip->input_extras; l ; l = SCHEME_CDR(l)) {
+	for (l = ip->input_extras; l; l = SCHEME_CDR(l)) {
 	  n++;
 	}
 	aa = MALLOC_N(Scheme_Object *, n);
 	n = 3;
-	for (l = ip->input_extras; l ; l = SCHEME_CDR(l)) {
+	for (l = ip->input_extras; l; l = SCHEME_CDR(l)) {
 	  aa[n++] = SCHEME_CDR(SCHEME_CAR(l));
 	}
       } else {

src/mzscheme/src/print.c

@@ -2153,7 +2153,15 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
 #ifdef SGC_STD_DEBUGGING
 	len = strlen(s) - 1;
 #endif
+	if (!s) {
+	  char s[8];
+	  print_utf8_string(pp, "<???:", 0, 5);
+	  sprintf(s, "%d", SCHEME_TYPE(obj));
+	  print_utf8_string(pp, s, 0, -1);
+	  print_utf8_string(pp, ">", 0, 1);
+	} else {
 	  print_utf8_string(pp, s, 0, len);
+	}
 #ifdef SGC_STD_DEBUGGING
 	PRINTADDRESS(pp, obj);
 	print_utf8_string(pp, ">", 0, 1);

src/mzscheme/src/read.c

@@ -80,6 +80,8 @@ static Scheme_Object *print_honu(int, Scheme_Object *[]);
 
 #define isdigit_ascii(n) ((n >= '0') && (n <= '9'))
 
+#define scheme_isxdigit(n) (isdigit_ascii(n) || ((n >= 'a') && (n <= 'f')) || ((n >= 'A') && (n <= 'F')))
+
 #define RETURN_FOR_SPECIAL_COMMENT  0x1
 #define RETURN_FOR_HASH_COMMENT     0x2
 #define RETURN_FOR_DELIM            0x4
@@ -106,6 +108,7 @@ typedef struct Readtable {
   Scheme_Object so;
   Scheme_Hash_Table *mapping; /* pos int -> (cons int proc-or-char); neg int -> proc */
   char *fast_mapping;
+  Scheme_Object *symbol_parser; /* NULL or a Scheme function */
 } Readtable;
 
 typedef struct ReadParams {
@@ -170,7 +173,7 @@ static Scheme_Object *read_number(int init_ch,
 				  Scheme_Object *indentation,
 				  ReadParams *params,
 				  Readtable *table);
-static Scheme_Object *read_symbol(int init_ch,
+static Scheme_Object *read_symbol(int init_ch, int skip_rt,
 				  Scheme_Object *port, Scheme_Object *stxsrc,
 				  long line, long col, long pos,
 				  Scheme_Hash_Table **ht,
@@ -219,6 +222,10 @@ static int skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc,
 				    Scheme_Object *indentation,
 				    ReadParams *params);
 
+static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, ReadParams *params,
+				     Scheme_Object *port, Scheme_Object *src, long line, long col, long pos,
+				     Scheme_Hash_Table **ht);
+
 static Scheme_Object *copy_to_protect_placeholders(Scheme_Object *v, Scheme_Object *src, Scheme_Hash_Table **ht);
 
 #define READTABLE_WHITESPACE 0x1
@@ -725,7 +732,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
 		 Scheme_Object *indentation, ReadParams *params,
 		 int comment_mode, int pre_char, Readtable *table)
 {
-  int ch, ch2, depth, dispatch_ch;
+  int ch, ch2, depth, dispatch_ch, special_value_need_copy = 0;
   long line = 0, col = 0, pos = 0;
   Scheme_Object *special_value;
 
@@ -818,28 +825,11 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
       return scheme_eof;
     case SCHEME_SPECIAL:
       {
-	Scheme_Object *v;
+	if (!special_value) {
-	if (special_value)
+	  special_value = scheme_get_special(port, stxsrc, line, col, pos, 0, ht);
-	  v = special_value;
+	  special_value_need_copy = 1;
-	else
-	  v = scheme_get_special(port, stxsrc, line, col, pos, 0, ht);
-	if (scheme_special_comment_value(v)) {
-	  /* a "comment" */
-	  if (comment_mode & RETURN_FOR_SPECIAL_COMMENT)
-	    return NULL;
-	  else
-	    goto start_over;
-	} else if (SCHEME_STXP(v)) {
-	  if (!stxsrc)
-	    v = scheme_syntax_to_datum(v, 0, NULL);
-	} else if (stxsrc) {
-	  Scheme_Object *s;
-	  s = scheme_make_stx_w_offset(scheme_false, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
-	  v = scheme_datum_to_syntax(v, s, scheme_false, 1, 0);
 	}
-	if (!special_value)
+	break;
-	  v = copy_to_protect_placeholders(v, stxsrc, ht);
-	return v;
       }
     case ']':
       if (!params->square_brackets_are_parens) {
@@ -875,7 +865,8 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
       } else
 	return read_list(port, stxsrc, line, col, pos, '}', mz_shape_cons, 0, ht, indentation, params);
     case '|':
-      return read_symbol(ch, port, stxsrc, line, col, pos, ht, indentation, params, table);
+      special_value = read_symbol(ch, 1, port, stxsrc, line, col, pos, ht, indentation, params, table);
+      break;
     case '"':
       return read_string(0, 0, port, stxsrc, line, col, pos, ht, indentation, params, 1);
     case '\'':
@@ -887,7 +878,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
     case '`':
       if (params->honu_mode) {
 	/* Raises illegal-char error: */
-	return read_symbol(ch, port, stxsrc, line, col, pos, ht, indentation, params, table);
+	return read_symbol(ch, 1, port, stxsrc, line, col, pos, ht, indentation, params, table);
       } else if (!params->can_read_quasi) {
 	scheme_read_err(port, stxsrc, line, col, pos, 1, 0, indentation, "read: illegal use of backquote");
 	return NULL;
@@ -930,7 +921,8 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
     case '+':
     case '-':
       if (params->honu_mode) {
-	return read_symbol(ch, port, stxsrc, line, col, pos, ht, indentation, params, table);
+	special_value = read_symbol(ch, 1, port, stxsrc, line, col, pos, ht, indentation, params, table);
+	break;
       }
     case '.': /* ^^^ fallthrough ^^^ */
       ch2 = scheme_peekc_special_ok(port);
@@ -938,10 +930,12 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
 	  || (!params->honu_mode
 	      && ((ch2 == 'i') || (ch2 == 'I') /* Maybe inf */
 		  || (ch2 == 'n') || (ch2 == 'N') /* Maybe nan*/ ))) {
-	return read_number(ch, port, stxsrc, line, col, pos, 0, 0, 10, 0, ht, indentation, params, table);
+	/* read_number tries to get a number, but produces a symbol if number parsing doesn't work: */
+	special_value = read_number(ch, port, stxsrc, line, col, pos, 0, 0, 10, 0, ht, indentation, params, table);
       } else {
-	return read_symbol(ch, port, stxsrc, line, col, pos, ht, indentation, params, table);
+	special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
       }
+      break;
     case '#':
       ch = scheme_getc_special_ok(port);
 
@@ -959,7 +953,9 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
 	}
       }
 
-      switch ( ch )
+      special_value = NULL;
+
+      switch (ch)
 	{
 	case EOF:
 	case SCHEME_SPECIAL:
@@ -993,7 +989,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
 	case '%':
 	  if (!params->honu_mode) {
 	    scheme_ungetc('%', port);
-	    return read_symbol('#', port, stxsrc, line, col, pos, ht, indentation, params, table);
+	    special_value = read_symbol('#', 1, port, stxsrc, line, col, pos, ht, indentation, params, table);
 	  }
 	  break;
 	case ':':
@@ -1598,11 +1594,13 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
 	  }
 	  break;
 	}
+      if (!special_value) {
 	/* We get here only in honu mode */
 	scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation,
 			"read: bad syntax `#%c'",
 			ch);
 	return NULL;
+      }
       break;
     case '/':
       if (params->honu_mode) {
@@ -1615,13 +1613,39 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
 	  goto start_over_with_ch;
 	}
       }
-      return read_symbol(ch, port, stxsrc, line, col, pos, ht, indentation, params, table);
+      special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
       break;
     default:
       if (isdigit_ascii(ch))
-	return read_number(ch, port, stxsrc, line, col, pos, 0, 0, 10, 0, ht, indentation, params, table);
+	special_value = read_number(ch, port, stxsrc, line, col, pos, 0, 0, 10, 0, ht, indentation, params, table);
       else
-	return read_symbol(ch, port, stxsrc, line, col, pos, ht, indentation, params, table);
+	special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table);
+      break;
+    }
+
+  /* We get here after reading a "symbol". Check for a comment. */
+  {
+    Scheme_Object *v = special_value;
+
+    if (scheme_special_comment_value(v)) {
+      /* a "comment" */
+      if (comment_mode & RETURN_FOR_SPECIAL_COMMENT)
+	return NULL;
+      else {
+	special_value_need_copy = 0;
+	goto start_over;
+      }
+    } else if (SCHEME_STXP(v)) {
+      if (!stxsrc)
+	v = scheme_syntax_to_datum(v, 0, NULL);
+    } else if (stxsrc) {
+      Scheme_Object *s;
+      s = scheme_make_stx_w_offset(scheme_false, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG);
+      v = scheme_datum_to_syntax(v, s, scheme_false, 1, 0);
+    }
+    if (special_value_need_copy)
+      v = copy_to_protect_placeholders(v, stxsrc, ht);
+    return v;
   }
 }
 
@@ -1816,8 +1840,10 @@ _scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int h
 
   ht = NULL;
   if (recur) {
+    /* Check whether this is really a recursive call. If so,
+       we get a pointer to a hash table for cycles: */
     v = scheme_extract_one_cc_mark(NULL, an_uninterned_symbol);
-    if (v && SCHEME_PAIRP(v)) {
+    if (v && SCHEME_RPAIRP(v)) {
       if (SCHEME_FALSEP(SCHEME_CDR(v)) == !stxsrc)
 	ht = (Scheme_Hash_Table **)SCHEME_CAR(v);
     }
@@ -2785,7 +2811,7 @@ typedef int (*Getc_Fun_r)(Scheme_Object *port);
 
 /* nothing has been read, except maybe some flags */
 static Scheme_Object  *
-read_number_or_symbol(int init_ch, Scheme_Object *port,
+read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port,
 		      Scheme_Object *stxsrc, long line, long col, long pos,
 		      int is_float, int is_not_float,
 		      int radix, int radix_set,
@@ -2808,6 +2834,15 @@ read_number_or_symbol(int init_ch, Scheme_Object *port,
   int single_escape, multiple_escape, norm_count = 0;
   Getc_Fun_r getc_special_ok_fun;
 
+  if (!skip_rt && table) {
+    /* If the readtable provide a "symbol" reader, then use it: */
+    if (table->symbol_parser) {
+      return readtable_call(1, init_ch, table->symbol_parser, params, 
+			    port, stxsrc, line, col, pos, ht);
+      /* Special-comment result is handled in main loop. */
+    }
+  }
+
   ungetc_ok = scheme_peekc_is_ungetc(port);
 
   if (ungetc_ok) {
@@ -3074,7 +3109,7 @@ read_number(int init_ch,
 	    Scheme_Hash_Table **ht,
 	    Scheme_Object *indentation, ReadParams *params, Readtable *table)
 {
-  return read_number_or_symbol(init_ch,
+  return read_number_or_symbol(init_ch, init_ch < 0,
 			       port, stxsrc, line, col, pos,
 			       is_float, is_not_float,
 			       radix, radix_set, 0, 0,
@@ -3084,12 +3119,13 @@ read_number(int init_ch,
 
 static Scheme_Object  *
 read_symbol(int init_ch,
+	    int skip_rt,
 	    Scheme_Object *port,
 	    Scheme_Object *stxsrc, long line, long col, long pos,
 	    Scheme_Hash_Table **ht,
 	    Scheme_Object *indentation, ReadParams *params, Readtable *table)
 {
-  return read_number_or_symbol(init_ch,
+  return read_number_or_symbol(init_ch, skip_rt,
 			       port, stxsrc, line, col, pos,
 			       0, 0, 10, 0, 1, 0,
 			       params->can_read_pipe_quote,
@@ -3103,7 +3139,7 @@ read_keyword(int init_ch,
 	     Scheme_Hash_Table **ht,
 	     Scheme_Object *indentation, ReadParams *params, Readtable *table)
 {
-  return read_number_or_symbol(init_ch,
+  return read_number_or_symbol(init_ch, 1,
 			       port, stxsrc, line, col, pos,
 			       0, 0, 10, 0, 1, 1,
 			       params->can_read_pipe_quote,
@@ -4715,7 +4751,7 @@ void scheme_set_in_read_mark(Scheme_Object *src, Scheme_Hash_Table **ht)
   Scheme_Object *v;
 
   if (ht)
-    v = scheme_make_pair((Scheme_Object *)ht, 
+    v = scheme_make_raw_pair((Scheme_Object *)ht, 
 			     (src ? scheme_true : scheme_false));
   else
     v = scheme_false;
@@ -4832,14 +4868,20 @@ static Scheme_Object *make_readtable(int argc, Scheme_Object **argv)
   fast = scheme_malloc_atomic(128);
   memcpy(fast, (orig_t ? orig_t->fast_mapping : builtin_fast), 128);
   t->fast_mapping = fast;
+  t->symbol_parser = (orig_t ? orig_t->symbol_parser : NULL);
 
   for (i = 1; i < argc; i += 3) {
-    if (!SCHEME_CHARP(argv[i])) {
+    if (!SCHEME_FALSEP(argv[i]) && !SCHEME_CHARP(argv[i])) {
-      scheme_wrong_type("make-readtable", "character", i, argc, argv);
+      scheme_wrong_type("make-readtable", "character or #f", i, argc, argv);
       return NULL;
     }
 
     if (i + 1 >= argc) {
+      if (SCHEME_FALSEP(argv[i]))
+	scheme_arg_mismatch("make-readtable",
+			    "expected 'non-terminating-macro after #f",
+			    NULL);
+      else
 	scheme_arg_mismatch("make-readtable",
 			    "expected 'terminating-macro, 'non-terminating-macro, 'dispatch-macro,"
 			    " or character argument after character argument: ",
@@ -4856,16 +4898,25 @@ static Scheme_Object *make_readtable(int argc, Scheme_Object **argv)
 			i+1, argc, argv);
       return NULL;
     }
+    if (SCHEME_FALSEP(argv[i])
+	&& !SAME_OBJ(sym, non_terminating_macro_symbol)) {
+      scheme_arg_mismatch("make-readtable",
+			  "expected 'non-terminating-macro after #f, given: ",
+			  sym);
+    }
 
     if (i + 2 >= argc) {
       scheme_arg_mismatch("make-readtable",
 			  (SCHEME_CHARP(sym) 
-			   ? "expected readtable or #f argument after character argument: "
+			   ? "expected readtable or #f argument after character argument, given: "
-			   : "expected procedure argument after symbol argument: "),
+			   : "expected procedure argument after symbol argument, given: "),
 			  argv[i+1]);
     }
 
-    if (SAME_OBJ(sym, dispatch_macro_symbol)) {
+    if (SCHEME_FALSEP(argv[i])) {
+      scheme_check_proc_arity("make-readtable", 6, i+2, argc, argv);
+      t->symbol_parser = argv[i + 2];
+    } else if (SAME_OBJ(sym, dispatch_macro_symbol)) {
       ch = SCHEME_CHAR_VAL(argv[i]);
       scheme_check_proc_arity("make-readtable", 6, i+2, argc, argv);
       scheme_hash_set(t->mapping, scheme_make_integer(-ch), argv[i+2]);

src/mzscheme/src/salloc.c

@@ -948,6 +948,8 @@ static void cons_onto_list(void *p)
 # ifdef MZ_PRECISE_GC
 START_XFORM_SKIP;
 extern int GC_is_tagged(void *p);
+extern int GC_is_tagged_start(void *p);
+extern void *GC_next_tagged_start(void *p);
 #  ifdef DOS_FILE_SYSTEM
 extern void gc_fprintf(int ignored, const char *c, ...);
 #   define object_console_printf gc_fprintf
@@ -986,10 +988,6 @@ void scheme_print_tagged_value(const char *prefix,
   scheme_check_print_is_obj = check_home;
 
   if (!xtagged) {
-    if (SCHEME_PAIRP(v)) {
-      /* Pairs are used for all sorts of non-Scheme values: */
-      type ="#<pair>";
-    } else
     type = scheme_write_to_string_w_max((Scheme_Object *)v, &len, max_w);
     if (!scheme_strncmp(type, "#<thread", 8) 
 	&& ((type[8] == '>') || (type[8] == ':'))) {
@@ -1070,6 +1068,22 @@ void scheme_print_tagged_value(const char *prefix,
       memcpy(t2 + len, buffer, len2 + 1);
       len += len2;
       type = t2;
+    } else if (!scheme_strncmp(type, "#<syntax-code", 13)) {
+      char *t2, *t3;
+      long len2, len3;
+
+      t2 = scheme_write_to_string_w_max(SCHEME_IPTR_VAL(v), &len2, 32);
+      
+      len3 = len + len2 + 2 + 2;
+      t3 = (char *)scheme_malloc_atomic(len3);
+      memcpy(t3, type, len);
+      t3[len] = (SCHEME_PINT_VAL(v) / 10) + '0';
+      t3[len + 1] = (SCHEME_PINT_VAL(v) % 10) + '0';
+      t3[len + 2] = '=';
+      memcpy(t3 + len + 3, t2, len2);
+      t3[len + len2 + 3] = 0;
+      type = t3;
+      len = len3;
     } else if (!scheme_strncmp(type, "#<syntax", 8)) {
       char *t2, *t3;
       long len2, len3;
@@ -1124,12 +1138,11 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
 
   scheme_start_atomic();
 
-  scheme_console_printf("Begin Dump\n");
-
   if (scheme_external_dump_arg)
     scheme_external_dump_arg(c ? p[0] : NULL);
 
 #ifdef USE_TAGGED_ALLOCATION
+  scheme_console_printf("Begin Dump\n");
   trace_path_type = -1;
   obj_type = -1;
   if (c && SCHEME_SYMBOLP(p[0])) {
@@ -1356,6 +1369,35 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
 
     if (!strcmp("fnl", s))
       GC_show_finals = 1;
+
+    if (!strcmp("peek", s) && (c == 3)) {
+      long n;
+      scheme_end_atomic();
+      if (scheme_get_int_val(p[1], &n)) {
+	if (GC_is_tagged_start((void *)n)) {
+	  return (Scheme_Object *)n;
+	} else
+	  return p[2];
+      }
+    }
+    
+    if (!strcmp("next", s) && (c == 2)) {
+      void *pt;
+      scheme_end_atomic();
+      if (SCHEME_FALSEP(p[1]))
+	pt = GC_next_tagged_start(NULL);
+      else
+	pt = GC_next_tagged_start((void *)p[1]);
+      if (pt)
+	return (Scheme_Object *)pt;
+      else
+	return scheme_false;
+    }
+
+    if (!strcmp("addr", s) && (c == 2)) {
+      scheme_end_atomic();      
+      return scheme_make_integer_value((long)p[1]);
+    }
   } else if (SCHEME_INTP(p[0])) {
     GC_trace_for_tag = SCHEME_INT_VAL(p[0]);
     GC_show_trace = 1;
@@ -1368,6 +1410,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
     GC_show_trace = 0;
   } else
     GC_path_length_limit = 1000;
+  scheme_console_printf("Begin Dump\n");
 #endif
 
   GC_dump();
@@ -1449,6 +1492,9 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
   scheme_console_printf(" (dump-memory-stats -num) - prints paths to objects of size num.\n");
   scheme_console_printf(" (dump-memory-stats sym/num len) - limits path to size len.\n");
   scheme_console_printf(" (dump-memory-stats sym/num 'cons) - builds list instead of showing paths.\n");
+  scheme_console_printf(" (dump-memory-stats 'peek num v) - returns value if num is address of object, v otherwise.\n");
+  scheme_console_printf(" (dump-memory-stats 'next v) - next tagged object after v, #f if none; start with #f.\n");
+  scheme_console_printf(" (dump-memory-stats 'addr v) - returns the address of v.\n");
   scheme_console_printf("End Help\n");
 
   result = cons_accum_result;

src/mzscheme/src/schemef.h

@@ -227,6 +227,7 @@ MZ_EXTERN Scheme_Object *scheme_multiple_values;
 
 MZ_EXTERN unsigned short *scheme_uchar_table[];
 MZ_EXTERN unsigned char *scheme_uchar_cases_table[];
+MZ_EXTERN unsigned char *scheme_uchar_cats_table[];
 MZ_EXTERN int scheme_uchar_ups[];
 MZ_EXTERN int scheme_uchar_downs[];
 MZ_EXTERN int scheme_uchar_titles[];
@@ -438,6 +439,8 @@ MZ_EXTERN void scheme_prim_is_method(Scheme_Object *o);
 MZ_EXTERN Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr);
 MZ_EXTERN Scheme_Object *scheme_make_immutable_pair(Scheme_Object *car, Scheme_Object *cdr);
 
+MZ_EXTERN Scheme_Object *scheme_make_raw_pair(Scheme_Object *, Scheme_Object *);
+
 MZ_EXTERN Scheme_Object *scheme_make_byte_string(const char *chars);
 MZ_EXTERN Scheme_Object *scheme_make_sized_byte_string(char *chars, long len, int copy);
 MZ_EXTERN Scheme_Object *scheme_make_sized_offset_byte_string(char *chars, long d, long len, int copy);

src/mzscheme/src/schemex.h

@@ -182,6 +182,7 @@ Scheme_Object *scheme_tail_call_waiting;
 Scheme_Object *scheme_multiple_values;
 unsigned short **scheme_uchar_table;
 unsigned char **scheme_uchar_cases_table;
+unsigned char **scheme_uchar_cats_table;
 int *scheme_uchar_ups;
 int *scheme_uchar_downs;
 int *scheme_uchar_titles;
@@ -357,6 +358,7 @@ Scheme_Object *(*scheme_make_closed_prim_w_everything)(Scheme_Closed_Prim *fun,
 void (*scheme_prim_is_method)(Scheme_Object *o);
 Scheme_Object *(*scheme_make_pair)(Scheme_Object *car, Scheme_Object *cdr);
 Scheme_Object *(*scheme_make_immutable_pair)(Scheme_Object *car, Scheme_Object *cdr);
+Scheme_Object *(*scheme_make_raw_pair)(Scheme_Object *, Scheme_Object *);
 Scheme_Object *(*scheme_make_byte_string)(const char *chars);
 Scheme_Object *(*scheme_make_sized_byte_string)(char *chars, long len, int copy);
 Scheme_Object *(*scheme_make_sized_offset_byte_string)(char *chars, long d, long len, int copy);

src/mzscheme/src/schemex.inc

@@ -106,6 +106,7 @@
   scheme_extension_table->scheme_multiple_values = scheme_multiple_values;
   scheme_extension_table->scheme_uchar_table = scheme_uchar_table;
   scheme_extension_table->scheme_uchar_cases_table = scheme_uchar_cases_table;
+  scheme_extension_table->scheme_uchar_cats_table = scheme_uchar_cats_table;
   scheme_extension_table->scheme_uchar_ups = scheme_uchar_ups;
   scheme_extension_table->scheme_uchar_downs = scheme_uchar_downs;
   scheme_extension_table->scheme_uchar_titles = scheme_uchar_titles;
@@ -224,6 +225,7 @@
   scheme_extension_table->scheme_prim_is_method = scheme_prim_is_method;
   scheme_extension_table->scheme_make_pair = scheme_make_pair;
   scheme_extension_table->scheme_make_immutable_pair = scheme_make_immutable_pair;
+  scheme_extension_table->scheme_make_raw_pair = scheme_make_raw_pair;
   scheme_extension_table->scheme_make_byte_string = scheme_make_byte_string;
   scheme_extension_table->scheme_make_sized_byte_string = scheme_make_sized_byte_string;
   scheme_extension_table->scheme_make_sized_offset_byte_string = scheme_make_sized_offset_byte_string;

src/mzscheme/src/schemexm.h

@@ -106,6 +106,7 @@
 #define scheme_multiple_values (scheme_extension_table->scheme_multiple_values)
 #define scheme_uchar_table (scheme_extension_table->scheme_uchar_table)
 #define scheme_uchar_cases_table (scheme_extension_table->scheme_uchar_cases_table)
+#define scheme_uchar_cats_table (scheme_extension_table->scheme_uchar_cats_table)
 #define scheme_uchar_ups (scheme_extension_table->scheme_uchar_ups)
 #define scheme_uchar_downs (scheme_extension_table->scheme_uchar_downs)
 #define scheme_uchar_titles (scheme_extension_table->scheme_uchar_titles)
@@ -224,6 +225,7 @@
 #define scheme_prim_is_method (scheme_extension_table->scheme_prim_is_method)
 #define scheme_make_pair (scheme_extension_table->scheme_make_pair)
 #define scheme_make_immutable_pair (scheme_extension_table->scheme_make_immutable_pair)
+#define scheme_make_raw_pair (scheme_extension_table->scheme_make_raw_pair)
 #define scheme_make_byte_string (scheme_extension_table->scheme_make_byte_string)
 #define scheme_make_sized_byte_string (scheme_extension_table->scheme_make_sized_byte_string)
 #define scheme_make_sized_offset_byte_string (scheme_extension_table->scheme_make_sized_offset_byte_string)

src/mzscheme/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 861
+#define EXPECTED_PRIM_COUNT 862
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

src/mzscheme/src/schpriv.h

@@ -587,8 +587,11 @@ Scheme_Object *scheme_make_module_rename(long phase, int kind, Scheme_Hash_Table
 void scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *modname,
 				 Scheme_Object *locname, Scheme_Object *exname,
 				 Scheme_Object *nominal_src, Scheme_Object *nominal_ex,
-				 int mod_phase);
+				 int mod_phase, int drop_for_marshal);
 void scheme_extend_module_rename_with_kernel(Scheme_Object *rn, Scheme_Object *nominal_src);
+void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info);
+void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
+				       Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to);
 void scheme_remove_module_rename(Scheme_Object *mrn,
 				 Scheme_Object *localname);
 void scheme_append_module_rename(Scheme_Object *src, Scheme_Object *dest);
@@ -754,6 +757,13 @@ typedef struct Scheme_Toplevel {
 /* MUTATED and READY flags are used in different contexts */
 #define SCHEME_TOPLEVEL_FLAGS_MASK 0x3
 
+typedef struct Scheme_Quote_Syntax {
+  Scheme_Object so; /* scheme_quote_syntax_type */
+  mzshort depth;
+  mzshort position;
+  mzshort midpoint;
+} Scheme_Quote_Syntax;
+
 typedef struct Scheme_Let_Value {
   Scheme_Inclhash_Object iso; /* keyex used for autobox */
   mzshort count;
@@ -1721,10 +1731,9 @@ int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env);
 #define BOXVAL_EXPD        6
 #define MODULE_EXPD        7
 #define REQUIRE_EXPD       8
-#define QUOTE_SYNTAX_EXPD  9
+#define DEFINE_FOR_SYNTAX_EXPD 9
-#define DEFINE_FOR_SYNTAX_EXPD 10
+#define REF_EXPD           10
-#define REF_EXPD           11
+#define _COUNT_EXPD_       11
-#define _COUNT_EXPD_       12
 
 #define scheme_register_syntax(i, fo, fr, fv, fe, fj, cl, pa) \
      (scheme_syntax_optimizers[i] = fo, \
@@ -1963,9 +1972,6 @@ void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
 			      int num_toplevels, int num_stxes);
 void scheme_validate_boxenv(int pos, Mz_CPort *port,
 			    char *stack, int depth, int delta);
-void scheme_validate_quote_syntax(int c, int p, int z, Mz_CPort *port,
-				  char *stack, int depth, int delta,
-				  int num_toplevels, int num_stxes);
 
 #define TRACK_ILL_FORMED_CATCH_LINES 0
 #if TRACK_ILL_FORMED_CATCH_LINES

src/mzscheme/src/schvers.h

@@ -9,6 +9,6 @@
 
 
 #define MZSCHEME_VERSION_MAJOR 301
-#define MZSCHEME_VERSION_MINOR 11
+#define MZSCHEME_VERSION_MINOR 12
 
-#define MZSCHEME_VERSION "301.11" _MZ_SPECIAL_TAG
+#define MZSCHEME_VERSION "301.12" _MZ_SPECIAL_TAG

src/mzscheme/src/stxobj.c

@@ -104,7 +104,7 @@ static void preemptive_chunk(Scheme_Stx *stx);
 
 typedef struct Module_Renames {
   Scheme_Object so; /* scheme_rename_table_type */
-  char plus_kernel, kind;
+  char plus_kernel, kind, needs_unmarshal;
   long phase;
   Scheme_Object *plus_kernel_nominal_source;
   Scheme_Hash_Table *ht; /* localname ->  modidx  OR
@@ -112,9 +112,12 @@ typedef struct Module_Renames {
                                           (cons-immutable modidx nominal_modidx) OR
                                           (list* modidx exportname nominal_modidx nominal_exportname) OR
                                           (list* modidx mod-phase exportname nominal_modidx nominal_exportname) */
+  Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */
   Scheme_Hash_Table *marked_names; /* shared with module environment while compiling the module;
 				      this table maps a top-level-bound identifier with a non-empty mark
 				      set to a gensym created for the binding */
+  Scheme_Object *unmarshal_info; /* stores some renamings as infomation needed to consult
+				    imported modules and restore renames from their exports */
 } Module_Renames;
 
 typedef struct Scheme_Cert {
@@ -141,8 +144,8 @@ typedef struct Scheme_Cert {
             maybe inactive certs in nested parts
     - cons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL); 
                     no inactive certs in nested parts */
-#define ACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_PAIRP((stx)->certs) ? SCHEME_CAR((stx)->certs) : (stx)->certs) : NULL))
+#define ACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CAR((stx)->certs) : (stx)->certs) : NULL))
-#define INACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_PAIRP((stx)->certs) ? SCHEME_CDR((stx)->certs) : NULL) : NULL))
+#define INACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CDR((stx)->certs) : NULL) : NULL))
 static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Scheme_Hash_Table **ht);
 
 #define SCHEME_RENAME_LEN(vec)  ((SCHEME_VEC_SIZE(vec) - 2) >> 1)
@@ -210,6 +213,7 @@ static Module_Renames *krn;
   to sub-syntax.  */
 
 #define IS_POSMARK(x) (SCHEME_INTP(x) ? (SCHEME_INT_VAL(x) >= 0) : SCHEME_BIGPOS(x))
+#define SCHEME_MARKP(x) (SCHEME_INTP(x) || SCHEME_BIGNUMP(x))
 
 /*========================================================================*/
 /*                            wrap chunks                                 */
@@ -509,7 +513,7 @@ void scheme_init_stx(Scheme_Env *env)
   REGISTER_SO(than_id_marks_ht);
 
   REGISTER_SO(no_nested_inactive_certs);
-  no_nested_inactive_certs = scheme_make_pair(NULL, NULL);
+  no_nested_inactive_certs = scheme_make_raw_pair(NULL, NULL);
 }
 
 /*========================================================================*/
@@ -1061,6 +1065,7 @@ Scheme_Object *scheme_make_module_rename(long phase, int kind, Scheme_Hash_Table
   mr->phase = phase;
   mr->kind = kind;
   mr->marked_names = marked_names;
+  mr->unmarshal_info = scheme_null;
 
   if (!krn) {
     REGISTER_SO(krn);
@@ -1084,7 +1089,8 @@ void scheme_extend_module_rename(Scheme_Object *mrn,
 				 Scheme_Object *exname,      /* name in definition context  */
 				 Scheme_Object *nominal_mod, /* nominal source module */
 				 Scheme_Object *nominal_ex,  /* nominal import before local renaming */
-				 int mod_phase)              /* phase of source defn */
+				 int mod_phase,              /* phase of source defn */
+				 int unmarshal_drop)         /* 1 => can be reconstructed from unmarshal info */
 {
   Scheme_Object *elem;
 
@@ -1115,23 +1121,53 @@ void scheme_extend_module_rename(Scheme_Object *mrn,
     elem = CONS(modname, elem);
   }
   
+  if (unmarshal_drop) {
+    if (!((Module_Renames *)mrn)->nomarshal_ht) {
+      Scheme_Hash_Table *ht;
+      ht = scheme_make_hash_table(SCHEME_hash_ptr);
+      ((Module_Renames *)mrn)->nomarshal_ht = ht;
+    }
+    scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, elem);
+  } else
     scheme_hash_set(((Module_Renames *)mrn)->ht, localname, elem);
 }
 
+void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info)
+{
+  Scheme_Object *l;
+
+  l = scheme_make_pair(info, ((Module_Renames *)rn)->unmarshal_info);
+  ((Module_Renames *)rn)->unmarshal_info = l;
+}
+
 static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest,
 				    Scheme_Object *old_midx, Scheme_Object *new_midx)
 {
-  Scheme_Hash_Table *ht, *hts;
+  Scheme_Hash_Table *ht, *hts, *drop_ht;
   Scheme_Object *v;
-  int i;
+  int i, t;
 
   if (((Module_Renames *)src)->plus_kernel) {
     ((Module_Renames *)dest)->plus_kernel = 1;
     ((Module_Renames *)dest)->plus_kernel_nominal_source = ((Module_Renames *)src)->plus_kernel_nominal_source;
   }
 
+  for (t = 0; t < 2; t++) {
+    if (!t) {
       ht = ((Module_Renames *)dest)->ht;
       hts = ((Module_Renames *)src)->ht;
+      drop_ht = ((Module_Renames *)dest)->nomarshal_ht;
+    } else {
+      hts = ((Module_Renames *)src)->nomarshal_ht;
+      if (!hts)
+	break;
+      ht = ((Module_Renames *)dest)->nomarshal_ht;
+      if (!ht) {
+	ht = scheme_make_hash_table(SCHEME_hash_ptr);
+	((Module_Renames *)dest)->nomarshal_ht = ht;
+      }
+      drop_ht = ((Module_Renames *)dest)->ht;
+    }
   
     /* Mappings in src overwrite mappings in dest: */
 
@@ -1174,6 +1210,9 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest,
 	  }
 	}
 	scheme_hash_set(ht, hts->keys[i], v);
+	if (drop_ht)
+	  scheme_hash_set(drop_ht, hts->keys[i], NULL);
+      }
     }
   }
 
@@ -1204,21 +1243,31 @@ void scheme_remove_module_rename(Scheme_Object *mrn,
 				 Scheme_Object *localname)
 {
   scheme_hash_set(((Module_Renames *)mrn)->ht, localname, NULL);
+  if (((Module_Renames *)mrn)->nomarshal_ht)
+    scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, NULL);
 }
 
 void scheme_list_module_rename(Scheme_Object *src, Scheme_Hash_Table *ht)
 {
   /* Put every name mapped by src into ht: */
   Scheme_Hash_Table *hts;
-  int i;
+  int i, t;
 
+  for (t = 0; t < 2; t++) {
+    if (!t)
       hts = ((Module_Renames *)src)->ht;
+    else {
+      hts = ((Module_Renames *)src)->nomarshal_ht;
+      if (!hts)
+	break;
+    }
    
     for (i = hts->size; i--; ) {
       if (hts->vals[i]) {
 	scheme_hash_set(ht, hts->keys[i], scheme_false);
       }
     }
+  }
 
   if (((Module_Renames *)src)->plus_kernel) {
     scheme_list_module_rename((Scheme_Object *)krn, ht);
@@ -1243,9 +1292,23 @@ Scheme_Object *scheme_stx_to_rename(Scheme_Object *stx)
 Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn, 
 				       Scheme_Object *old_midx, Scheme_Object *new_midx)
 {
-  Scheme_Object *nmrn;
+  Scheme_Object *nmrn, *a, *l, *nl;
+
   nmrn = scheme_make_module_rename(0, mzMOD_RENAME_NORMAL, NULL);
   do_append_module_rename(mrn, nmrn, old_midx, new_midx);
+
+  /* Shift each mark_info: */
+  l = ((Module_Renames *)mrn)->unmarshal_info;
+  nl = scheme_null;
+  while (!SCHEME_NULLP(l)) {
+    a = SCHEME_CAR(l);
+    nl = scheme_make_pair(scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(a), old_midx, new_midx),
+					   SCHEME_CDR(a)),
+			  nl);
+    l = SCHEME_CDR(l);
+  }
+  ((Module_Renames *)nmrn)->unmarshal_info = nl;
+
   return nmrn;
 }
 
@@ -1254,6 +1317,18 @@ Scheme_Hash_Table *scheme_module_rename_marked_names(Scheme_Object *rn)
   return ((Module_Renames *)rn)->marked_names;
 }
 
+static void unmarshal_rename(Module_Renames *mrn,
+			     Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to)
+{
+  Scheme_Object *l;
+
+  mrn->needs_unmarshal = 0;
+  for (l = mrn->unmarshal_info; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
+    scheme_do_module_rename_unmarshal((Scheme_Object *)mrn, SCHEME_CAR(l),
+				      modidx_shift_from, modidx_shift_to);
+  }
+}
+
 /******************** wrap manipulations ********************/
 
 Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename)
@@ -1436,7 +1511,7 @@ static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int
     }
 
     if (icerts) {
-      nc = scheme_make_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts);
+      nc = scheme_make_raw_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts);
     } else
       nc = (Scheme_Object *)acerts;
 
@@ -1788,7 +1863,7 @@ static void make_mapped(Scheme_Cert *cert)
 
   ht = scheme_make_hash_table_equal();
 
-  pr = scheme_make_pair((Scheme_Object *)ht, (Scheme_Object *)stop);
+  pr = scheme_make_raw_pair((Scheme_Object *)ht, (Scheme_Object *)stop);
   cert->mapped = pr;
 
   for (; cert != stop; cert = cert->next) {
@@ -1855,7 +1930,7 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
       if (active)
 	res->certs = (Scheme_Object *)certs;
       else {
-	pr = scheme_make_pair(NULL, (Scheme_Object *)certs);
+	pr = scheme_make_raw_pair(NULL, (Scheme_Object *)certs);
 	res->certs = pr;
       }
       return (Scheme_Object *)res;
@@ -1878,10 +1953,10 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
 	res->wraps = stx->wraps;
 	res->u.lazy_prefix = stx->u.lazy_prefix;
 	if (!active) {
-	  pr = scheme_make_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)orig_certs);
+	  pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)orig_certs);
 	  res->certs = pr;
-	} else if (stx->certs && SCHEME_PAIRP(stx->certs)) {
+	} else if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
-	  pr = scheme_make_pair((Scheme_Object *)orig_certs, SCHEME_CDR(stx->certs));
+	  pr = scheme_make_raw_pair((Scheme_Object *)orig_certs, SCHEME_CDR(stx->certs));
 	  res->certs = pr;
 	} else
 	  res->certs = (Scheme_Object *)orig_certs;
@@ -1893,7 +1968,7 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
       now_certs = cl;
       if (!active) {
 	SCHEME_CDR(stx->certs) = (Scheme_Object *)cl;
-      } else if (stx->certs && SCHEME_PAIRP(stx->certs))
+      } else if (stx->certs && SCHEME_RPAIRP(stx->certs))
 	SCHEME_CAR(stx->certs) = (Scheme_Object *)cl;
       else
 	stx->certs = (Scheme_Object *)cl;
@@ -1977,15 +2052,15 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
 		     menv->module->insp, key, cert);
 
     if (active) {
-      if (stx->certs && SCHEME_PAIRP(stx->certs)) {
+      if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
 	Scheme_Object *pr;
-	pr = scheme_make_pair((Scheme_Object *)cert, SCHEME_CDR(stx->certs));
+	pr = scheme_make_raw_pair((Scheme_Object *)cert, SCHEME_CDR(stx->certs));
 	res->certs = pr;
       } else
 	res->certs = (Scheme_Object *)cert;
     } else {
       Scheme_Object *pr;
-      pr = scheme_make_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)cert);
+      pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)cert);
       res->certs = pr;
     }
     
@@ -2250,7 +2325,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
 					  stx->props);
       res->wraps = stx->wraps;
       res->u.lazy_prefix = stx->u.lazy_prefix;
-      np = scheme_make_pair(SCHEME_CAR(stx->certs), NULL);
+      np = scheme_make_raw_pair(SCHEME_CAR(stx->certs), NULL);
       res->certs = np;
 
       cc = *cp;
@@ -2261,7 +2336,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
       *cp = cc;
 
       return (Scheme_Object *)res;
-    } else if (stx->certs && SCHEME_PAIRP(stx->certs)) {
+    } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
       /* Explicit pair but NULL for inactive certs means no
 	 inactive certs anywhere in this object. */
       return (Scheme_Object *)stx;
@@ -2312,7 +2387,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
 	   that there are no nested certs here */
 	if (stx->certs) {
 	  Scheme_Object *np;
-	  np = scheme_make_pair(stx->certs, NULL);
+	  np = scheme_make_raw_pair(stx->certs, NULL);
 	  res->certs = np;
 	} else
 	  res->certs = no_nested_inactive_certs;
@@ -2327,7 +2402,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
 	/* Record the absence of certificates in sub-parts: */
 	if (stx->certs) {
 	  Scheme_Object *np;
-	  np = scheme_make_pair(stx->certs, NULL);
+	  np = scheme_make_raw_pair(stx->certs, NULL);
 	  stx->certs = np;
 	} else
 	  stx->certs = no_nested_inactive_certs;
@@ -2609,12 +2684,17 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
 	if (phase == mrn->phase) {
 	  Scheme_Object *rename, *nominal = NULL, *glob_id;
 
+	  if (mrn->needs_unmarshal)
+	    unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to);
+	  
 	  if (mrn->marked_names)
 	    glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, 0);
 	  else
 	    glob_id = SCHEME_STX_VAL(a);
 
 	  rename = scheme_hash_get(mrn->ht, glob_id);
+	  if (!rename && mrn->nomarshal_ht)
+	    rename = scheme_hash_get(mrn->nomarshal_ht, glob_id);
 	  if (!rename && mrn->plus_kernel) {
 	    rename = scheme_hash_get(krn->ht, glob_id);
 	    nominal = mrn->plus_kernel_nominal_source;
@@ -2841,6 +2921,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, long phase)
   WRAP_POS wraps;
   Scheme_Object *result;
   int is_in_module = 0, skip_other_mods = 0;
+  long orig_phase = phase;
 
   if (((Scheme_Stx *)a)->u.modinfo_cache)
     return ((Scheme_Stx *)a)->u.modinfo_cache;
@@ -2868,12 +2949,20 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, long phase)
 	  /* Module rename: */
 	  Scheme_Object *rename, *glob_id;
 
+	  if (mrn->needs_unmarshal) {
+	    /* Use resolve_env to trigger unmarshal, so that we
+	       don't have to implement top/from shifts here: */
+	    resolve_env(a, orig_phase, 1, NULL, NULL);
+	  }
+
 	  if (mrn->marked_names)
 	    glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, 0);
 	  else
 	    glob_id = SCHEME_STX_VAL(a);
 
 	  rename = scheme_hash_get(mrn->ht, glob_id);
+	  if (!rename && mrn->nomarshal_ht)
+	    rename = scheme_hash_get(mrn->nomarshal_ht, glob_id);
 	  if (!rename && mrn->plus_kernel)
 	    rename = scheme_hash_get(krn->ht, glob_id);
 	  
@@ -3715,10 +3804,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
 	      int i, j, count = 0;
 	      Scheme_Object *l, *idi;
 	    
-	      for (i = mrn->ht->size; i--; ) {
+	      count = mrn->ht->mcount;
-		if (mrn->ht->vals[i])
-		  count++;
-	      }
 
 	      l = scheme_make_vector(count * 2, NULL);
 	    
@@ -3761,6 +3847,9 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
 	      } else
 		l = CONS(l, scheme_null);
 
+	      if (SCHEME_PAIRP(mrn->unmarshal_info))
+		l = CONS(mrn->unmarshal_info, l); 
+	      
 	      l = CONS((mrn->kind == mzMOD_RENAME_MARKED) ? scheme_true : scheme_false, l);
 	      l = CONS(scheme_make_integer(mrn->phase), l);
 	      if (mrn->plus_kernel) {
@@ -4204,8 +4293,8 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
       scheme_hash_set(rns, local_key, a);
     } else if (SCHEME_PAIRP(a)) {
       /* A rename table:
-           - ([#t] <index-num> <bool> <phase-num> #(<table-elem> ...) 
+           - ([#t] <index-num> <phase-num> <bool> [unmarshal] #(<table-elem> ...) 
-	       . ((<sym> (<marked-list> . <target-gensym>) ...) ...)) ; <- marked_names
+	       . ((<sym> (<marked-list-or-mark> . <target-gensym>) ...) ...)) ; <- marked_names
 	where a <table-elem> is actually two values, one of:
            - <exname> <modname>
            - <exname> (<modname> . <defname>)
@@ -4248,6 +4337,46 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
       mns = SCHEME_CDR(a);
       a = SCHEME_CAR(a);
 
+      if (!SCHEME_VECTORP(a)) {
+	/* Unmarshall info: */
+	Scheme_Object *ml = a, *mli;
+	while (SCHEME_PAIRP(ml)) {
+	  mli = SCHEME_CAR(ml);
+	  if (!SCHEME_PAIRP(mli)) return NULL;
+
+	  /* A module path index: */
+	  p = SCHEME_CAR(mli);
+	  if (!(SCHEME_SYMBOLP(p)
+		|| SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)))
+	    return NULL;
+
+	  mli = SCHEME_CDR(mli);
+	  if (!SCHEME_PAIRP(mli)) return NULL;
+	  /* A list of symbols: */
+	  p = SCHEME_CAR(mli);
+	  while (SCHEME_PAIRP(p)) {
+	    if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) return NULL;
+	    p = SCHEME_CDR(p);
+	  }
+	  if (!SCHEME_NULLP(p)) return NULL;
+
+	  /* #f or a symbol: */
+	  p = SCHEME_CDR(mli);
+	  if (!SCHEME_SYMBOLP(p) && !SCHEME_FALSEP(p)) return NULL;
+
+	  ml = SCHEME_CDR(ml);
+	}
+	if (!SCHEME_NULLP(ml)) return NULL;
+
+	mrn->unmarshal_info = a;
+	if (SCHEME_PAIRP(a))
+	  mrn->needs_unmarshal = 1;
+
+	if (!SCHEME_PAIRP(mns)) return NULL;
+	a = SCHEME_CAR(mns);
+	mns = SCHEME_CDR(mns);
+      }
+
       if (!SCHEME_VECTORP(a)) return_NULL;
       count = SCHEME_VEC_SIZE(a);
       if (count & 0x1) return_NULL;
@@ -4312,7 +4441,11 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
 
 	    kfirst = scheme_null;
 	    klast = NULL;
-	    for (a = SCHEME_CAR(a); SCHEME_PAIRP(a); a = SCHEME_CDR(a)) {
+	    a = SCHEME_CAR(a);
+	    if (SCHEME_MARKP(a)) {
+	      kfirst = unmarshal_mark(a, rns);
+	    } else {
+	      for (; SCHEME_PAIRP(a); a = SCHEME_CDR(a)) {
 		kp = CONS(unmarshal_mark(SCHEME_CAR(a), rns), scheme_null);
 		if (!klast)
 		  kfirst = kp;
@@ -4321,6 +4454,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
 		klast = kp;
 	      }
 	      if (!SCHEME_NULLP(a)) return_NULL;
+	    }
 
 	    ll = CONS(CONS(kfirst, kkey), ll);
 	  }
@@ -4618,7 +4752,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
       Scheme_Object *icerts;
       certs = cert_marks_to_certs(SCHEME_CAR(cert_marks), stx_wraps, &bad);
       icerts = cert_marks_to_certs(SCHEME_CDR(cert_marks), stx_wraps, &bad);
-      certs = scheme_make_pair(certs, icerts);
+      certs = scheme_make_raw_pair(certs, icerts);
     } else {
       /* Just active certs */
       certs = cert_marks_to_certs(cert_marks, stx_wraps, &bad);
@@ -4821,9 +4955,9 @@ static void simplify_syntax_inner(Scheme_Object *o,
 	  }
 	}
 	if (!i) {
-	  if (SCHEME_PAIRP(stx->certs)) {
+	  if (SCHEME_RPAIRP(stx->certs)) {
 	    Scheme_Object *pr;
-	    pr = scheme_make_pair((Scheme_Object *)result, SCHEME_CDR(stx->certs));
+	    pr = scheme_make_raw_pair((Scheme_Object *)result, SCHEME_CDR(stx->certs));
 	    stx->certs = pr;
 	  } else
 	    stx->certs = (Scheme_Object *)result;
@@ -4832,7 +4966,7 @@ static void simplify_syntax_inner(Scheme_Object *o,
 	    stx->certs = SCHEME_CAR(stx->certs);
 	  else {
 	    Scheme_Object *pr;
-	    pr = scheme_make_pair(SCHEME_CAR(stx->certs), (Scheme_Object *)result);
+	    pr = scheme_make_raw_pair(SCHEME_CAR(stx->certs), (Scheme_Object *)result);
 	    stx->certs = pr;
 	  }
 	}
@@ -5464,14 +5598,14 @@ static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv)
 	res->wraps = stx->wraps;
 	res->u.lazy_prefix = stx->u.lazy_prefix;
 
-	if (!i && (!stx->certs || !SCHEME_PAIRP(stx->certs) || !SCHEME_CDR(stx->certs)))
+	if (!i && (!stx->certs || !SCHEME_RPAIRP(stx->certs) || !SCHEME_CDR(stx->certs)))
 	  res->certs = (Scheme_Object *)new_certs;
 	else {
 	  Scheme_Object *pr;
 	  if (!i)
-	    pr = scheme_make_pair((Scheme_Object *)new_certs, SCHEME_CDR(stx->certs));
+	    pr = scheme_make_raw_pair((Scheme_Object *)new_certs, SCHEME_CDR(stx->certs));
 	  else
-	    pr = scheme_make_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)new_certs);
+	    pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)new_certs);
 	  res->certs = pr;
 	}
       

src/mzscheme/src/stypes.h

@@ -17,202 +17,204 @@ enum {
   scheme_letrec_type,                   /* 12 */
   scheme_let_one_type,                  /* 13 */
   scheme_with_cont_mark_type,           /* 14 */
+  scheme_quote_syntax_type,             /* 15 */
 
   _scheme_values_types_, /* All following types are values */
   
   /* intermediate compiled: */
-  scheme_compiled_unclosed_procedure_type,/* 16 */
+  scheme_compiled_unclosed_procedure_type,/* 17 */
-  scheme_compiled_let_value_type,       /* 17 */
+  scheme_compiled_let_value_type,       /* 18 */
-  scheme_compiled_let_void_type,        /* 18 */
+  scheme_compiled_let_void_type,        /* 19 */
-  scheme_compiled_syntax_type,          /* 19 */
+  scheme_compiled_syntax_type,          /* 20 */
-  scheme_compiled_toplevel_type,        /* 20 */
+  scheme_compiled_toplevel_type,        /* 21 */
-  scheme_compiled_quote_syntax_type,    /* 21 */
+  scheme_compiled_quote_syntax_type,    /* 22 */
 
   scheme_quote_compilation_type, /* used while writing, only */
 
   /* Registered in prefix table: */
-  scheme_variable_type,                 /* 23 */
+  scheme_variable_type,                 /* 24 */
   scheme_module_variable_type, /* link replaces with scheme_variable_type */
 
-  _scheme_compiled_values_types_,       /* 25 */
+  _scheme_compiled_values_types_,       /* 26 */
 
   /* procedure types */
-  scheme_prim_type,                     /* 26 */
+  scheme_prim_type,                     /* 27 */
-  scheme_closed_prim_type,              /* 27 */
+  scheme_closed_prim_type,              /* 28 */
-  scheme_closure_type,                  /* 28 */
+  scheme_closure_type,                  /* 29 */
-  scheme_case_closure_type,             /* 29 */
+  scheme_case_closure_type,             /* 30 */
-  scheme_cont_type,                     /* 30 */
+  scheme_cont_type,                     /* 31 */
-  scheme_escaping_cont_type,            /* 31 */
+  scheme_escaping_cont_type,            /* 32 */
-  scheme_proc_struct_type,              /* 32 */
+  scheme_proc_struct_type,              /* 33 */
-  scheme_native_closure_type,           /* 33 */
+  scheme_native_closure_type,           /* 34 */
 
   /* structure types (overlaps with procs) */
-  scheme_structure_type,                /* 34 */
+  scheme_structure_type,                /* 35 */
 
   /* basic types */
-  scheme_char_type,                     /* 35 */
+  scheme_char_type,                     /* 36 */
-  scheme_integer_type,                  /* 36 */
+  scheme_integer_type,                  /* 37 */
-  scheme_bignum_type,                   /* 37 */
+  scheme_bignum_type,                   /* 38 */
-  scheme_rational_type,                 /* 38 */
+  scheme_rational_type,                 /* 39 */
-  scheme_float_type,                    /* 39 */
+  scheme_float_type,                    /* 40 */
-  scheme_double_type,                   /* 40 */
+  scheme_double_type,                   /* 41 */
-  scheme_complex_izi_type,              /* 41 */
+  scheme_complex_izi_type,              /* 42 */
-  scheme_complex_type,                  /* 42 */
+  scheme_complex_type,                  /* 43 */
-  scheme_char_string_type,              /* 43 */
+  scheme_char_string_type,              /* 44 */
-  scheme_byte_string_type,              /* 44 */
+  scheme_byte_string_type,              /* 45 */
-  scheme_path_type,                     /* 45 */
+  scheme_path_type,                     /* 46 */
-  scheme_symbol_type,                   /* 46 */
+  scheme_symbol_type,                   /* 47 */
-  scheme_keyword_type,                  /* 47 */
+  scheme_keyword_type,                  /* 48 */
-  scheme_null_type,                     /* 48 */
+  scheme_null_type,                     /* 49 */
-  scheme_pair_type,                     /* 49 */
+  scheme_pair_type,                     /* 50 */
-  scheme_vector_type,                   /* 50 */
+  scheme_vector_type,                   /* 51 */
-  scheme_inspector_type,                /* 51 */
+  scheme_inspector_type,                /* 52 */
-  scheme_input_port_type,               /* 52 */
+  scheme_input_port_type,               /* 53 */
-  scheme_output_port_type,              /* 53 */
+  scheme_output_port_type,              /* 54 */
-  scheme_eof_type,                      /* 54 */
+  scheme_eof_type,                      /* 55 */
-  scheme_true_type,                     /* 55 */
+  scheme_true_type,                     /* 56 */
-  scheme_false_type,                    /* 56 */
+  scheme_false_type,                    /* 57 */
-  scheme_void_type,                     /* 57 */
+  scheme_void_type,                     /* 58 */
-  scheme_syntax_compiler_type,          /* 58 */
+  scheme_syntax_compiler_type,          /* 59 */
-  scheme_macro_type,                    /* 59 */
+  scheme_macro_type,                    /* 60 */
-  scheme_box_type,                      /* 60 */
+  scheme_box_type,                      /* 61 */
-  scheme_thread_type,                   /* 61 */
+  scheme_thread_type,                   /* 62 */
-  scheme_stx_offset_type,               /* 62 */
+  scheme_stx_offset_type,               /* 63 */
-  scheme_cont_mark_set_type,            /* 63 */
+  scheme_cont_mark_set_type,            /* 64 */
-  scheme_sema_type,                     /* 64 */
+  scheme_sema_type,                     /* 65 */
-  scheme_hash_table_type,               /* 65 */
+  scheme_hash_table_type,               /* 66 */
-  scheme_cpointer_type,                 /* 66 */
+  scheme_cpointer_type,                 /* 67 */
-  scheme_weak_box_type,                 /* 67 */
+  scheme_weak_box_type,                 /* 68 */
-  scheme_ephemeron_type,                /* 68 */
+  scheme_ephemeron_type,                /* 69 */
-  scheme_struct_type_type,              /* 69 */
+  scheme_struct_type_type,              /* 70 */
-  scheme_module_index_type,             /* 70 */
+  scheme_module_index_type,             /* 71 */
-  scheme_set_macro_type,                /* 71 */
+  scheme_set_macro_type,                /* 72 */
-  scheme_listener_type,                 /* 72 */
+  scheme_listener_type,                 /* 73 */
-  scheme_namespace_type,                /* 73 */
+  scheme_namespace_type,                /* 74 */
-  scheme_config_type,                   /* 74 */
+  scheme_config_type,                   /* 75 */
-  scheme_stx_type,                      /* 75 */
+  scheme_stx_type,                      /* 76 */
-  scheme_will_executor_type,            /* 76 */
+  scheme_will_executor_type,            /* 77 */
-  scheme_custodian_type,                /* 77 */
+  scheme_custodian_type,                /* 78 */
-  scheme_random_state_type,             /* 78 */
+  scheme_random_state_type,             /* 79 */
-  scheme_regexp_type,                   /* 79 */
+  scheme_regexp_type,                   /* 80 */
-  scheme_bucket_type,                   /* 80 */
+  scheme_bucket_type,                   /* 81 */
-  scheme_bucket_table_type,             /* 81 */
+  scheme_bucket_table_type,             /* 82 */
-  scheme_subprocess_type,               /* 82 */
+  scheme_subprocess_type,               /* 83 */
-  scheme_compilation_top_type,          /* 83 */
+  scheme_compilation_top_type,          /* 84 */
-  scheme_wrap_chunk_type,               /* 84 */
+  scheme_wrap_chunk_type,               /* 85 */
-  scheme_eval_waiting_type,             /* 85 */
+  scheme_eval_waiting_type,             /* 86 */
-  scheme_tail_call_waiting_type,        /* 86 */
+  scheme_tail_call_waiting_type,        /* 87 */
-  scheme_undefined_type,                /* 87 */
+  scheme_undefined_type,                /* 88 */
-  scheme_struct_property_type,          /* 88 */
+  scheme_struct_property_type,          /* 89 */
-  scheme_multiple_values_type,          /* 89 */
+  scheme_multiple_values_type,          /* 90 */
-  scheme_placeholder_type,              /* 90 */
+  scheme_placeholder_type,              /* 91 */
-  scheme_case_lambda_sequence_type,     /* 91 */
+  scheme_case_lambda_sequence_type,     /* 92 */
-  scheme_begin0_sequence_type,          /* 92 */
+  scheme_begin0_sequence_type,          /* 93 */
-  scheme_rename_table_type,             /* 93 */
+  scheme_rename_table_type,             /* 94 */
-  scheme_module_type,                   /* 94 */
+  scheme_module_type,                   /* 95 */
-  scheme_svector_type,                  /* 95 */
+  scheme_svector_type,                  /* 96 */
-  scheme_lazy_macro_type,               /* 96 */
+  scheme_lazy_macro_type,               /* 97 */
-  scheme_resolve_prefix_type,           /* 97 */
+  scheme_resolve_prefix_type,           /* 98 */
-  scheme_security_guard_type,           /* 98 */
+  scheme_security_guard_type,           /* 99 */
-  scheme_indent_type,                   /* 99 */
+  scheme_indent_type,                   /* 100 */
-  scheme_udp_type,                      /* 100 */
+  scheme_udp_type,                      /* 101 */
-  scheme_udp_evt_type,                  /* 101 */
+  scheme_udp_evt_type,                  /* 102 */
-  scheme_tcp_accept_evt_type,           /* 102 */
+  scheme_tcp_accept_evt_type,           /* 103 */
-  scheme_id_macro_type,                 /* 103 */
+  scheme_id_macro_type,                 /* 104 */
-  scheme_evt_set_type,                  /* 104 */
+  scheme_evt_set_type,                  /* 105 */
-  scheme_wrap_evt_type,                 /* 105 */
+  scheme_wrap_evt_type,                 /* 106 */
-  scheme_handle_evt_type,               /* 106 */
+  scheme_handle_evt_type,               /* 107 */
-  scheme_nack_guard_evt_type,           /* 107 */
+  scheme_nack_guard_evt_type,           /* 108 */
-  scheme_semaphore_repost_type,         /* 108 */
+  scheme_semaphore_repost_type,         /* 109 */
-  scheme_channel_type,                  /* 109 */
+  scheme_channel_type,                  /* 110 */
-  scheme_channel_put_type,              /* 110 */
+  scheme_channel_put_type,              /* 111 */
-  scheme_thread_resume_type,            /* 111 */
+  scheme_thread_resume_type,            /* 112 */
-  scheme_thread_suspend_type,           /* 112 */
+  scheme_thread_suspend_type,           /* 113 */
-  scheme_thread_dead_type,              /* 113 */
+  scheme_thread_dead_type,              /* 114 */
-  scheme_poll_evt_type,                 /* 114 */
+  scheme_poll_evt_type,                 /* 115 */
-  scheme_nack_evt_type,                 /* 115 */
+  scheme_nack_evt_type,                 /* 116 */
-  scheme_module_registry_type,          /* 116 */
+  scheme_module_registry_type,          /* 117 */
-  scheme_thread_set_type,               /* 117 */
+  scheme_thread_set_type,               /* 118 */
-  scheme_string_converter_type,         /* 118 */
+  scheme_string_converter_type,         /* 119 */
-  scheme_alarm_type,                    /* 119 */
+  scheme_alarm_type,                    /* 120 */
-  scheme_thread_cell_type,              /* 120 */
+  scheme_thread_cell_type,              /* 121 */
-  scheme_channel_syncer_type,           /* 121 */
+  scheme_channel_syncer_type,           /* 122 */
-  scheme_special_comment_type,          /* 122 */
+  scheme_special_comment_type,          /* 123 */
-  scheme_write_evt_type,                /* 123 */
+  scheme_write_evt_type,                /* 124 */
-  scheme_always_evt_type,               /* 124 */
+  scheme_always_evt_type,               /* 125 */
-  scheme_never_evt_type,                /* 125 */
+  scheme_never_evt_type,                /* 126 */
-  scheme_progress_evt_type,             /* 126 */
+  scheme_progress_evt_type,             /* 127 */
-  scheme_certifications_type,           /* 127 */
+  scheme_certifications_type,           /* 128 */
-  scheme_already_comp_type,             /* 128 */
+  scheme_already_comp_type,             /* 129 */
-  scheme_readtable_type,                /* 129 */
+  scheme_readtable_type,                /* 130 */
-  scheme_intdef_context_type,           /* 130 */
+  scheme_intdef_context_type,           /* 131 */
-  scheme_lexical_rib_type,              /* 131 */
+  scheme_lexical_rib_type,              /* 132 */
-  scheme_thread_cell_values_type,       /* 132 */
+  scheme_thread_cell_values_type,       /* 133 */
-  scheme_global_ref_type,               /* 133 */
+  scheme_global_ref_type,               /* 134 */
-  scheme_cont_mark_chain_type,          /* 134 */
+  scheme_cont_mark_chain_type,          /* 135 */
+  scheme_raw_pair_type,                 /* 136 */
 
 #ifdef MZTAG_REQUIRED
-  _scheme_last_normal_type_,            /* 135 */
+  _scheme_last_normal_type_,            /* 137 */
 
-  scheme_rt_comp_env,                   /* 136 */
+  scheme_rt_comp_env,                   /* 138 */
-  scheme_rt_constant_binding,           /* 137 */
+  scheme_rt_constant_binding,           /* 139 */
-  scheme_rt_resolve_info,               /* 138 */
+  scheme_rt_resolve_info,               /* 140 */
-  scheme_rt_optimize_info,              /* 139 */
+  scheme_rt_optimize_info,              /* 141 */
-  scheme_rt_compile_info,               /* 140 */
+  scheme_rt_compile_info,               /* 142 */
-  scheme_rt_cont_mark,                  /* 141 */
+  scheme_rt_cont_mark,                  /* 143 */
-  scheme_rt_saved_stack,                /* 142 */
+  scheme_rt_saved_stack,                /* 144 */
-  scheme_rt_reply_item,                 /* 143 */
+  scheme_rt_reply_item,                 /* 145 */
-  scheme_rt_closure_info,               /* 144 */
+  scheme_rt_closure_info,               /* 146 */
-  scheme_rt_overflow,                   /* 145 */
+  scheme_rt_overflow,                   /* 147 */
-  scheme_rt_dyn_wind_cell,              /* 146 */
+  scheme_rt_dyn_wind_cell,              /* 148 */
-  scheme_rt_dyn_wind_info,              /* 147 */
+  scheme_rt_dyn_wind_info,              /* 149 */
-  scheme_rt_dyn_wind,                   /* 148 */
+  scheme_rt_dyn_wind,                   /* 150 */
-  scheme_rt_dup_check,                  /* 149 */
+  scheme_rt_dup_check,                  /* 151 */
-  scheme_rt_thread_memory,              /* 150 */
+  scheme_rt_thread_memory,              /* 152 */
-  scheme_rt_input_file,                 /* 151 */
+  scheme_rt_input_file,                 /* 153 */
-  scheme_rt_input_fd,                   /* 152 */
+  scheme_rt_input_fd,                   /* 154 */
-  scheme_rt_oskit_console_input,        /* 153 */
+  scheme_rt_oskit_console_input,        /* 155 */
-  scheme_rt_tested_input_file,          /* 154 */
+  scheme_rt_tested_input_file,          /* 156 */
-  scheme_rt_tested_output_file,         /* 155 */
+  scheme_rt_tested_output_file,         /* 157 */
-  scheme_rt_indexed_string,             /* 156 */
+  scheme_rt_indexed_string,             /* 158 */
-  scheme_rt_output_file,                /* 157 */
+  scheme_rt_output_file,                /* 159 */
-  scheme_rt_load_handler_data,          /* 158 */
+  scheme_rt_load_handler_data,          /* 160 */
-  scheme_rt_pipe,                       /* 159 */
+  scheme_rt_pipe,                       /* 161 */
-  scheme_rt_beos_process,               /* 160 */
+  scheme_rt_beos_process,               /* 162 */
-  scheme_rt_system_child,               /* 161 */
+  scheme_rt_system_child,               /* 163 */
-  scheme_rt_tcp,                        /* 162 */
+  scheme_rt_tcp,                        /* 164 */
-  scheme_rt_write_data,                 /* 163 */
+  scheme_rt_write_data,                 /* 165 */
-  scheme_rt_tcp_select_info,            /* 164 */
+  scheme_rt_tcp_select_info,            /* 166 */
-  scheme_rt_namespace_option,           /* 165 */
+  scheme_rt_namespace_option,           /* 167 */
-  scheme_rt_param_data,                 /* 166 */
+  scheme_rt_param_data,                 /* 168 */
-  scheme_rt_will,                       /* 167 */
+  scheme_rt_will,                       /* 169 */
-  scheme_rt_will_registration,          /* 168 */
+  scheme_rt_will_registration,          /* 170 */
-  scheme_rt_struct_proc_info,           /* 169 */
+  scheme_rt_struct_proc_info,           /* 171 */
-  scheme_rt_linker_name,                /* 170 */
+  scheme_rt_linker_name,                /* 172 */
-  scheme_rt_param_map,                  /* 171 */
+  scheme_rt_param_map,                  /* 173 */
-  scheme_rt_finalization,               /* 172 */
+  scheme_rt_finalization,               /* 174 */
-  scheme_rt_finalizations,              /* 173 */
+  scheme_rt_finalizations,              /* 175 */
-  scheme_rt_cpp_object,                 /* 174 */
+  scheme_rt_cpp_object,                 /* 176 */
-  scheme_rt_cpp_array_object,           /* 175 */
+  scheme_rt_cpp_array_object,           /* 177 */
-  scheme_rt_stack_object,               /* 176 */
+  scheme_rt_stack_object,               /* 178 */
-  scheme_rt_preallocated_object,        /* 177 */
+  scheme_rt_preallocated_object,        /* 179 */
-  scheme_thread_hop_type,               /* 178 */
+  scheme_thread_hop_type,               /* 180 */
-  scheme_rt_srcloc,                     /* 179 */
+  scheme_rt_srcloc,                     /* 181 */
-  scheme_rt_evt,                        /* 180 */
+  scheme_rt_evt,                        /* 182 */
-  scheme_rt_syncing,                    /* 181 */
+  scheme_rt_syncing,                    /* 183 */
-  scheme_rt_comp_prefix,                /* 182 */
+  scheme_rt_comp_prefix,                /* 184 */
-  scheme_rt_user_input,                 /* 183 */
+  scheme_rt_user_input,                 /* 185 */
-  scheme_rt_user_output,                /* 184 */
+  scheme_rt_user_output,                /* 186 */
-  scheme_rt_compact_port,               /* 185 */
+  scheme_rt_compact_port,               /* 187 */
-  scheme_rt_read_special_dw,            /* 186 */
+  scheme_rt_read_special_dw,            /* 188 */
-  scheme_rt_regwork,                    /* 187 */
+  scheme_rt_regwork,                    /* 189 */
-  scheme_rt_buf_holder,                 /* 188 */
+  scheme_rt_buf_holder,                 /* 190 */
-  scheme_rt_parameterization,           /* 189 */
+  scheme_rt_parameterization,           /* 191 */
-  scheme_rt_print_params,               /* 190 */
+  scheme_rt_print_params,               /* 192 */
-  scheme_rt_read_params,                /* 191 */
+  scheme_rt_read_params,                /* 193 */
-  scheme_rt_native_code,                /* 192 */
+  scheme_rt_native_code,                /* 194 */
-  scheme_rt_native_code_plus_case,      /* 193 */
+  scheme_rt_native_code_plus_case,      /* 195 */
-  scheme_rt_jitter_data,                /* 194 */
+  scheme_rt_jitter_data,                /* 196 */
 #endif
 
   _scheme_last_type_

src/mzscheme/src/syntax.c

@@ -101,7 +101,6 @@ static Scheme_Object *define_syntaxes_execute(Scheme_Object *expr);
 static Scheme_Object *define_for_syntaxes_execute(Scheme_Object *expr);
 static Scheme_Object *case_lambda_execute(Scheme_Object *expr);
 static Scheme_Object *begin0_execute(Scheme_Object *data);
-static Scheme_Object *quote_syntax_execute(Scheme_Object *data);
 
 static Scheme_Object *bangboxenv_execute(Scheme_Object *data);
 static Scheme_Object *bangboxvalue_execute(Scheme_Object *data);
@@ -139,8 +138,6 @@ static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stac
 				 int num_toplevels, int num_stxes);
 static void begin0_validate(Scheme_Object *data, Mz_CPort *port, char *stack, int depth, int letlimit, int delta,
 			    int num_toplevels, int num_stxes);
-static void quote_syntax_validate(Scheme_Object *data, Mz_CPort *port, char *stack, int depth, int letlimit, int delta,
-				    int num_toplevels, int num_stxes);
 static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, char *stack, int depth, int letlimit, int delta,
 				int num_toplevels, int num_stxes);
 static void bangboxvalue_validate(Scheme_Object *data, Mz_CPort *port, char *stack, int depth, int letlimit, int delta,
@@ -153,7 +150,6 @@ static Scheme_Object *define_syntaxes_jit(Scheme_Object *expr);
 static Scheme_Object *define_for_syntaxes_jit(Scheme_Object *expr);
 static Scheme_Object *case_lambda_jit(Scheme_Object *expr);
 static Scheme_Object *begin0_jit(Scheme_Object *data);
-static Scheme_Object *quote_syntax_jit(Scheme_Object *data);
 static Scheme_Object *bangboxvalue_jit(Scheme_Object *data);
 
 static Scheme_Object *named_let_syntax (Scheme_Object *form, Scheme_Comp_Env *env, 
@@ -274,10 +270,6 @@ scheme_init_syntax (Scheme_Env *env)
 			 begin0_resolve, begin0_validate,
 			 begin0_execute, begin0_jit, 
 			 begin0_clone, -1);
-  scheme_register_syntax(QUOTE_SYNTAX_EXPD, 
-			 NULL, NULL, quote_syntax_validate,
-			 quote_syntax_execute, quote_syntax_jit, 
-			 NULL, 2);
 
   scheme_register_syntax(BOXENV_EXPD, 
 			 NULL, NULL, bangboxenv_validate,
@@ -3793,44 +3785,6 @@ unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *er
 /*                            quote-syntax                            */
 /**********************************************************************/
 
-static Scheme_Object *
-quote_syntax_execute(Scheme_Object *obj)
-{
-  Scheme_Object **globs, *stx;
-  int i, c, p;
-
-  i = SCHEME_INT_VAL(SCHEME_CAR(obj));
-  c = SCHEME_INT_VAL(SCHEME_CADR(obj));
-  p = SCHEME_INT_VAL(SCHEME_CDDR(obj));
-
-  globs = (Scheme_Object **)MZ_RUNSTACK[c];
-  stx = globs[i+p+1];
-  if (!stx) {
-    stx = globs[p];
-    stx = scheme_add_rename(((Scheme_Object **)SCHEME_CDR(stx))[i], 
-			    SCHEME_CAR(stx));
-    globs[i+p+1] = stx;
-  }
-  return stx;
-}
-
-Scheme_Object *quote_syntax_jit(Scheme_Object *data)
-{
-  return data;
-}
-
-static void quote_syntax_validate(Scheme_Object *obj, Mz_CPort *port, char *stack, 
-				  int depth, int letlimit, int delta, int num_toplevels, int num_stxes)
-{
-  int i, c, p;
-
-  i = SCHEME_INT_VAL(SCHEME_CAR(obj));
-  c = SCHEME_INT_VAL(SCHEME_CADR(obj));
-  p = SCHEME_INT_VAL(SCHEME_CDDR(obj));
-
-  scheme_validate_quote_syntax(c, p, i, port, stack, depth, delta, num_toplevels, num_stxes);
-}
-
 static Scheme_Object *
 quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
 {

src/mzscheme/src/thread.c

@@ -1601,7 +1601,7 @@ static void run_closers(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void
 {
   Scheme_Object *l;
 
-  for (l = closers; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
+  for (l = closers; SCHEME_RPAIRP(l); l = SCHEME_CDR(l)) {
     Scheme_Exit_Closer_Func cf;
     cf = (Scheme_Exit_Closer_Func)SCHEME_CAR(l);
     cf(o, f, data);
@@ -1639,7 +1639,7 @@ void scheme_add_atexit_closer(Scheme_Exit_Closer_Func f)
     closers = scheme_null;
   }
 
-  closers = scheme_make_pair((Scheme_Object *)f, closers);
+  closers = scheme_make_raw_pair((Scheme_Object *)f, closers);
 }
 
 void scheme_schedule_custodian_close(Scheme_Custodian *c)
@@ -2149,7 +2149,7 @@ void scheme_swap_thread(Scheme_Thread *new_thread)
     {
       Scheme_Object *l, *o;
       Scheme_Closure_Func f;
-      for (l = thread_swap_callbacks; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
+      for (l = thread_swap_callbacks; SCHEME_RPAIRP(l); l = SCHEME_CDR(l)) {
 	o = SCHEME_CAR(l);
 	f = SCHEME_CLOS_FUNC(o);
 	o = SCHEME_CLOS_DATA(o);
@@ -2408,7 +2408,7 @@ static void start_child(Scheme_Thread * volatile child,
     {
       Scheme_Object *l, *o;
       Scheme_Closure_Func f;
-      for (l = thread_swap_callbacks; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
+      for (l = thread_swap_callbacks; SCHEME_RPAIRP(l); l = SCHEME_CDR(l)) {
 	o = SCHEME_CAR(l);
 	f = SCHEME_CLOS_FUNC(o);
 	o = SCHEME_CLOS_DATA(o);
@@ -2628,7 +2628,7 @@ void scheme_add_swap_callback(Scheme_Closure_Func f, Scheme_Object *data)
 {
   Scheme_Object *p;
 
-  p = scheme_make_pair((Scheme_Object *)f, data);
+  p = scheme_make_raw_pair((Scheme_Object *)f, data);
   thread_swap_callbacks = scheme_make_pair(p, thread_swap_callbacks);
 }
 
@@ -4416,7 +4416,7 @@ static void promote_thread(Scheme_Thread *p, Scheme_Custodian *to_c)
       /* Otherwise, this is custodian is unrelated to the existing ones.
 	 Add it as an extra custodian. */
       mref = scheme_add_managed(to_c, (Scheme_Object *)p->mr_hop, NULL, NULL, 0);
-      l = scheme_make_pair((Scheme_Object *)mref, p->extra_mrefs);
+      l = scheme_make_raw_pair((Scheme_Object *)mref, p->extra_mrefs);
       p->extra_mrefs = l;
 
       transitive_promote(p, to_c);

src/mzscheme/src/type.c

@@ -93,6 +93,7 @@ scheme_init_type (Scheme_Env *env)
   set_name(scheme_case_lambda_sequence_type, "<case-lambda-code>");
   set_name(scheme_begin0_sequence_type, "<begin0-code>");
   set_name(scheme_with_cont_mark_type, "<with-continuation-mark-code>");
+  set_name(scheme_quote_syntax_type, "<quote-syntax-code>");
 
   set_name(scheme_let_value_type, "<let-value-code>");
   set_name(scheme_let_void_type, "<let-void-code>");
@@ -114,6 +115,7 @@ scheme_init_type (Scheme_Env *env)
   set_name(scheme_tail_call_waiting_type, "<tail-call-waiting>");
   set_name(scheme_null_type, "<empty-list>");
   set_name(scheme_pair_type, "<pair>");
+  set_name(scheme_raw_pair_type, "<raw-pair>");
   set_name(scheme_box_type, "<box>");
   set_name(scheme_integer_type, "<fixnum-integer>");
   set_name(scheme_double_type, "<inexact-number>");
@@ -424,6 +426,7 @@ void scheme_register_traversers(void)
   GC_REG_TRAV(scheme_letrec_type, letrec);
   GC_REG_TRAV(scheme_let_one_type, let_one);
   GC_REG_TRAV(scheme_with_cont_mark_type, with_cont_mark);
+  GC_REG_TRAV(scheme_quote_syntax_type, quotesyntax_obj);
   GC_REG_TRAV(scheme_module_variable_type, module_var);
 
   GC_REG_TRAV(_scheme_values_types_, bad_trav);
@@ -466,6 +469,7 @@ void scheme_register_traversers(void)
   GC_REG_TRAV(scheme_keyword_type, symbol_obj);
   GC_REG_TRAV(scheme_null_type, char_obj); /* small */
   GC_REG_TRAV(scheme_pair_type, cons_cell);
+  GC_REG_TRAV(scheme_raw_pair_type, cons_cell);
   GC_REG_TRAV(scheme_vector_type, vector_obj);
   GC_REG_TRAV(scheme_cpointer_type, cpointer_obj);