359.2, core changes

svn: r5142

src/mred/wxs/wxs_medi.cxx

@@ -2143,7 +2143,7 @@ static Scheme_Object *os_wxMediaBufferInsertPort(int n,  Scheme_Object *p[])
   VAR_STACK_PUSH(1, x0);
 
   
-  x0 = (SCHEME_INPORTP(p[POFFSET+0]) ? p[POFFSET+0] : (scheme_wrong_type(METHODNAME("editor<%>","insert-port"), "input port", -1, 1, &p[POFFSET+0]), (Scheme_Object *)NULL));
+  x0 = (SCHEME_INPUT_PORTP(p[POFFSET+0]) ? p[POFFSET+0] : (scheme_wrong_type(METHODNAME("editor<%>","insert-port"), "input port", -1, 1, &p[POFFSET+0]), (Scheme_Object *)NULL));
   if (n > (POFFSET+1)) {
     x1 = WITH_VAR_STACK(unbundle_symset_fileType(p[POFFSET+1], "insert-port in editor<%>"));
   } else
@@ -2177,7 +2177,7 @@ static Scheme_Object *os_wxMediaBufferSavePort(int n,  Scheme_Object *p[])
   VAR_STACK_PUSH(1, x0);
 
   
-  x0 = (SCHEME_OUTPORTP(p[POFFSET+0]) ? p[POFFSET+0] : (scheme_wrong_type(METHODNAME("editor<%>","save-port"), "output port", -1, 1, &p[POFFSET+0]), (Scheme_Object *)NULL));
+  x0 = (SCHEME_OUTPUT_PORTP(p[POFFSET+0]) ? p[POFFSET+0] : (scheme_wrong_type(METHODNAME("editor<%>","save-port"), "output port", -1, 1, &p[POFFSET+0]), (Scheme_Object *)NULL));
   if (n > (POFFSET+1)) {
     x1 = WITH_VAR_STACK(unbundle_symset_fileType(p[POFFSET+1], "save-port in editor<%>"));
   } else

src/mred/wxs/wxs_medi.xc

@@ -49,10 +49,10 @@ static void *wxbDCToBuffer(wxMediaBuffer *b, double x, double y)
 @MACRO rFALSE = return FALSE;
 @MACRO rZERO = return 0;
 
-@MACRO ubiPort[who] = (SCHEME_INPORTP({x}) ? {x} : (scheme_wrong_type(METHODNAME("editor<%>",<who>), "input port", -1, 1, &{x}), (Scheme_Object *)NULL))
+@MACRO ubiPort[who] = (SCHEME_INPUT_PORTP({x}) ? {x} : (scheme_wrong_type(METHODNAME("editor<%>",<who>), "input port", -1, 1, &{x}), (Scheme_Object *)NULL))
-@MACRO ciPort = SCHEME_INPORTP({x})
+@MACRO ciPort = SCHEME_INPUT_PORTP({x})
-@MACRO uboPort[who] = (SCHEME_OUTPORTP({x}) ? {x} : (scheme_wrong_type(METHODNAME("editor<%>",<who>), "output port", -1, 1, &{x}), (Scheme_Object *)NULL))
+@MACRO uboPort[who] = (SCHEME_OUTPUT_PORTP({x}) ? {x} : (scheme_wrong_type(METHODNAME("editor<%>",<who>), "output port", -1, 1, &{x}), (Scheme_Object *)NULL))
-@MACRO coPort = SCHEME_OUTPORTP({x})
+@MACRO coPort = SCHEME_OUTPUT_PORTP({x})
 
 @INCLUDE wxs_eds.xci
 

src/mzscheme/cmdline.inc

@@ -312,7 +312,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
 	save = p->error_buf;
 	p->error_buf = &newbuf;
 	if (!scheme_setjmp(newbuf))
-	  scheme_eval_string_all(fa->evals_and_loads[i], fa->global_env, 0);
+	  scheme_eval_string_all_with_prompt(fa->evals_and_loads[i], fa->global_env, 0);
 	else {
 	  exit_val = 1;
 	  p->error_buf = save;
@@ -327,11 +327,11 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
 	if (!scheme_setjmp(newbuf)) {
 	  Scheme_Object *a[1], *m, *fn;
 	  
-	  m = scheme_eval_string("main", fa->global_env);
+	  m = scheme_eval_string_with_prompt("main", fa->global_env);
 	  fn = scheme_make_locale_string(fa->evals_and_loads[i]);
 	  SCHEME_SET_CHAR_STRING_IMMUTABLE(fn);
 	  a[0] = scheme_make_pair(fn, scheme_vector_to_list(fa->main_args));
-	  (void)scheme_apply(m, 1, a);
+	  (void)scheme_apply_multi_with_prompt(m, 1, a);
 	} else {
 	  exit_val = 1;
 	  p->error_buf = save;
@@ -358,7 +358,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
       if (SAME_OBJ(f, SCHEME_MULTIPLE_VALUES)
 	  && (scheme_multiple_count == 2)) {
 	f = scheme_multiple_array[0];
-	_scheme_apply(f, 0, NULL);
+	scheme_apply_multi_with_prompt(f, 0, NULL);
       }
     } else {
       exit_val = 1;

src/mzscheme/include/mzscheme.exp

@@ -106,6 +106,8 @@ scheme_uchar_folds
 scheme_uchar_combining_classes
 scheme_eval
 scheme_eval_multi
+scheme_eval_with_prompt
+scheme_eval_multi_with_prompt
 scheme_eval_compiled
 scheme_eval_compiled_multi
 _scheme_eval_compiled
@@ -115,13 +117,24 @@ scheme_apply_multi
 scheme_apply_no_eb
 scheme_apply_multi_no_eb
 scheme_apply_to_list
+scheme_apply_with_prompt
+scheme_apply_multi_with_prompt
+_scheme_apply_with_prompt
+_scheme_apply_multi_with_prompt
 scheme_eval_string
 scheme_eval_string_multi
 scheme_eval_string_all
+scheme_eval_string_with_prompt
+scheme_eval_string_multi_with_prompt
+scheme_eval_string_all_with_prompt
 _scheme_apply_known_prim_closure
 _scheme_apply_known_prim_closure_multi
 _scheme_apply_prim_closure
 _scheme_apply_prim_closure_multi
+scheme_call_with_prompt
+scheme_call_with_prompt_multi
+_scheme_call_with_prompt
+_scheme_call_with_prompt_multi
 scheme_values
 scheme_check_one_value
 scheme_tail_apply
@@ -179,6 +192,7 @@ scheme_make_hash_table
 scheme_make_hash_table_equal
 scheme_hash_set
 scheme_hash_get
+scheme_eq_hash_get
 scheme_hash_table_equal
 scheme_is_hash_table_equal
 scheme_clone_hash_table
@@ -348,6 +362,11 @@ scheme_close_output_port
 scheme_write_special
 scheme_write_special_nonblock
 scheme_make_write_evt
+scheme_port_record
+scheme_input_port_record
+scheme_output_port_record
+scheme_is_input_port
+scheme_is_output_port
 scheme_make_port_type
 scheme_make_input_port
 scheme_make_output_port

src/mzscheme/include/mzscheme3m.exp

@@ -106,6 +106,8 @@ scheme_uchar_folds
 scheme_uchar_combining_classes
 scheme_eval
 scheme_eval_multi
+scheme_eval_with_prompt
+scheme_eval_multi_with_prompt
 scheme_eval_compiled
 scheme_eval_compiled_multi
 _scheme_eval_compiled
@@ -115,13 +117,24 @@ scheme_apply_multi
 scheme_apply_no_eb
 scheme_apply_multi_no_eb
 scheme_apply_to_list
+scheme_apply_with_prompt
+scheme_apply_multi_with_prompt
+_scheme_apply_with_prompt
+_scheme_apply_multi_with_prompt
 scheme_eval_string
 scheme_eval_string_multi
 scheme_eval_string_all
+scheme_eval_string_with_prompt
+scheme_eval_string_multi_with_prompt
+scheme_eval_string_all_with_prompt
 _scheme_apply_known_prim_closure
 _scheme_apply_known_prim_closure_multi
 _scheme_apply_prim_closure
 _scheme_apply_prim_closure_multi
+scheme_call_with_prompt
+scheme_call_with_prompt_multi
+_scheme_call_with_prompt
+_scheme_call_with_prompt_multi
 scheme_values
 scheme_check_one_value
 scheme_tail_apply
@@ -186,6 +199,7 @@ scheme_make_hash_table
 scheme_make_hash_table_equal
 scheme_hash_set
 scheme_hash_get
+scheme_eq_hash_get
 scheme_hash_table_equal
 scheme_is_hash_table_equal
 scheme_clone_hash_table
@@ -355,6 +369,11 @@ scheme_close_output_port
 scheme_write_special
 scheme_write_special_nonblock
 scheme_make_write_evt
+scheme_port_record
+scheme_input_port_record
+scheme_output_port_record
+scheme_is_input_port
+scheme_is_output_port
 scheme_make_port_type
 scheme_make_input_port
 scheme_make_output_port

src/mzscheme/include/mzwin.def

@@ -108,6 +108,8 @@ EXPORTS
  scheme_uchar_combining_classes
  scheme_eval
  scheme_eval_multi
+ scheme_eval_with_prompt
+ scheme_eval_multi_with_prompt
  scheme_eval_compiled
  scheme_eval_compiled_multi
  scheme_apply
@@ -115,9 +117,16 @@ EXPORTS
  scheme_apply_no_eb
  scheme_apply_multi_no_eb
  scheme_apply_to_list
+ scheme_apply_with_prompt
+ scheme_apply_multi_with_prompt
  scheme_eval_string
  scheme_eval_string_multi
  scheme_eval_string_all
+ scheme_eval_string_with_prompt
+ scheme_eval_string_multi_with_prompt
+ scheme_eval_string_all_with_prompt
+ scheme_call_with_prompt
+ scheme_call_with_prompt_multi
  scheme_values
  scheme_check_one_value
  scheme_tail_apply
@@ -171,6 +180,7 @@ EXPORTS
  scheme_make_hash_table_equal
  scheme_hash_set
  scheme_hash_get
+ scheme_eq_hash_get
  scheme_hash_table_equal
  scheme_is_hash_table_equal
  scheme_clone_hash_table
@@ -340,6 +350,11 @@ EXPORTS
  scheme_write_special
  scheme_write_special_nonblock
  scheme_make_write_evt
+ scheme_port_record
+ scheme_input_port_record
+ scheme_output_port_record
+ scheme_is_input_port
+ scheme_is_output_port
  scheme_make_port_type
  scheme_make_input_port
  scheme_make_output_port

src/mzscheme/include/scheme.h

@@ -441,6 +441,9 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
 #define SCHEME_INPORTP(obj)  SAME_TYPE(SCHEME_TYPE(obj), scheme_input_port_type)
 #define SCHEME_OUTPORTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_output_port_type)
 
+#define SCHEME_INPUT_PORTP(obj)  scheme_is_input_port(obj)
+#define SCHEME_OUTPUT_PORTP(obj) scheme_is_output_port(obj)
+
 #define SCHEME_THREADP(obj)   SAME_TYPE(SCHEME_TYPE(obj), scheme_thread_type)
 #define SCHEME_CUSTODIANP(obj)   SAME_TYPE(SCHEME_TYPE(obj), scheme_custodian_type)
 #define SCHEME_SEMAP(obj)   SAME_TYPE(SCHEME_TYPE(obj), scheme_sema_type)
@@ -936,7 +939,6 @@ typedef struct Scheme_Thread {
   struct Scheme_Thread **cont_mark_stack_owner;
   struct Scheme_Cont_Mark *cont_mark_stack_swapped;
 
-  struct Scheme_Prompt *barrier_prompt; /* a pseudo-prompt */
   struct Scheme_Prompt *meta_prompt; /* a pseudo-prompt */
   
   struct Scheme_Meta_Continuation *meta_continuation;
@@ -957,6 +959,7 @@ typedef struct Scheme_Thread {
   Scheme_Jumpup_Buf jmpup_buf; /* For jumping back to this thread */
 
   struct Scheme_Dynamic_Wind *dw;
+  int next_meta;  /* amount to move forward in the meta-continuaiton chain, starting with dw */
 
   int running;
   Scheme_Object *suspended_box; /* contains pointer to thread when it's suspended */
@@ -1087,7 +1090,6 @@ enum {
 
   MZCONFIG_EXIT_HANDLER,
 
-  MZCONFIG_EXN_HANDLER,
   MZCONFIG_INIT_EXN_HANDLER,
 
   MZCONFIG_EVAL_HANDLER,

src/mzscheme/src/error.c

@@ -631,9 +631,8 @@ call_error(char *buffer, int len, Scheme_Object *exn)
 					scheme_make_pair(v, exn),
 					"nested-exception-handler", 
 					1, 1);
-    config = scheme_extend_config(orig_config,
+
-				  MZCONFIG_EXN_HANDLER,
+    config = orig_config;
-				  v);
     if (SAME_OBJ(display_handler, default_display_handler))
       config = scheme_extend_config(config,
 				    MZCONFIG_ERROR_DISPLAY_HANDLER,
@@ -645,6 +644,7 @@ call_error(char *buffer, int len, Scheme_Object *exn)
     
     scheme_push_continuation_frame(&cframe);
     scheme_install_config(config);
+    scheme_set_cont_mark(scheme_exn_handler_key, v);
     scheme_push_break_enable(&cframe2, 0, 0);
 
     p[0] = scheme_make_immutable_sized_utf8_string(buffer, len);
@@ -656,9 +656,7 @@ call_error(char *buffer, int len, Scheme_Object *exn)
 					scheme_make_pair(v, exn),
 					"nested-exception-handler", 
 					1, 1);
-    config = scheme_extend_config(orig_config,
+    
-				  MZCONFIG_EXN_HANDLER,
-				  v);
     config = scheme_extend_config(config,
 				  MZCONFIG_ERROR_DISPLAY_HANDLER,
 				  default_display_handler);
@@ -670,6 +668,7 @@ call_error(char *buffer, int len, Scheme_Object *exn)
     scheme_pop_continuation_frame(&cframe);
 
     scheme_push_continuation_frame(&cframe);
+    scheme_set_cont_mark(scheme_exn_handler_key, v);
     scheme_install_config(config);
     scheme_push_break_enable(&cframe2, 0, 0);
 
@@ -2237,6 +2236,16 @@ def_error_value_string_proc(int argc, Scheme_Object *argv[])
 static Scheme_Object *
 def_error_escape_proc(int argc, Scheme_Object *argv[])
 {  
+  Scheme_Object *prompt;
+  Scheme_Thread *p = scheme_current_thread;
+
+  prompt = scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(scheme_default_prompt_tag));
+
+  if (prompt) {
+    p->cjs.jumping_to_continuation = prompt;
+    p->cjs.num_vals = 1;
+    p->cjs.val = scheme_void_proc;
+  }
   scheme_longjmp(scheme_error_buf, 1);
 
   return scheme_void; /* Never get here */
@@ -2416,19 +2425,10 @@ def_exn_handler(int argc, Scheme_Object *argv[])
   return scheme_void;
 }
 
-static Scheme_Object *
-exn_handler(int argc, Scheme_Object *argv[])
-{
-  return scheme_param_config("current-exception-handler",
-			     scheme_make_integer(MZCONFIG_EXN_HANDLER),
-			     argc, argv,
-			     1, NULL, NULL, 0);
-}
-
 static Scheme_Object *
 init_exn_handler(int argc, Scheme_Object *argv[])
 {
-  return scheme_param_config("initial-exception-handler",
+  return scheme_param_config("uncaught-exception-handler",
 			     scheme_make_integer(MZCONFIG_INIT_EXN_HANDLER),
 			     argc, argv,
 			     1, NULL, NULL, 0);
@@ -2486,7 +2486,6 @@ static Scheme_Object *
 do_raise(Scheme_Object *arg, int return_ok, int need_debug)
 {
  Scheme_Object *v, *p[1], *h;
- Scheme_Config *config;
  Scheme_Cont_Frame_Data cframe, cframe2;
 
  if (scheme_current_thread->skip_error) {
@@ -2499,8 +2498,10 @@ do_raise(Scheme_Object *arg, int return_ok, int need_debug)
    ((Scheme_Structure *)arg)->slots[1] = marks;
  }
 
- config = scheme_current_config();
+ h = scheme_extract_one_cc_mark(NULL, scheme_exn_handler_key);
- h = scheme_get_param(config, MZCONFIG_EXN_HANDLER);
+ if (!h) {
+   h = scheme_get_param(scheme_current_config(), MZCONFIG_INIT_EXN_HANDLER);
+ }
 
  v = scheme_make_byte_string_without_copying("exception handler");
  v = scheme_make_closed_prim_w_arity(nested_exn_handler,
@@ -2508,12 +2509,8 @@ do_raise(Scheme_Object *arg, int return_ok, int need_debug)
 				     "nested-exception-handler", 
 				     1, 1);
 
- config = scheme_extend_config(config,
-			       MZCONFIG_EXN_HANDLER,
-			       v);
-
  scheme_push_continuation_frame(&cframe);
- scheme_install_config(config);
+ scheme_set_cont_mark(scheme_exn_handler_key, v);
  scheme_push_break_enable(&cframe2, 0, 0);
 
  p[0] = arg;
@@ -2702,15 +2699,9 @@ void scheme_init_exn(Scheme_Env *env)
     }
   }
 
-  scheme_add_global_constant("current-exception-handler",
+  scheme_add_global_constant("uncaught-exception-handler",
-			     scheme_register_parameter(exn_handler,
-						       "current-exception-handler",
-						       MZCONFIG_EXN_HANDLER),
-			     env);
-
-  scheme_add_global_constant("initial-exception-handler",
 			     scheme_register_parameter(init_exn_handler,
-						       "initial-exception-handler",
+						       "uncaught-exception-handler",
 						       MZCONFIG_INIT_EXN_HANDLER),
 			     env);
 
@@ -2731,7 +2722,6 @@ void scheme_init_exn_config(void)
 			       "default-exception-handler",
 			       1, 1);
 
-  scheme_set_root_param(MZCONFIG_EXN_HANDLER, h);
   scheme_set_root_param(MZCONFIG_INIT_EXN_HANDLER, h);
 }
 

src/mzscheme/src/eval.c

@@ -143,6 +143,7 @@
 /* globals */
 Scheme_Object *scheme_eval_waiting;
 Scheme_Object *scheme_multiple_values;
+int scheme_continuation_application_count;
 
 volatile int scheme_fuel_counter;
 
@@ -152,6 +153,7 @@ void scheme_set_startup_use_jit(int v) { scheme_startup_use_jit =  v; }
 static Scheme_Object *app_symbol;
 static Scheme_Object *datum_symbol;
 static Scheme_Object *top_symbol;
+static Scheme_Object *top_level_symbol;
 
 static Scheme_Object *app_expander;
 static Scheme_Object *datum_expander;
@@ -222,7 +224,6 @@ static Scheme_Object *internal_define_symbol;
 static Scheme_Object *module_symbol;
 static Scheme_Object *module_begin_symbol;
 static Scheme_Object *expression_symbol;
-static Scheme_Object *top_level_symbol;
 
 static Scheme_Object *protected_symbol;
 
@@ -234,6 +235,8 @@ static Scheme_Object *scheme_compile_expand_expr(Scheme_Object *form, Scheme_Com
 						 Scheme_Compile_Expand_Info *rec, int drec, 
 						 int app_position);
 
+static Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env);
+
 #define cons(x,y) scheme_make_pair(x,y)
 
 typedef void (*DW_PrePost_Proc)(void *);
@@ -517,6 +520,8 @@ scheme_handle_stack_overflow(Scheme_Object *(*k)(void))
   Scheme_Overflow *overflow;
   Scheme_Overflow_Jmp *jmp;
 
+  scheme_about_to_move_C_stack();
+
   scheme_overflow_k = k;
   scheme_overflow_count++;
   
@@ -550,6 +555,11 @@ scheme_handle_stack_overflow(Scheme_Object *(*k)(void))
         /* Jump directly to prompt: */
         Scheme_Prompt *prompt = (Scheme_Prompt *)p->cjs.jumping_to_continuation;
         scheme_longjmp(*prompt->prompt_buf, 1);
+      } else if (p->cjs.jumping_to_continuation
+                 && SCHEME_CONTP(p->cjs.jumping_to_continuation)) {
+        Scheme_Cont *c = (Scheme_Cont *)p->cjs.jumping_to_continuation;
+        p->cjs.jumping_to_continuation = NULL;
+        scheme_longjmpup(&c->buf);
       } else {
         /* Continue normal escape: */
         scheme_longjmp(scheme_error_buf, 1);
@@ -1454,7 +1464,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
     if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1)) {
       /* We can't optimize (begin0 expr cont) to expr because
 	 exp is not in tail position in the original (so we'd mess
-	 up continuation marks. */
+	 up continuation marks). */
       addconst = 1;
     } else
       return good;
@@ -3574,7 +3584,6 @@ static Scheme_Object *call_compile_handler(Scheme_Object *form, int immediate_ev
   return o;
 }
 
-
 static Scheme_Object *add_renames_unless_module(Scheme_Object *form, Scheme_Env *genv)
 {
   if (genv->rename) {
@@ -3804,7 +3813,7 @@ static void *compile_k(void)
     if (SCHEME_PAIRP(tl_queue)) {
       /* This compile is interleaved with evaluation,
 	 and we need to eval now before compiling more. */
-      _scheme_eval_compiled_multi((Scheme_Object *)top, genv);
+      _eval_compiled_multi_with_prompt((Scheme_Object *)top, genv);
 
       form = SCHEME_CAR(tl_queue);
       tl_queue = SCHEME_CDR(tl_queue);
@@ -5591,28 +5600,34 @@ static void make_tail_buffer_safe()
 }
 
 static Scheme_Dynamic_Wind *intersect_dw(Scheme_Dynamic_Wind *a, Scheme_Dynamic_Wind *b, 
-                                         Scheme_Object *prompt_tag, int *_common_depth)
+                                         Scheme_Object *prompt_tag, int b_has_tag, int *_common_depth)
 {
   int alen = 0, blen = 0;
-  int prompt_delta = 0;
+  int a_has_tag = 0, a_prompt_delta = 0, b_prompt_delta = 0;
-
-  if (prompt_tag) {
   Scheme_Dynamic_Wind *dw;
+
   for (dw = a; dw && (dw->prompt_tag != prompt_tag); dw = dw->prev) {
   }
-    if (dw)
+  if (dw) {
-      prompt_delta = dw->depth + 1;
+    /* Cut off `a' below the prompt dw. */
+    a_prompt_delta = dw->depth;
+    a_has_tag = 1;
   }
 
-  alen = (a ? a->depth + 1 : 0) - prompt_delta;
+  if (a_has_tag)
-  blen = (b ? b->depth + 1 : 0);
+    a_prompt_delta += 1;
+  if (b_has_tag)
+    b_prompt_delta += 1;
+
+  alen = (a ? a->depth + 1 : 0) - a_prompt_delta;
+  blen = (b ? b->depth + 1 : 0) - b_prompt_delta;
 
   while (alen > blen) {
     --alen;
     a = a->prev;
   }
   if (!alen) {
-    *_common_depth = -1;
+    *_common_depth = b_prompt_delta - 1;
     return a;
   }
   while (blen > alen) {
@@ -5635,6 +5650,124 @@ static Scheme_Dynamic_Wind *intersect_dw(Scheme_Dynamic_Wind *a, Scheme_Dynamic_
   return a;
 }
 
+static Scheme_Prompt *lookup_cont_prompt(Scheme_Cont *c, 
+                                         Scheme_Meta_Continuation **_prompt_mc,
+                                         MZ_MARK_POS_TYPE *_prompt_pos,
+                                         const char *msg)
+{
+  Scheme_Prompt *prompt;
+
+  prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL, 
+                                                                 SCHEME_PTR_VAL(c->prompt_tag),
+                                                                 NULL,
+                                                                 _prompt_mc,
+                                                                 _prompt_pos);
+  if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, c->prompt_tag)) {
+    scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
+                     msg);
+  }
+
+  return prompt;
+}
+
+#define LOOKUP_NO_PROMPT "continuation application: no corresponding prompt in the current continuation"
+
+static Scheme_Prompt *check_barrier(Scheme_Prompt *prompt, 
+                                    Scheme_Meta_Continuation *prompt_cont, MZ_MARK_POS_TYPE prompt_pos,
+                                    Scheme_Cont *c)
+/* A continuation barrier is analogous to a dynamic-wind. A jump is
+   allowed if no dynamic-wind-like barriers would be executed for
+   the jump. */
+{
+  Scheme_Prompt *barrier_prompt, *b1, *b2;
+  Scheme_Meta_Continuation *barrier_cont;
+  MZ_MARK_POS_TYPE barrier_pos;
+
+  barrier_prompt = scheme_get_barrier_prompt(&barrier_cont, &barrier_pos);
+  b1 = barrier_prompt;
+  if (b1) {
+    if (!b1->is_barrier)
+      b1 = NULL;
+    else if (prompt
+             && scheme_is_cm_deeper(barrier_cont, barrier_pos,
+                                    prompt_cont, prompt_pos))
+      b1 = NULL;
+  }
+  b2 = c->barrier_prompt;
+  if (b2) {
+    if (!b2->is_barrier)
+      b2 = NULL;
+  }
+  
+  if (b1 != b2) {
+    scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
+                     "continuation application: attempt to cross a continuation barrier");
+  }
+
+  return barrier_prompt;
+}
+
+void scheme_recheck_prompt_and_barrier(Scheme_Cont *c)
+/* Check for prompt & barrier, again. We need to
+   call this function like a d-w thunk, so that the meta
+   continuation is right in case of an error. */
+{
+  Scheme_Prompt *prompt;
+  Scheme_Meta_Continuation *prompt_cont;
+  MZ_MARK_POS_TYPE prompt_pos;
+  prompt = lookup_cont_prompt(c, &prompt_cont, &prompt_pos,
+                              LOOKUP_NO_PROMPT
+                              " on return from `dynamic-wind' post thunk");
+  check_barrier(prompt, prompt_cont, prompt_pos, c);
+}
+
+static int exec_dyn_wind_posts(Scheme_Dynamic_Wind *common, Scheme_Cont *c, int common_depth)
+{
+  int meta_depth;
+  Scheme_Thread *p = scheme_current_thread;
+  Scheme_Dynamic_Wind *dw;
+  int old_cac = scheme_continuation_application_count;
+
+  for (dw = p->dw; 
+       ((common && common->id) ? dw->id != common->id : dw != common); 
+       ) {
+    meta_depth = p->next_meta;
+    p->next_meta += dw->next_meta;
+    p->dw = dw->prev;
+    if (dw->post) {
+      if (meta_depth > 0) {
+        scheme_apply_dw_in_meta(dw, 1, meta_depth, c);
+      } else {
+        DW_PrePost_Proc post = dw->post;
+        
+        MZ_CONT_MARK_POS = dw->envss.cont_mark_pos;
+        MZ_CONT_MARK_STACK = dw->envss.cont_mark_stack;
+        post(dw->data);
+
+        if (scheme_continuation_application_count != old_cac) {
+          scheme_recheck_prompt_and_barrier(c);
+        }
+      }
+      p = scheme_current_thread;
+      /* p->dw might not match dw if the post thunk captures a
+         continuation that is later restored in a different 
+         meta continuation: */
+      dw = p->dw;
+
+      /* If any continuations were applied, then the set of dynamic
+         winds may be different now than before Re-compute the
+         intersection. */
+      if (scheme_continuation_application_count != old_cac) {
+        old_cac = scheme_continuation_application_count;
+        
+        common = intersect_dw(p->dw, c->dw, c->prompt_tag, c->has_prompt_dw, &common_depth);
+      }
+    } else
+      dw = dw->prev;
+  }
+  return common_depth;
+}
+
 #ifdef REGISTER_POOR_MACHINE
 # define USE_LOCAL_RUNSTACK 0
 # define DELAY_THREAD_RUNSTACK_UPDATE 0
@@ -6061,10 +6194,11 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
 #endif
     } else if (type == scheme_cont_type) {
       Scheme_Cont *c;
-      Scheme_Dynamic_Wind *dw, *common;
+      Scheme_Dynamic_Wind *common;
       Scheme_Object *value;
       Scheme_Meta_Continuation *prompt_mc;
-      Scheme_Prompt *prompt;
+      MZ_MARK_POS_TYPE prompt_pos;
+      Scheme_Prompt *prompt, *barrier_prompt;
       int common_depth;
       
       if (num_rands != 1) {
@@ -6098,85 +6232,39 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
 
       if (c->composable) {
         /* Composable continuation. Jump right in... */
+        scheme_continuation_application_count++;
         RUNSTACK = old_runstack;
 	RUNSTACK_CHANGED();
         UPDATE_THREAD_RSPTR();
         v = scheme_compose_continuation(c, num_rands, value);
       } else {
         /* Aborting (Scheme-style) continuation. */
+        int orig_cac = scheme_continuation_application_count;
 
-        prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL, 
+        UPDATE_THREAD_RSPTR();
-                                                                       SCHEME_PTR_VAL(c->prompt_tag),
-                                                                       NULL,
-                                                                       &prompt_mc);
-        if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, c->prompt_tag)) {
-          scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
-                           "continuation application: no corresponding prompt in the current continuation");
-        }
 
-        /* A continuation barrier is analogous to a dynamic-wind. A jump is
+        scheme_about_to_move_C_stack();
-           allowed if no dynamic-wind-like barriers would be executed for
-           the jump. */
-        {
-          Scheme_Prompt *b1, *b2;
 
-          b1 = p->barrier_prompt;
+        prompt = lookup_cont_prompt(c, &prompt_mc, &prompt_pos, LOOKUP_NO_PROMPT);
-          if (b1) {
+        barrier_prompt = check_barrier(prompt, prompt_mc, prompt_pos, c);
-            if (!b1->is_barrier)
-              b1 = NULL;
-            else if (prompt && (prompt->depth > b1->depth))
-              b1 = NULL;
-          }
-          b2 = c->ss.barrier_prompt;
-          if (b2) {
-            if (!b2->is_barrier)
-              b2 = NULL;
-            else if (c->prompt_depth > b2->depth)
-              b2 = NULL;
-          }
-        
-          if (b1 != b2) {
-            UPDATE_THREAD_RSPTR_FOR_ERROR();
-            scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
-                             "continuation application: attempt to cross a continuation barrier");
-          }
-        }
 
         p->suspend_break++; /* restored at call/cc destination */
 
         /* Find `common', the intersection of dynamic-wind chain for 
            the current continuation and the given continuation, looking
            no further back in the current continuation than a prompt. */
-        common = intersect_dw(p->dw, c->dw, c->prompt_tag, &common_depth);
+        common = intersect_dw(p->dw, c->dw, c->prompt_tag, c->has_prompt_dw, &common_depth);
 
         /* For dynamic-winds after `common' in this
            continuation, execute the post-thunks */
-        {
+        common_depth = exec_dyn_wind_posts(common, c, common_depth);
-          int meta_depth = 0;
-          
-          for (dw = p->dw; 
-               ((common && common->id) ? dw->id != common->id : dw != common); 
-               ) {
-            if (dw->post) {
-              p->dw = dw->prev;
-              meta_depth += dw->next_meta;
-              if (meta_depth) {
-                scheme_apply_dw_in_meta(dw, 1, meta_depth);
-              } else {
-                DW_PrePost_Proc post = dw->post;
-
-                MZ_CONT_MARK_POS = dw->envss.cont_mark_pos;
-                MZ_CONT_MARK_STACK = dw->envss.cont_mark_stack;
-                post(dw->data);
-              }
         p = scheme_current_thread;
-              /* p->dw might not match dw if the post thunk captures a
+
-                 continuation that is later restored in a different 
+        if (orig_cac != scheme_continuation_application_count) {
-                 meta continuation: */
+          /* We checked for a barrier in exec_dyn_wind_posts, but
-              dw = p->dw;
+             get prompt & barrier again. */
-            } else
+          prompt = lookup_cont_prompt(c, &prompt_mc, &prompt_pos, "shouldn't fail!");
-              dw = dw->prev;
+          barrier_prompt = scheme_get_barrier_prompt(NULL, NULL);
-          }
         }
 
         c->common_dw_depth = common_depth;
@@ -6189,7 +6277,10 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
           c->value = vals;
         }
 
-        p->dw = common;
+        c->common_dw = common;
+        c->common_next_meta = p->next_meta;
+
+        scheme_continuation_application_count++;
 
         if (!prompt) {
           /* Invoke the continuation directly. If there's no prompt,
@@ -6197,7 +6288,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
              created with a new thread or a barrier prompt. */
           p->meta_continuation = NULL; /* since prompt wasn't in any meta-continuation */
           p->meta_prompt = NULL;
-          if (c->ss.barrier_prompt == p->barrier_prompt) {
+          if (c->barrier_prompt == barrier_prompt) {
             /* Barrier determines continuation end. */
             c->resume_to = NULL;
             p->stack_start = c->stack_start;
@@ -6211,6 +6302,32 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
             p->stack_start = c->prompt_stack_start;
           }
           scheme_longjmpup(&c->buf);
+        } else if (prompt->id
+                   && (prompt->id == c->prompt_id)
+                   && !prompt_mc) {
+          /* The current prompt is the same as the one in place when
+             capturing the continuation, so we can jump directly. */
+          scheme_drop_prompt_meta_continuations(c->prompt_tag);
+          c->shortcut_prompt = prompt;
+          if ((!prompt->boundary_overflow_id && !p->overflow)
+              || (prompt->boundary_overflow_id
+                  && (prompt->boundary_overflow_id == p->overflow->id))) {
+            scheme_longjmpup(&c->buf);
+          } else {
+            /* Need to unwind overflows... */
+            Scheme_Overflow *overflow;
+            overflow = p->overflow;
+            while (overflow->prev
+                   && (!overflow->prev->id
+                       || (overflow->prev->id != prompt->boundary_overflow_id))) {
+              overflow = overflow->prev;
+            }
+            /* Immediate destination is in scheme_handle_stack_overflow(). */
+            p->cjs.jumping_to_continuation = (Scheme_Object *)c;
+            p->overflow = overflow;
+            p->stack_start = overflow->stack_start;
+            scheme_longjmpup(&overflow->jmp->cont);
+          }
         } else {
           p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
           p->cjs.num_vals = 1;
@@ -6223,18 +6340,36 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
                and continue from there. Immediate destination is
                in compose_continuation() in fun.c; the ultimate
                destination is in scheme_finish_apply_for_prompt()
-               in fun.c. */
+               in fun.c.
+               We need to adjust the meta-continuation offsets in
+               common, based on the number that we're discarding
+               here. */
+            {
+              Scheme_Meta_Continuation *xmc;
+              int offset = 1;
+              for (xmc = p->meta_continuation; 
+                   xmc->prompt_tag != prompt_mc->prompt_tag; 
+                   xmc = xmc->next) {
+                if (xmc->overflow)
+                  offset++;
+              }
+              c->common_next_meta -= offset;
+            }
             p->meta_continuation = prompt_mc->next;
             p->stack_start = prompt_mc->overflow->stack_start;
             scheme_longjmpup(&prompt_mc->overflow->jmp->cont);
           } else if ((!prompt->boundary_overflow_id && !p->overflow)
-                     || (prompt->boundary_overflow_id == p->overflow->id)) {
+                     || (prompt->boundary_overflow_id
+                         && (prompt->boundary_overflow_id == p->overflow->id))) {
             /* Jump directly to the prompt: destination is in
                scheme_finish_apply_for_prompt() in fun.c. */
+            scheme_drop_prompt_meta_continuations(c->prompt_tag);
             scheme_longjmp(*prompt->prompt_buf, 1);
           } else {
             /* Need to unwind overflows to get to the prompt. */
-            Scheme_Overflow *overflow = p->overflow;
+            Scheme_Overflow *overflow;
+            scheme_drop_prompt_meta_continuations(c->prompt_tag);
+            overflow = p->overflow;
             while (overflow->prev
                    && (!overflow->prev->id
                        || (overflow->prev->id != prompt->boundary_overflow_id))) {
@@ -6955,6 +7090,34 @@ Scheme_Object *scheme_eval_multi(Scheme_Object *obj, Scheme_Env *env)
   return scheme_eval_compiled_multi(scheme_compile_for_eval(obj, env), env);
 }
 
+static Scheme_Object *finish_eval_with_prompt(void *_data, int argc, Scheme_Object **argv)
+{
+  Scheme_Object *data = (Scheme_Object *)_data;
+  return _scheme_eval_compiled(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data));
+}
+
+Scheme_Object *scheme_eval_with_prompt(Scheme_Object *obj, Scheme_Env *env)
+{
+  Scheme_Object *expr;
+  expr = scheme_compile_for_eval(obj, env);
+  return scheme_call_with_prompt(finish_eval_with_prompt, 
+                                 scheme_make_pair(expr, (Scheme_Object *)env));
+}
+
+static Scheme_Object *finish_eval_multi_with_prompt(void *_data, int argc, Scheme_Object **argv)
+{
+  Scheme_Object *data = (Scheme_Object *)_data;
+  return _scheme_eval_compiled_multi(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data));
+}
+
+Scheme_Object *scheme_eval_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env)
+{
+  Scheme_Object *expr;
+  expr = scheme_compile_for_eval(obj, env);
+  return scheme_call_with_prompt(finish_eval_multi_with_prompt, 
+                                 scheme_make_pair(expr, (Scheme_Object *)env));
+}
+
 static void *eval_k(void)
 {
   Scheme_Thread *p = scheme_current_thread;
@@ -7074,6 +7237,18 @@ Scheme_Object *_scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env)
   return _eval(obj, env, 0, 1, 0, 0);
 }
 
+static Scheme_Object *finish_compiled_multi_with_prompt(void *_data, int argc, Scheme_Object **argv)
+{
+  Scheme_Object *data = (Scheme_Object *)_data;
+  return _eval(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data), 0, 1, 0, 0);
+}
+
+Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env)
+{
+  return _scheme_call_with_prompt_multi(finish_compiled_multi_with_prompt,
+                                        scheme_make_pair(obj, (Scheme_Object *)env));
+}
+
 Scheme_Object *scheme_eval_linked_expr(Scheme_Object *obj)
 {
   return _eval(obj, NULL, 1, 0, 1, 0);
@@ -7672,7 +7847,7 @@ expand_stx_to_top_form(int argc, Scheme_Object **argv)
   return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 1, -1, 1, 1, 0, NULL);
 }
 
-Scheme_Object *scheme_eval_string_all(const char *str, Scheme_Env *env, int cont)
+static Scheme_Object *do_eval_string_all(const char *str, Scheme_Env *env, int cont, int w_prompt)
 {
   Scheme_Object *port, *expr, *result = scheme_void;
 
@@ -7681,23 +7856,50 @@ Scheme_Object *scheme_eval_string_all(const char *str, Scheme_Env *env, int cont
     expr = scheme_read_syntax(port, scheme_false);
     if (SAME_OBJ(expr, scheme_eof))
       cont = 0;
-    else if (cont < 0)
+    else if (cont < 0) {
+      if (w_prompt)
+        result = scheme_eval_with_prompt(expr, env);
+      else
         result = scheme_eval(expr, env);
+    } else {
+      if (w_prompt)
+        result = scheme_eval_multi_with_prompt(expr, env);
       else
         result = scheme_eval_multi(expr, env);
+    }
   } while (cont > 0);
 
   return result;
 }
 
+Scheme_Object *scheme_eval_string_all(const char *str, Scheme_Env *env, int cont)
+{
+  return do_eval_string_all(str, env, cont, 0);
+}
+
 Scheme_Object *scheme_eval_string(const char *str, Scheme_Env *env)
 {
-  return scheme_eval_string_all(str, env, -1);
+  return do_eval_string_all(str, env, -1, 0);
 }
 
 Scheme_Object *scheme_eval_string_multi(const char *str, Scheme_Env *env)
 {
-  return scheme_eval_string_all(str, env, 0);
+  return do_eval_string_all(str, env, 0, 0);
+}
+
+Scheme_Object *scheme_eval_string_all_with_prompt(const char *str, Scheme_Env *env, int cont)
+{
+  return do_eval_string_all(str, env, cont, 1);
+}
+
+Scheme_Object *scheme_eval_string_with_prompt(const char *str, Scheme_Env *env)
+{
+  return do_eval_string_all(str, env, -1, 1);
+}
+
+Scheme_Object *scheme_eval_string_multi_with_prompt(const char *str, Scheme_Env *env)
+{
+  return do_eval_string_all(str, env, 0, 1);
 }
 
 static Scheme_Object *allow_set_undefined(int argc, Scheme_Object **argv)

src/mzscheme/src/hash.c

@@ -310,7 +310,7 @@ static Scheme_Object *do_hash_set(Scheme_Hash_Table *table, Scheme_Object *key,
   return val;
 }
 
-static Scheme_Object *do_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
+XFORM_NONGCING static Scheme_Object *do_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
 {
   Scheme_Object *tkey, **keys;
   hash_v_t h, h2;
@@ -368,6 +368,15 @@ Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
     return do_hash_get(table, key);
 }
 
+Scheme_Object *scheme_eq_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
+/* Specialized to allow XFORM_NONGCING */
+{
+  if (!table->vals)
+    return NULL;
+  else
+    return do_hash_get(table, key);
+}
+
 int scheme_hash_table_equal(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2)
 {
   Scheme_Object **vals, **keys, *v;

src/mzscheme/src/jit.c

@@ -120,6 +120,7 @@ static void *struct_pred_branch_code;
 static void *struct_get_code;
 static void *bad_app_vals_target;
 static void *app_values_slow_code, *app_values_multi_slow_code, *app_values_tail_slow_code;
+static void *finish_tail_call_code, *finish_tail_call_fixup_code;
 
 typedef struct {
   MZTAG_IF_REQUIRED
@@ -1280,7 +1281,9 @@ static int generate_direct_prim_tail_call(mz_jit_state *jitter, int num_rands)
 }
 
 static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_native, int need_set_rs)
-/* If num_rands < 0, then argc is in LOCAL2 and arguments are already below RUNSTACK_BASE */
+/* If num_rands < 0, then argc is in LOCAL2 and arguments are already below RUNSTACK_BASE.
+   If direct_native == 2, then some arguments are already in place (shallower in the runstack
+   than the arguments to move). */
 {
   int i;
   GC_CAN_IGNORE jit_insn *ref, *ref2, *ref4, *ref5;
@@ -1389,6 +1392,23 @@ static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na
   } else {
     mz_get_local_p(JIT_R0, JIT_LOCAL2);    
   }
+  /* Since we've overwritten JIT_RUNSTACK, if this is not shared
+     code, and if this is 3m, then the runstack no longer
+     has a pointer to the closure for this code. To ensure that
+     an appropriate return point exists, jump to static code
+     for the rest. (This is the slow path, anyway.) */
+   __END_SHORT_JUMPS__(num_rands < 100);
+   if (direct_native > 1) {
+     (void)jit_jmpi(finish_tail_call_fixup_code);
+   } else {
+     (void)jit_jmpi(finish_tail_call_code);
+   }
+
+   return 1;
+}
+
+static int generate_finish_tail_call(mz_jit_state *jitter, int direct_native)
+{
   mz_prepare(3);
   CHECK_LIMIT();
   jit_pusharg_p(JIT_RUNSTACK);
@@ -1399,14 +1419,13 @@ static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na
   } else {
     (void)mz_finish(_scheme_tail_apply_from_native);
   }
+  CHECK_LIMIT();
   /* Pop saved runstack val and return: */
   mz_get_local_p(JIT_NOT_RET, JIT_LOCAL1);
   jit_sti_p(&scheme_current_runstack, JIT_NOT_RET);
   mz_pop_locals();
   jit_ret();
 
-  __END_SHORT_JUMPS__(num_rands < 100);
-
   return 1;
 }
 
@@ -4113,6 +4132,11 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 	  END_JIT_DATA(9);
 	}
 	break;
+      case SPLICE_EXPD:
+        {
+          scheme_signal_error("cannot JIT a top-level splice form");
+        }
+        break;
       default:
 	{
 	  JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
@@ -4993,6 +5017,31 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
   jit_ret();
   CHECK_LIMIT();
 
+  /* *** app_values_tail_slow_code *** */
+  /* RELIES ON jit_prolog(3) FROM ABOVE */
+  /* Rator in V1, arguments are in thread's multiple-values cells. */
+  app_values_tail_slow_code = jit_get_ip().ptr;
+  JIT_UPDATE_THREAD_RSPTR();
+  mz_prepare(1);
+  jit_pusharg_p(JIT_V1);
+  (void)mz_finish(tail_call_with_values_from_multiple_result);
+  jit_retval(JIT_R0);
+  /* Pop saved runstack val and return: */
+  mz_get_local_p(JIT_NOT_RET, JIT_LOCAL1);
+  jit_sti_p(&scheme_current_runstack, JIT_NOT_RET);
+  mz_pop_locals();
+  jit_ret();  
+  CHECK_LIMIT();
+
+  /* *** finish_tail_call_[fixup_]code *** */
+  /* RELIES ON jit_prolog(3) FROM ABOVE */
+  finish_tail_call_code = jit_get_ip().ptr;
+  generate_finish_tail_call(jitter, 0);
+  CHECK_LIMIT();
+  finish_tail_call_fixup_code = jit_get_ip().ptr;
+  generate_finish_tail_call(jitter, 2);
+  CHECK_LIMIT();
+
   /* *** get_stack_pointer_code *** */
   get_stack_pointer_code = jit_get_ip().ptr;
   jit_leaf(0);
@@ -5066,21 +5115,6 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
     CHECK_LIMIT();
   }
 
-  /* *** app_values_tail_slow_code *** */
-  /* Rator in V1, arguments are in thread's multiple-values cells. */
-  app_values_tail_slow_code = jit_get_ip().ptr;
-  JIT_UPDATE_THREAD_RSPTR();
-  mz_prepare(1);
-  jit_pusharg_p(JIT_V1);
-  (void)mz_finish(tail_call_with_values_from_multiple_result);
-  jit_retval(JIT_R0);
-  /* Pop saved runstack val and return: */
-  mz_get_local_p(JIT_NOT_RET, JIT_LOCAL1);
-  jit_sti_p(&scheme_current_runstack, JIT_NOT_RET);
-  mz_pop_locals();
-  jit_ret();  
-  CHECK_LIMIT();
-
   /* *** {vector,string,bytes}_{ref,set}_[check_index_]code *** */
   /* R0 is vector/string/bytes, R1 is index (Scheme number in check-index mode), 
      V1 is vector/string/bytes offset in non-check-index mode (and for

src/mzscheme/src/mk-uchar.ss

@@ -344,7 +344,7 @@
 		     #f
 		     ;; whitespace
 		     (or (member cat space-cats)
-			 (member code '(#x9 #xa #xb #xc #xd)))
+			 (member code '(#x9 #xa #xb #xc #xd #x85)))
 		     ;; control
 		     (or (<= #x0000 code #x001F)
 			 (<= #x007F code #x009F))

src/mzscheme/src/module.c

@@ -150,6 +150,7 @@ static Scheme_Object *set_stx;
 static Scheme_Object *with_continuation_mark_stx;
 static Scheme_Object *letrec_syntaxes_stx;
 static Scheme_Object *var_ref_stx;
+static Scheme_Object *expression_stx;
 
 static Scheme_Env *initial_modules_env;
 static int num_initial_modules;
@@ -483,6 +484,7 @@ void scheme_finish_kernel(Scheme_Env *env)
   REGISTER_SO(with_continuation_mark_stx);
   REGISTER_SO(letrec_syntaxes_stx);
   REGISTER_SO(var_ref_stx);
+  REGISTER_SO(expression_stx);
 
   w = scheme_sys_wraps0;
   scheme_module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, w, 0, 0);
@@ -507,6 +509,7 @@ void scheme_finish_kernel(Scheme_Env *env)
   with_continuation_mark_stx = scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0);
   letrec_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0);
   var_ref_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0);
+  expression_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0);
 
   REGISTER_SO(prefix_symbol);
   REGISTER_SO(only_symbol);
@@ -2112,7 +2115,8 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
   symbol = scheme_tl_id_sym(env, symbol, NULL, 0);
 
   if ((env == scheme_initial_env)
-      || (env->module->primitive)
+      || ((env->module->primitive
+           && !env->module->provide_protects))
       /* For now[?], we're pretending that all definitions exists for
 	 non-0 local phase. */
       || env->mod_phase) {
@@ -2129,7 +2133,8 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
     int need_cert = 0;
 
     if (position < env->module->me->num_var_provides) {
-      if (SCHEME_FALSEP(env->module->me->provide_srcs[position]))
+      if (!env->module->me->provide_srcs
+          || SCHEME_FALSEP(env->module->me->provide_srcs[position]))
 	isym = env->module->me->provide_src_names[position];
       else
 	isym = NULL;
@@ -2779,6 +2784,8 @@ void scheme_finish_primitive_module(Scheme_Env *env)
   m->me->num_provides = count;
   m->me->num_var_provides = count;
 
+  qsort_provides(exs, NULL, NULL, NULL, 0, count, 1);
+
   env->running = 1;
 }
 
@@ -2788,12 +2795,16 @@ void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name)
   int i;
 
   if (!m->provide_protects) {
+    Scheme_Hash_Table *ht;
     char *exps;
+    ht = scheme_make_hash_table(SCHEME_hash_ptr);
     exps = MALLOC_N_ATOMIC(char, m->me->num_provides);
     for (i = m->me->num_provides; i--; ) {
       exps[i] = 0;
+      scheme_hash_set(ht, m->me->provides[i], scheme_make_integer(i));
     }
     m->provide_protects = exps;
+    m->accessible = ht;
   }
 
   if (name) {
@@ -3883,7 +3894,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
   {
     Scheme_Object *stop;
     stop = scheme_get_stop_expander();
-    scheme_add_local_syntax(20, xenv);
+    scheme_add_local_syntax(21, xenv);
     scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv);
     scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv);
     scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv);
@@ -3904,6 +3915,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
     scheme_set_local_syntax(17, with_continuation_mark_stx, stop, xenv);
     scheme_set_local_syntax(18, letrec_syntaxes_stx, stop, xenv);
     scheme_set_local_syntax(19, var_ref_stx, stop, xenv);
+    scheme_set_local_syntax(20, expression_stx, stop, xenv);
   }
 
   first = scheme_null;

src/mzscheme/src/mzmark.c

@@ -884,6 +884,7 @@ static int cont_proc_MARK(void *p) {
   gcMARK(c->dw);
   gcMARK(c->prompt_tag);
   gcMARK(c->meta_continuation);
+  gcMARK(c->common_dw);
   gcMARK(c->save_overflow);
   gcMARK(c->runstack_copied);
   gcMARK(c->runstack_owner);
@@ -898,15 +899,19 @@ static int cont_proc_MARK(void *p) {
   MARK_jmpup(&c->buf);
   MARK_cjs(&c->cjs);
   MARK_stack_state(&c->ss);
+  gcMARK(c->barrier_prompt);
   gcMARK(c->runstack_start);
   gcMARK(c->runstack_saved);
 
+  gcMARK(c->prompt_id);
+
   /* These shouldn't actually persist across a GC, but
      just in case... */
   gcMARK(c->value);
   gcMARK(c->resume_to);
   gcMARK(c->use_next_cont);
   gcMARK(c->extra_marks);
+  gcMARK(c->shortcut_prompt);
   
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Cont));
@@ -918,6 +923,7 @@ static int cont_proc_FIXUP(void *p) {
   gcFIXUP(c->dw);
   gcFIXUP(c->prompt_tag);
   gcFIXUP(c->meta_continuation);
+  gcFIXUP(c->common_dw);
   gcFIXUP(c->save_overflow);
   gcFIXUP(c->runstack_copied);
   gcFIXUP(c->runstack_owner);
@@ -932,15 +938,19 @@ static int cont_proc_FIXUP(void *p) {
   FIXUP_jmpup(&c->buf);
   FIXUP_cjs(&c->cjs);
   FIXUP_stack_state(&c->ss);
+  gcFIXUP(c->barrier_prompt);
   gcFIXUP(c->runstack_start);
   gcFIXUP(c->runstack_saved);
 
+  gcFIXUP(c->prompt_id);
+
   /* These shouldn't actually persist across a GC, but
      just in case... */
   gcFIXUP(c->value);
   gcFIXUP(c->resume_to);
   gcFIXUP(c->use_next_cont);
   gcFIXUP(c->extra_marks);
+  gcFIXUP(c->shortcut_prompt);
   
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Cont));
@@ -1090,6 +1100,7 @@ static int escaping_cont_proc_MARK(void *p) {
   gcMARK(c->native_trace);
 #endif
 
+  gcMARK(c->barrier_prompt);
   MARK_stack_state(&c->envss);
 
   return
@@ -1103,6 +1114,7 @@ static int escaping_cont_proc_FIXUP(void *p) {
   gcFIXUP(c->native_trace);
 #endif
 
+  gcFIXUP(c->barrier_prompt);
   FIXUP_stack_state(&c->envss);
 
   return
@@ -1574,7 +1586,6 @@ static int thread_val_MARK(void *p) {
   gcMARK(pr->runstack_swapped);
   pr->spare_runstack = NULL; /* just in case */
 
-  gcMARK(pr->barrier_prompt);
   gcMARK(pr->meta_prompt);
   gcMARK(pr->meta_continuation);
   
@@ -1664,7 +1675,6 @@ static int thread_val_FIXUP(void *p) {
   gcFIXUP(pr->runstack_swapped);
   pr->spare_runstack = NULL; /* just in case */
 
-  gcFIXUP(pr->barrier_prompt);
   gcFIXUP(pr->meta_prompt);
   gcFIXUP(pr->meta_continuation);
   
@@ -1740,8 +1750,9 @@ static int prompt_val_SIZE(void *p) {
 static int prompt_val_MARK(void *p) {
   Scheme_Prompt *pr = (Scheme_Prompt *)p;
   gcMARK(pr->boundary_overflow_id);
-  gcMARK(pr->boundary_dw_id);
   gcMARK(pr->runstack_boundary_start);
+  gcMARK(pr->tag);
+  gcMARK(pr->id);
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Prompt));
 }
@@ -1749,8 +1760,9 @@ static int prompt_val_MARK(void *p) {
 static int prompt_val_FIXUP(void *p) {
   Scheme_Prompt *pr = (Scheme_Prompt *)p;
   gcFIXUP(pr->boundary_overflow_id);
-  gcFIXUP(pr->boundary_dw_id);
   gcFIXUP(pr->runstack_boundary_start);
+  gcFIXUP(pr->tag);
+  gcFIXUP(pr->id);
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Prompt));
 }

src/mzscheme/src/mzmarksrc.c

@@ -331,6 +331,7 @@ cont_proc {
   gcMARK(c->dw);
   gcMARK(c->prompt_tag);
   gcMARK(c->meta_continuation);
+  gcMARK(c->common_dw);
   gcMARK(c->save_overflow);
   gcMARK(c->runstack_copied);
   gcMARK(c->runstack_owner);
@@ -345,15 +346,19 @@ cont_proc {
   MARK_jmpup(&c->buf);
   MARK_cjs(&c->cjs);
   MARK_stack_state(&c->ss);
+  gcMARK(c->barrier_prompt);
   gcMARK(c->runstack_start);
   gcMARK(c->runstack_saved);
 
+  gcMARK(c->prompt_id);
+
   /* These shouldn't actually persist across a GC, but
      just in case... */
   gcMARK(c->value);
   gcMARK(c->resume_to);
   gcMARK(c->use_next_cont);
   gcMARK(c->extra_marks);
+  gcMARK(c->shortcut_prompt);
   
  size:
   gcBYTES_TO_WORDS(sizeof(Scheme_Cont));
@@ -417,6 +422,7 @@ escaping_cont_proc {
   gcMARK(c->native_trace);
 #endif
 
+  gcMARK(c->barrier_prompt);
   MARK_stack_state(&c->envss);
 
  size:
@@ -610,7 +616,6 @@ thread_val {
   gcMARK(pr->runstack_swapped);
   pr->spare_runstack = NULL; /* just in case */
 
-  gcMARK(pr->barrier_prompt);
   gcMARK(pr->meta_prompt);
   gcMARK(pr->meta_continuation);
   
@@ -678,8 +683,9 @@ prompt_val {
  mark: 
   Scheme_Prompt *pr = (Scheme_Prompt *)p;
   gcMARK(pr->boundary_overflow_id);
-  gcMARK(pr->boundary_dw_id);
   gcMARK(pr->runstack_boundary_start);
+  gcMARK(pr->tag);
+  gcMARK(pr->id);
  size:
   gcBYTES_TO_WORDS(sizeof(Scheme_Prompt));
 }

src/mzscheme/src/network.c

@@ -2286,15 +2286,15 @@ static Scheme_Object *tcp_addresses(int argc, Scheme_Object *argv[])
   Scheme_Object *result[4];
   int with_ports = 0;
 
-  if (SCHEME_OUTPORTP(argv[0])) {
+  if (SCHEME_OUTPUT_PORTP(argv[0])) {
     Scheme_Output_Port *op;
-    op = (Scheme_Output_Port *)argv[0];
+    op = scheme_output_port_record(argv[0]);
     if (op->sub_type == scheme_tcp_output_port_type)
       tcp = op->port_data;
     closed = op->closed;
-  } else if (SCHEME_INPORTP(argv[0])) {
+  } else if (SCHEME_INPUT_PORTP(argv[0])) {
     Scheme_Input_Port *ip;
-    ip = (Scheme_Input_Port *)argv[0];
+    ip = scheme_input_port_record(argv[0]);
     if (ip->sub_type == scheme_tcp_input_port_type)
       tcp = ip->port_data;
     closed = ip->closed;
@@ -2375,9 +2375,9 @@ static Scheme_Object *tcp_addresses(int argc, Scheme_Object *argv[])
 static Scheme_Object *tcp_abandon_port(int argc, Scheme_Object *argv[])
 {
 #ifdef USE_TCP
-  if (SCHEME_OUTPORTP(argv[0])) {
+  if (SCHEME_OUTPUT_PORTP(argv[0])) {
     Scheme_Output_Port *op;
-    op = (Scheme_Output_Port *)argv[0];
+    op = scheme_output_port_record(argv[0]);
     if (op->sub_type == scheme_tcp_output_port_type) {
       if (!op->closed) {
 	((Scheme_Tcp *)op->port_data)->flags |= MZ_TCP_ABANDON_OUTPUT;
@@ -2385,11 +2385,11 @@ static Scheme_Object *tcp_abandon_port(int argc, Scheme_Object *argv[])
       }
       return scheme_void;
     }
-  } else if (SCHEME_INPORTP(argv[0])) {
+  } else if (SCHEME_INPUT_PORTP(argv[0])) {
     /* Abandon is not really useful on input ports from the Schemer's
        perspective, but it's here for completeness. */
     Scheme_Input_Port *ip;
-    ip = (Scheme_Input_Port *)argv[0];
+    ip = scheme_input_port_record(argv[0]);
     if (ip->sub_type == scheme_tcp_input_port_type) {
       if (!ip->closed) {
 	((Scheme_Tcp *)ip->port_data)->flags |= MZ_TCP_ABANDON_INPUT;
@@ -2408,12 +2408,16 @@ static Scheme_Object *tcp_abandon_port(int argc, Scheme_Object *argv[])
 static Scheme_Object *tcp_port_p(int argc, Scheme_Object *argv[])
 {
 #ifdef USE_TCP
-  if (SCHEME_OUTPORTP(argv[0])) {
+  if (SCHEME_OUTPUT_PORTP(argv[0])) {
-    if (((Scheme_Output_Port *)argv[0])->sub_type == scheme_tcp_output_port_type) {
+    Scheme_Output_Port *op;
+    op = scheme_output_port_record(argv[0]);
+    if (op->sub_type == scheme_tcp_output_port_type) {
       return scheme_true;
     }
-  } else if (SCHEME_INPORTP(argv[0])) {
+  } else if (SCHEME_INPUT_PORTP(argv[0])) {
-    if (((Scheme_Input_Port *)argv[0])->sub_type == scheme_tcp_input_port_type) {
+    Scheme_Input_Port *ip;
+    ip = scheme_input_port_record(argv[0]);
+    if (ip->sub_type == scheme_tcp_input_port_type) {
       return scheme_true;
     }
   }
@@ -2462,18 +2466,18 @@ int scheme_get_port_socket(Scheme_Object *p, long *_s)
   tcp_t s = 0;
   int s_ok = 0;
 
-  if (SCHEME_OUTPORTP(p)) {
+  if (SCHEME_OUTPUT_PORTP(p)) {
     Scheme_Output_Port *op;
-    op = (Scheme_Output_Port *)p;
+    op = scheme_output_port_record(p);
     if (op->sub_type == scheme_tcp_output_port_type) {
       if (!op->closed) {
 	s = ((Scheme_Tcp *)op->port_data)->tcp;
 	s_ok = 1;
       }
     }
-  } else if (SCHEME_INPORTP(p)) {
+  } else if (SCHEME_INPUT_PORTP(p)) {
     Scheme_Input_Port *ip;
-    ip = (Scheme_Input_Port *)p;
+    ip = scheme_input_port_record(p);
     if (ip->sub_type == scheme_tcp_input_port_type) {
       if (!ip->closed) {
 	s = ((Scheme_Tcp *)ip->port_data)->tcp;

src/mzscheme/src/port.c

@@ -1113,7 +1113,7 @@ static int output_ready(Scheme_Object *port, Scheme_Schedule_Info *sinfo)
 {
   Scheme_Output_Port *op;
 
-  op = (Scheme_Output_Port *)port;
+  op = scheme_output_port_record(port);
 
   if (op->closed)
     return 1;
@@ -1144,7 +1144,7 @@ static void output_need_wakeup (Scheme_Object *port, void *fds)
   /* If this is a user output port and its evt needs a wakeup, we
      shouldn't get here. The target use above will take care of it. */
 
-  op = (Scheme_Output_Port *)port;
+  op = scheme_output_port_record(port);
   if (op->need_wakeup_fun) {
     Scheme_Need_Wakeup_Output_Fun f;
     f = op->need_wakeup_fun;
@@ -1154,7 +1154,9 @@ static void output_need_wakeup (Scheme_Object *port, void *fds)
 
 int scheme_byte_ready_or_user_port_ready(Scheme_Object *p, Scheme_Schedule_Info *sinfo)
 {
-  Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
+  Scheme_Input_Port *ip;
+
+  ip = scheme_input_port_record(p);
 
   if (ip->closed)
     return 1;
@@ -1185,7 +1187,10 @@ XFORM_NONGCING static int pipe_char_count(Scheme_Object *p)
 {
   if (p) {
     Scheme_Pipe *pipe;
-    pipe = (Scheme_Pipe *)((Scheme_Input_Port *)p)->port_data;
+    Scheme_Input_Port *ip;
+
+    ip = (Scheme_Input_Port *)p;
+    pipe = (Scheme_Pipe *)ip->port_data;
 
     if (pipe->bufstart <= pipe->bufend)
       return pipe->bufend - pipe->bufstart;
@@ -1357,7 +1362,7 @@ long scheme_get_byte_string_unless(const char *who,
   if (!peek_skip)
     peek_skip = scheme_make_integer(0);
 
-  ip = (Scheme_Input_Port *)port;
+  ip = scheme_input_port_record(port);
 
   gs = ip->get_string_fun;
   ps = ip->peek_string_fun;
@@ -1769,7 +1774,9 @@ static void elect_new_main(Scheme_Input_Port *ip)
 
 static void release_input_lock_and_elect_new_main(void *_ip)
 {
-  Scheme_Input_Port *ip = (Scheme_Input_Port *)_ip;
+  Scheme_Input_Port *ip;
+
+  ip = scheme_input_port_record(_ip);
 
   release_input_lock(ip);
   elect_new_main(ip);
@@ -1783,9 +1790,11 @@ static void check_suspended()
 
 static void remove_extra(void *ip_v)
 {
-  Scheme_Input_Port *ip = (Scheme_Input_Port *)SCHEME_CAR(ip_v);
+  Scheme_Input_Port *ip;
   Scheme_Object *v = SCHEME_CDR(ip_v), *ll, *prev;
 
+  ip = scheme_input_port_record(SCHEME_CAR(ip_v));
+
   prev = NULL;
   for (ll = ip->input_extras; ll; prev = ll, ll = SCHEME_CDR(ll)) {
     if (SAME_OBJ(ll, SCHEME_CDR(v))) {
@@ -2040,7 +2049,7 @@ int scheme_peeked_read(Scheme_Object *port,
   Scheme_Input_Port *ip;
   Scheme_Peeked_Read_Fun pr;
   
-  ip = (Scheme_Input_Port *)port;
+  ip = scheme_input_port_record(port);
 
   unless_evt = SCHEME_PTR2_VAL(unless_evt);
 
@@ -2067,7 +2076,7 @@ Scheme_Object *scheme_progress_evt(Scheme_Object *port)
 {  
   Scheme_Input_Port *ip;
   
-  ip = (Scheme_Input_Port *)port;
+  ip = scheme_input_port_record(port);
   
   if (ip->progress_evt_fun) {
     Scheme_Progress_Evt_Fun ce;
@@ -2260,7 +2269,7 @@ long get_one_byte(const char *who,
 
   special_is_ok = 0;
 
-  ip = (Scheme_Input_Port *)port;
+  ip = scheme_input_port_record(port);
 
   CHECK_PORT_CLOSED(who, "input", port, ip->closed);
 
@@ -2554,7 +2563,7 @@ int scheme_peekc_is_ungetc(Scheme_Object *port)
 {
   Scheme_Input_Port *ip;
 
-  ip = (Scheme_Input_Port *)port;
+  ip = scheme_input_port_record(port);
 
   return !ip->peek_string_fun;
 }
@@ -2589,8 +2598,13 @@ static int rw_evt_ready(Scheme_Object *_rww, Scheme_Schedule_Info *sinfo)
   }
   
   if (rww->v) {
-    Scheme_Write_Special_Fun ws = ((Scheme_Output_Port *)rww->port)->write_special_fun;
+    Scheme_Output_Port *op;
-    v = ws((Scheme_Output_Port *)rww->port, rww->v, 1);
+    Scheme_Write_Special_Fun ws;
+
+    op = scheme_output_port_record(rww->port);
+    ws = op->write_special_fun;
+
+    v = ws(op, rww->v, 1);
     if (v) {
       scheme_set_sync_target(sinfo, scheme_true, NULL, NULL, 0, 0);
       return 1;
@@ -2640,7 +2654,9 @@ Scheme_Object *scheme_write_special_evt_via_write_special(Scheme_Output_Port *po
 Scheme_Object *scheme_make_write_evt(const char *who, Scheme_Object *port,
 				     Scheme_Object *special, char *str, long start, long size)
 {
-  Scheme_Output_Port *op = (Scheme_Output_Port *)port;
+  Scheme_Output_Port *op;
+
+  op = scheme_output_port_record(port);
 
   if (!special) {
     if (op->write_string_evt_fun) {
@@ -2666,7 +2682,7 @@ scheme_ungetc (int ch, Scheme_Object *port)
 {
   Scheme_Input_Port *ip;
 
-  ip = (Scheme_Input_Port *)port;
+  ip = scheme_input_port_record(port);
 
   CHECK_PORT_CLOSED("#<primitive:peek-port-char>", "input", port, ip->closed);
 
@@ -2716,7 +2732,7 @@ scheme_byte_ready (Scheme_Object *port)
   Scheme_Input_Port *ip;
   int retval;
 
-  ip = (Scheme_Input_Port *)port;
+  ip = scheme_input_port_record(port);
 
   CHECK_PORT_CLOSED("char-ready?", "input", port, ip->closed);
 
@@ -2756,7 +2772,7 @@ Scheme_Object *scheme_get_special(Scheme_Object *port,
 
   SCHEME_USE_FUEL(1);
 
-  ip = (Scheme_Input_Port *)port;
+  ip = scheme_input_port_record(port);
 
   /* Only `read' and similar internals should call this function. A
      caller must should ensure that there are no ungotten
@@ -2815,7 +2831,9 @@ static Scheme_Object *do_get_ready_special(Scheme_Object *port,
   long line, col, pos;
 
   if (!stxsrc) {
-    stxsrc = ((Scheme_Input_Port *)port)->name;
+    Scheme_Input_Port *ip;
+    ip = scheme_input_port_record(port);
+    stxsrc = ip->name;
   }
 
   /* Don't use scheme_tell_all(), because we always want the
@@ -2880,7 +2898,7 @@ Scheme_Object *scheme_get_special_proc(Scheme_Object *inport)
   Scheme_Object *special, **sbox;
   Scheme_Input_Port *ip;
 
-  ip = (Scheme_Input_Port *)inport;
+  ip = scheme_input_port_record(inport);
   special = ip->special;
   ip->special = NULL;
   
@@ -2896,7 +2914,7 @@ scheme_need_wakeup (Scheme_Object *port, void *fds)
 {
   Scheme_Input_Port *ip;
 
-  ip = (Scheme_Input_Port *)port;
+  ip = scheme_input_port_record(port);
 
   if (ip->need_wakeup_fun) {
     Scheme_Need_Wakeup_Input_Fun f = ip->need_wakeup_fun;
@@ -2905,7 +2923,7 @@ scheme_need_wakeup (Scheme_Object *port, void *fds)
 }
 
 #define CHECK_IOPORT_CLOSED(who, port) \
-        if (SCHEME_INPORTP(port)) { \
+        if (SCHEME_INPORTP((Scheme_Object *)port)) {                          \
           CHECK_PORT_CLOSED(who, "input", port, ((Scheme_Input_Port *)port)->closed); \
         } else { \
           CHECK_PORT_CLOSED(who, "output", port, ((Scheme_Output_Port *)port)->closed); \
@@ -2917,9 +2935,9 @@ scheme_tell (Scheme_Object *port)
   Scheme_Port *ip;
   long pos;
 
-  ip = (Scheme_Port *)port;
+  ip = scheme_port_record(port);
   
-  CHECK_IOPORT_CLOSED("get-file-position", port);
+  CHECK_IOPORT_CLOSED("get-file-position", ip);
 
   if (!ip->count_lines || (ip->position < 0))
     pos = ip->position;
@@ -2935,12 +2953,12 @@ scheme_tell_line (Scheme_Object *port)
   Scheme_Port *ip;
   long line;
 
-  ip = (Scheme_Port *)port;
+  ip = scheme_port_record(port);
 
   if (!ip->count_lines || (ip->position < 0))
     return -1;
 
-  CHECK_IOPORT_CLOSED("get-file-line", port);
+  CHECK_IOPORT_CLOSED("get-file-line", ip);
 
   line = ip->lineNumber;
 
@@ -2953,12 +2971,12 @@ scheme_tell_column (Scheme_Object *port)
   Scheme_Port *ip;
   long col;
 
-  ip = (Scheme_Port *)port;
+  ip = scheme_port_record(port);
 
   if (!ip->count_lines || (ip->position < 0))
     return -1;
   
-  CHECK_IOPORT_CLOSED("get-file-column", port);
+  CHECK_IOPORT_CLOSED("get-file-column", ip);
 
   col = ip->column;
 
@@ -2968,9 +2986,11 @@ scheme_tell_column (Scheme_Object *port)
 void
 scheme_tell_all (Scheme_Object *port, long *_line, long *_col, long *_pos)
 {
-  Scheme_Port *ip = (Scheme_Port *)port;
+  Scheme_Port *ip;
   long line = -1, col = -1, pos = -1;
   
+  ip = scheme_port_record(port);
+
   if (ip->count_lines && ip->location_fun) {
     Scheme_Location_Fun location_fun;
     Scheme_Object *r, *a[3];
@@ -3039,7 +3059,9 @@ scheme_tell_all (Scheme_Object *port, long *_line, long *_col, long *_pos)
 void
 scheme_count_lines (Scheme_Object *port)
 {
-  Scheme_Port *ip = (Scheme_Port *)port;
+  Scheme_Port *ip;
+
+  ip = scheme_port_record(port);
 
   if (!ip->count_lines) {
     ip->count_lines = 1;
@@ -3055,7 +3077,7 @@ scheme_close_input_port (Scheme_Object *port)
 {
   Scheme_Input_Port *ip;
 
-  ip = (Scheme_Input_Port *)port;
+  ip = scheme_input_port_record(port);
 
   if (!ip->closed) {
     if (ip->close_fun) {
@@ -3103,11 +3125,13 @@ scheme_put_byte_string(const char *who, Scheme_Object *port,
      have to deal with peeks and specials, so it's a thin wrapper on
      the port's function. */
 
-  Scheme_Output_Port *op = (Scheme_Output_Port *)port;
+  Scheme_Output_Port *op;
   Scheme_Write_String_Fun ws;
   long out, llen, oout;
   int enable_break;
 
+  op = scheme_output_port_record(port);
+
   CHECK_PORT_CLOSED(who, "output", port, op->closed);
 
   ws = op->write_string_fun;
@@ -3203,7 +3227,7 @@ scheme_close_output_port(Scheme_Object *port)
 {
   Scheme_Output_Port *op;
 
-  op = (Scheme_Output_Port *)port;
+  op = scheme_output_port_record(port);
 
   if (!op->closed) {
     /* call close function first; it might raise an exception */
@@ -3255,8 +3279,10 @@ scheme_file_stream_port_p (int argc, Scheme_Object *argv[])
 {
   Scheme_Object *p = argv[0];
 
-  if (SCHEME_INPORTP(p)) {
+  if (SCHEME_INPUT_PORTP(p)) {
-    Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
+    Scheme_Input_Port *ip;
+
+    ip = scheme_input_port_record(p);
 
     if (SAME_OBJ(ip->sub_type, file_input_port_type))
       return scheme_true;
@@ -3264,8 +3290,10 @@ scheme_file_stream_port_p (int argc, Scheme_Object *argv[])
     else if (SAME_OBJ(ip->sub_type, fd_input_port_type))
       return scheme_true;
 #endif
-  } else if (SCHEME_OUTPORTP(p)) {
+  } else if (SCHEME_OUTPUT_PORTP(p)) {
-    Scheme_Output_Port *op = (Scheme_Output_Port *)p;
+    Scheme_Output_Port *op;
+
+    op = scheme_output_port_record(p);
 
     if (SAME_OBJ(op->sub_type, file_output_port_type))
       return scheme_true;
@@ -3285,8 +3313,10 @@ int scheme_get_port_file_descriptor(Scheme_Object *p, long *_fd)
   long fd = 0;
   int fd_ok = 0;
 
-  if (SCHEME_INPORTP(p)) {
+  if (SCHEME_INPUT_PORTP(p)) {
-    Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
+    Scheme_Input_Port *ip;
+
+    ip = scheme_input_port_record(p);
 
     if (!ip->closed) {
       if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
@@ -3300,8 +3330,10 @@ int scheme_get_port_file_descriptor(Scheme_Object *p, long *_fd)
       }
 #endif
     }
-  } else if (SCHEME_OUTPORTP(p)) {
+  } else if (SCHEME_OUTPUT_PORTP(p)) {
-    Scheme_Output_Port *op = (Scheme_Output_Port *)p;
+    Scheme_Output_Port *op;
+
+    op = scheme_output_port_record(p);
 
     if (!op->closed) {
       if (SAME_OBJ(op->sub_type, file_output_port_type))  {
@@ -3336,12 +3368,16 @@ Scheme_Object *scheme_file_identity(int argc, Scheme_Object *argv[])
 
   if (!fd_ok) {
     /* Maybe failed because it was closed... */
-    if (SCHEME_INPORTP(p)) {
+    if (SCHEME_INPUT_PORTP(p)) {
-      Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
+      Scheme_Input_Port *ip;
+
+      ip = scheme_input_port_record(p);
       
       CHECK_PORT_CLOSED("port-file-identity", "input", p, ip->closed);
-    } else if (SCHEME_OUTPORTP(p)) {
+    } else if (SCHEME_OUTPUT_PORTP(p)) {
-      Scheme_Output_Port *op = (Scheme_Output_Port *)p;
+      Scheme_Output_Port *op;
+      
+      op = scheme_output_port_record(p);
       
       CHECK_PORT_CLOSED("port-file-identity", "output", p, op->closed);
     }
@@ -3374,8 +3410,10 @@ Scheme_Object *scheme_terminal_port_p(int argc, Scheme_Object *argv[])
 
   p = argv[0];
 
-  if (SCHEME_INPORTP(p)) {
+  if (SCHEME_INPUT_PORTP(p)) {
-    Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
+    Scheme_Input_Port *ip;
+
+    ip = scheme_input_port_record(p);
 
     if (ip->closed)
       return scheme_false;
@@ -3390,8 +3428,10 @@ Scheme_Object *scheme_terminal_port_p(int argc, Scheme_Object *argv[])
       fd_ok = 1;
     }
 #endif
-  } else if (SCHEME_OUTPORTP(p)) {
+  } else if (SCHEME_OUTPUT_PORTP(p)) {
-    Scheme_Output_Port *op = (Scheme_Output_Port *)p;
+    Scheme_Output_Port *op;
+
+    op = scheme_output_port_record(p);
 
     if (op->closed)
       return scheme_false;
@@ -3999,7 +4039,7 @@ scheme_file_position(int argc, Scheme_Object *argv[])
 #endif
   int wis;
 
-  if (!SCHEME_OUTPORTP(argv[0]) && !SCHEME_INPORTP(argv[0]))
+  if (!SCHEME_OUTPUT_PORTP(argv[0]) && !SCHEME_INPUT_PORTP(argv[0]))
     scheme_wrong_type("file-position", "port", 0, argc, argv);
   if (argc == 2) {
     if (!SCHEME_EOFP(argv[1])) {
@@ -4026,10 +4066,11 @@ scheme_file_position(int argc, Scheme_Object *argv[])
   had_fd = 0;
 #endif
 
-  if (SCHEME_OUTPORTP(argv[0])) {
+  if (!SCHEME_INPUT_PORTP(argv[0])) {
     Scheme_Output_Port *op;
 
-    op = (Scheme_Output_Port *)argv[0];
+    op = scheme_output_port_record(argv[0]);
+
     if (SAME_OBJ(op->sub_type, file_output_port_type)) {
       f = ((Scheme_Output_File *)op->port_data)->f;
 #ifdef MZ_FDS
@@ -4042,10 +4083,11 @@ scheme_file_position(int argc, Scheme_Object *argv[])
       wis = 1;
     } else if (argc < 2)
       return scheme_make_integer(scheme_output_tell(argv[0]));
-  } else if (SCHEME_INPORTP(argv[0])) {
+  } else {
     Scheme_Input_Port *ip;
 
-    ip = (Scheme_Input_Port *)argv[0];
+    ip = scheme_input_port_record(argv[0]);
+
     if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
       f = ((Scheme_Input_File *)ip->port_data)->f;
 #ifdef MZ_FDS
@@ -4057,7 +4099,7 @@ scheme_file_position(int argc, Scheme_Object *argv[])
       is = (Scheme_Indexed_String *)ip->port_data;
     else if (argc < 2) {
       long pos;
-      pos = ((Scheme_Input_Port *)argv[0])->p.position;
+      pos = ip->p.position;
       if (pos < 0) {
 	scheme_raise_exn(MZEXN_FAIL,
 			 "the port's current position is not known: %v",
@@ -4106,8 +4148,8 @@ scheme_file_position(int argc, Scheme_Object *argv[])
     } else if (had_fd) {
       long lv;
       
-      if (SCHEME_OUTPORTP(argv[0])) {
+      if (!SCHEME_INPUT_PORTP(argv[0])) {
-	flush_fd((Scheme_Output_Port *)argv[0], NULL, 0, 0, 0, 0);
+	flush_fd(scheme_output_port_record(argv[0]), NULL, 0, 0, 0, 0);
       }
       
 # ifdef WINDOWS_FILE_HANDLES
@@ -4138,14 +4180,16 @@ scheme_file_position(int argc, Scheme_Object *argv[])
 			 errno);
       }
 
-      if (SCHEME_INPORTP(argv[0])) {
+      if (SCHEME_INPUT_PORTP(argv[0])) {
 	/* Get rid of buffered data: */
 	Scheme_FD *sfd;
-	sfd = (Scheme_FD *)((Scheme_Input_Port *)argv[0])->port_data;
+        Scheme_Input_Port *ip;
+        ip = scheme_input_port_record(argv[0]);
+	sfd = (Scheme_FD *)ip->port_data;
 	sfd->bufcount = 0;
 	sfd->buffpos = 0;
 	/* 1 means no pending eof, but can set: */
-	((Scheme_Input_Port *)argv[0])->pending_eof = 1;
+	ip->pending_eof = 1;
       }
 #endif
     } else {
@@ -4182,9 +4226,9 @@ scheme_file_position(int argc, Scheme_Object *argv[])
     }
 
     /* Remove any chars saved from peeks: */
-    if (SCHEME_INPORTP(argv[0])) {
+    if (SCHEME_INPUT_PORTP(argv[0])) {
       Scheme_Input_Port *ip;
-      ip = (Scheme_Input_Port *)argv[0];
+      ip = scheme_input_port_record(argv[0]);
       ip->ungotten_count = 0;
       if (pipe_char_count(ip->peeked_read)) {
 	ip->peeked_read = NULL;
@@ -4216,16 +4260,20 @@ scheme_file_position(int argc, Scheme_Object *argv[])
 #  endif
 # endif
       if (p < 0) {
-	if (SCHEME_INPORTP(argv[0])) {
+	if (SCHEME_INPUT_PORTP(argv[0])) {
 	  p = scheme_tell(argv[0]);
 	} else {
 	  p = scheme_output_tell(argv[0]);
 	}
       } else {
-	if (SCHEME_OUTPORTP(argv[0])) {
+	if (SCHEME_INPUT_PORTP(argv[0])) {          
-	  p += ((Scheme_FD *)((Scheme_Output_Port *)argv[0])->port_data)->bufcount;
+          Scheme_Input_Port *ip;
+          ip = scheme_input_port_record(argv[0]);
+	  p -= ((Scheme_FD *)ip->port_data)->bufcount;
 	} else {
-	  p -= ((Scheme_FD *)((Scheme_Input_Port *)argv[0])->port_data)->bufcount;
+          Scheme_Output_Port *op;
+          op = scheme_output_port_record(argv[0]);
+	  p += ((Scheme_FD *)op->port_data)->bufcount;
 	}
       }
 #endif
@@ -4240,9 +4288,9 @@ scheme_file_position(int argc, Scheme_Object *argv[])
     }
 
     /* Back up for un-gotten & peeked chars: */
-    if (SCHEME_INPORTP(argv[0])) {
+    if (SCHEME_INPUT_PORTP(argv[0])) {
       Scheme_Input_Port *ip;
-      ip = (Scheme_Input_Port *)argv[0];
+      ip = scheme_input_port_record(argv[0]);
       p -= ip->ungotten_count;
       p -= pipe_char_count(ip->peeked_read);
     }
@@ -4272,10 +4320,10 @@ scheme_file_buffer(int argc, Scheme_Object *argv[])
 {
   Scheme_Port *p = NULL;
 
-  if (!SCHEME_OUTPORTP(argv[0]) && !SCHEME_INPORTP(argv[0]))
+  if (!SCHEME_OUTPUT_PORTP(argv[0]) && !SCHEME_INPUT_PORTP(argv[0]))
     scheme_wrong_type("file-stream-buffer-mode", "port", 0, argc, argv);
 
-  p = (Scheme_Port *)argv[0];
+  p = scheme_port_record(argv[0]);
 
   if (argc == 1) {
     Scheme_Buffer_Mode_Fun bm;
@@ -4302,7 +4350,7 @@ scheme_file_buffer(int argc, Scheme_Object *argv[])
 	&& !SAME_OBJ(s, scheme_none_symbol))
       scheme_wrong_type("file-stream-buffer-mode", "'none, 'line, or 'block", 1, argc, argv);
 
-    if (SCHEME_INPORTP(argv[0]) && SAME_OBJ(s, scheme_line_symbol))
+    if (SCHEME_INPUT_PORTP(argv[0]) && SAME_OBJ(s, scheme_line_symbol))
       scheme_arg_mismatch("file-stream-buffer-mode", 
 			  "'line buffering not supported for an input port: ",
 			  argv[0]);
@@ -4393,10 +4441,13 @@ file_buffer_mode(Scheme_Port *p, int mode)
   if (mode < 0)
     return -1; /* unknown mode */
 
-  if (SCHEME_INPORTP(p))
+  if (SCHEME_INPORTP((Scheme_Object *)p)) {
-    f = ((Scheme_Output_File *)((Scheme_Input_Port *)p)->port_data)->f;
+    Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
-  else
+    f = ((Scheme_Output_File *)ip->port_data)->f;
-    f = ((Scheme_Output_File *)((Scheme_Output_Port *)p)->port_data)->f;
+  } else {
+    Scheme_Output_Port *op = (Scheme_Output_Port *)p;
+    f = ((Scheme_Output_File *)op->port_data)->f;
+  }
   
   if (mode == MZ_FLUSH_NEVER)
     bad = setvbuf(f, NULL, _IOFBF, 0);
@@ -4945,8 +4996,9 @@ fd_need_wakeup(Scheme_Input_Port *port, void *fds)
 static int fd_input_buffer_mode(Scheme_Port *p, int mode)
 {
   Scheme_FD *fd;
+  Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
     
-  fd = (Scheme_FD *)((Scheme_Input_Port *)p)->port_data;
+  fd = (Scheme_FD *)ip->port_data;
 
   if (mode < 0) {
     return fd->flush;
@@ -5447,8 +5499,11 @@ static int
 fd_flush_done(Scheme_Object *port)
 {
   Scheme_FD *fop;
+  Scheme_Output_Port *op;
 
-  fop = (Scheme_FD *)((Scheme_Output_Port *)port)->port_data;
+  op = scheme_output_port_record(port);
+
+  fop = (Scheme_FD *)op->port_data;
 
   return !fop->flushing;
 }
@@ -5506,10 +5561,12 @@ fd_write_ready (Scheme_Object *port)
      the port has been flushed. */
 
   Scheme_FD *fop;
+  Scheme_Output_Port *op;
 
-  fop = (Scheme_FD *)((Scheme_Output_Port *)port)->port_data;
+  op = scheme_output_port_record(port);
+  fop = (Scheme_FD *)op->port_data;
 
-  if (fop->regfile || ((Scheme_Output_Port *)port)->closed)
+  if (fop->regfile || op->closed)
     return 1;
 
 #ifdef WINDOWS_FILE_HANDLES
@@ -5568,6 +5625,7 @@ fd_write_ready (Scheme_Object *port)
 static void
 fd_write_need_wakeup(Scheme_Object *port, void *fds)
 {
+  Scheme_Output_Port *op;
   Scheme_FD *fop;
 
 #ifdef WINDOWS_FILE_HANDLES
@@ -5579,7 +5637,8 @@ fd_write_need_wakeup(Scheme_Object *port, void *fds)
 # endif
 #endif
 
-  fop = (Scheme_FD *)((Scheme_Output_Port *)port)->port_data;
+  op = scheme_output_port_record(port);
+  fop = (Scheme_FD *)op->port_data;
 
 #ifdef WINDOWS_FILE_HANDLES
   if (fop->oth && !fd_write_ready(port))
@@ -6150,8 +6209,9 @@ fd_close_output(Scheme_Output_Port *port)
 static int fd_output_buffer_mode(Scheme_Port *p, int mode)
 {
   Scheme_FD *fd;
+  Scheme_Output_Port *op = (Scheme_Output_Port *)p;
 
-  fd = (Scheme_FD *)((Scheme_Output_Port *)p)->port_data;
+  fd = (Scheme_FD *)op->port_data;
   
   if (mode < 0) {
     return fd->flush;
@@ -6160,7 +6220,7 @@ static int fd_output_buffer_mode(Scheme_Port *p, int mode)
     go = (mode > fd->flush);
     fd->flush = mode;
     if (go)
-      flush_fd((Scheme_Output_Port *)p, NULL, 0, 0, 0, 0);
+      flush_fd(op, NULL, 0, 0, 0, 0);
     return mode;
   }
 }
@@ -6232,8 +6292,9 @@ make_fd_output_port(int fd, Scheme_Object *name, int regfile, int win_textmode,
 
 static void flush_if_output_fds(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data)
 {
-  if (SCHEME_OUTPORTP(o)) {
+  if (SCHEME_OUTPUT_PORTP(o)) {
-    Scheme_Output_Port *op = (Scheme_Output_Port *)o;
+    Scheme_Output_Port *op;
+    op = scheme_output_port_record(o);
     if (SAME_OBJ(op->sub_type, fd_output_port_type)) {
       scheme_flush_output(o);
     }
@@ -6606,7 +6667,8 @@ scheme_make_redirect_output_port(Scheme_Object *port)
   Scheme_Output_Port *op;
   int can_write_special;
 
-  can_write_special = !!((Scheme_Output_Port *)port)->write_special_fun;
+  op = scheme_output_port_record(port);
+  can_write_special = !!op->write_special_fun;
 
   op = scheme_make_output_port(scheme_redirect_output_port_type,
 			       port,
@@ -6959,9 +7021,11 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
 
   if (SCHEME_TRUEP(args[0])) {
     outport = args[0];
-    if (SCHEME_OUTPORTP(outport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &outport))) {
+    if (SCHEME_OUTPUT_PORTP(outport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &outport))) {
 #ifdef PROCESS_FUNCTION
-      Scheme_Output_Port *op = (Scheme_Output_Port *)outport;
+      Scheme_Output_Port *op;
+
+      op = scheme_output_port_record(outport);
 
       if (SAME_OBJ(op->sub_type, file_output_port_type)) {
 	int tmp;
@@ -6980,9 +7044,11 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
 
   if (SCHEME_TRUEP(args[1])) {
     inport = args[1];
-    if (SCHEME_INPORTP(inport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &inport))) {
+    if (SCHEME_INPUT_PORTP(inport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &inport))) {
 #ifdef PROCESS_FUNCTION
-      Scheme_Input_Port *ip = (Scheme_Input_Port *)inport;
+      Scheme_Input_Port *ip;
+
+      ip = scheme_input_port_record(inport);
 
       if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
 	int tmp;
@@ -7001,9 +7067,11 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
 
   if (SCHEME_TRUEP(args[2])) {
     errport = args[2];
-    if (SCHEME_OUTPORTP(errport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &errport))) {
+    if (SCHEME_OUTPUT_PORTP(errport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &errport))) {
 #ifdef PROCESS_FUNCTION
-      Scheme_Output_Port *op = (Scheme_Output_Port *)errport;
+      Scheme_Output_Port *op;
+
+      op = scheme_output_port_record(errport);
 
       if (SAME_OBJ(op->sub_type, file_output_port_type)) {
 	int tmp;
@@ -8016,7 +8084,9 @@ void scheme_start_itimer_thread(long usec)
 void scheme_count_input_port(Scheme_Object *port, long *s, long *e,
 			     Scheme_Hash_Table *ht)
 {
-  Scheme_Input_Port *ip = (Scheme_Input_Port *)port;
+  Scheme_Input_Port *ip;
+
+  ip = scheme_input_port_record(port);
 
   *e = (ht ? scheme_count_memory(ip->read_handler, ht) : 0);
   *s = sizeof(Scheme_Input_Port);
@@ -8053,7 +8123,9 @@ void scheme_count_input_port(Scheme_Object *port, long *s, long *e,
 void scheme_count_output_port(Scheme_Object *port, long *s, long *e,
 			      Scheme_Hash_Table *ht)
 {
-  Scheme_Output_Port *op = (Scheme_Output_Port *)port;
+  Scheme_Output_Port *op;
+
+  op = scheme_output_port_record(port);
 
   *e = 0;
   *s = sizeof(Scheme_Output_Port);

src/mzscheme/src/portfun.c

@@ -144,6 +144,8 @@ Scheme_Object *scheme_default_global_print_handler;
 
 Scheme_Object *scheme_write_proc, *scheme_display_proc, *scheme_print_proc;
 
+static Scheme_Object *dummy_input_port, *dummy_output_port;
+
 #define fail_err_symbol scheme_false
 
 /*========================================================================*/
@@ -753,6 +755,98 @@ void scheme_init_port_fun_config(void)
 			scheme_default_global_print_handler);
 }
 
+/*========================================================================*/
+/*                              port records                              */
+/*========================================================================*/
+
+Scheme_Port *scheme_port_record(Scheme_Object *port)
+{
+  if (scheme_is_input_port(port))
+    return (Scheme_Port *)scheme_input_port_record(port);
+  else
+    return (Scheme_Port *)scheme_output_port_record(port);
+}
+
+Scheme_Input_Port *scheme_input_port_record(Scheme_Object *port)
+{
+  Scheme_Object *v;
+
+  while (1) {
+    if (SCHEME_INPORTP(port))
+      return (Scheme_Input_Port *)port;
+
+    if (!SCHEME_STRUCTP(port)) {
+      /* Use dummy port: */
+      if (!dummy_input_port) {
+        REGISTER_SO(dummy_input_port);
+        dummy_input_port = scheme_make_byte_string_input_port("");
+      }
+      return (Scheme_Input_Port *)dummy_input_port;
+    }
+    
+    v = scheme_struct_type_property_ref(scheme_input_port_property, port);
+    if (!v)
+      v = scheme_false;
+    else if (SCHEME_INTP(v))
+      v = ((Scheme_Structure *)port)->slots[SCHEME_INT_VAL(v)];
+    port = v;
+
+    SCHEME_USE_FUEL(1);
+  }
+}
+
+Scheme_Output_Port *scheme_output_port_record(Scheme_Object *port)
+{
+  Scheme_Object *v;
+
+  while (1) {
+    if (SCHEME_OUTPORTP(port))
+      return (Scheme_Output_Port *)port;
+
+    if (!SCHEME_STRUCTP(port)) {
+      /* Use dummy port: */
+      if (!dummy_output_port) {
+        REGISTER_SO(dummy_output_port);
+        dummy_output_port = scheme_make_null_output_port(1);
+      }
+      return (Scheme_Output_Port *)dummy_output_port;
+    }
+    
+    v = scheme_struct_type_property_ref(scheme_output_port_property, port);
+    if (!v)
+      v = scheme_false;
+    else if (SCHEME_INTP(v))
+      v = ((Scheme_Structure *)port)->slots[SCHEME_INT_VAL(v)];
+    port = v;
+
+    SCHEME_USE_FUEL(1);
+  }
+}
+
+int scheme_is_input_port(Scheme_Object *port)
+{
+  if (SCHEME_INPORTP(port))
+    return 1;
+
+  if (SCHEME_STRUCTP(port))
+    if (scheme_struct_type_property_ref(scheme_input_port_property, port))
+      return 1;
+
+  return 0;
+}
+
+int scheme_is_output_port(Scheme_Object *port)
+{
+  if (SCHEME_OUTPORTP(port))
+    return 1;
+  
+  if (SCHEME_STRUCTP(port))
+    if (scheme_struct_type_property_ref(scheme_output_port_property, port))
+      return 1;
+
+  return 0;
+}
+
 /*========================================================================*/
 /*                          string input ports                            */
 /*========================================================================*/
@@ -960,10 +1054,10 @@ scheme_get_sized_byte_string_output(Scheme_Object *port, long *size)
   char *v;
   long len;
 
-  if (!SCHEME_OUTPORTP(port))
+  if (!SCHEME_OUTPUT_PORTP(port))
     return NULL;
 
-  op = (Scheme_Output_Port *)port;
+  op = scheme_output_port_record(port);
   if (op->sub_type != scheme_string_output_port_type)
     return NULL;
 
@@ -1379,8 +1473,8 @@ user_close_input(Scheme_Input_Port *port)
 static Scheme_Object *
 user_input_location(Scheme_Port *p)
 {
-  Scheme_Input_Port *port = (Scheme_Input_Port *)p;
+  Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
-  User_Input_Port *uip = (User_Input_Port *)port->port_data;
+  User_Input_Port *uip = (User_Input_Port *)ip->port_data;
 
   return scheme_apply_multi(uip->location_proc, 0, NULL);
 }
@@ -1388,8 +1482,8 @@ user_input_location(Scheme_Port *p)
 static void
 user_input_count_lines(Scheme_Port *p)
 {
-  Scheme_Input_Port *port = (Scheme_Input_Port *)p;
+  Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
-  User_Input_Port *uip = (User_Input_Port *)port->port_data;
+  User_Input_Port *uip = (User_Input_Port *)ip->port_data;
 
   scheme_apply_multi(uip->count_lines_proc, 0, NULL);
 }
@@ -1438,8 +1532,8 @@ user_buffer_mode(Scheme_Object *buffer_mode_proc, int mode, int line_ok)
 static int
 user_input_buffer_mode(Scheme_Port *p, int mode)
 {
-  Scheme_Input_Port *port = (Scheme_Input_Port *)p;
+  Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
-  User_Input_Port *uip = (User_Input_Port *)port->port_data;
+  User_Input_Port *uip = (User_Input_Port *)ip->port_data;
 
   return user_buffer_mode(uip->buffer_mode_proc, mode, 0);
 }
@@ -1736,8 +1830,8 @@ user_write_special_evt (Scheme_Output_Port *port, Scheme_Object *v)
 static Scheme_Object *
 user_output_location(Scheme_Port *p)
 {
-  Scheme_Output_Port *port = (Scheme_Output_Port *)p;
+  Scheme_Output_Port *op = (Scheme_Output_Port *)p;
-  User_Output_Port *uop = (User_Output_Port *)port->port_data;
+  User_Output_Port *uop = (User_Output_Port *)op->port_data;
 
   return scheme_apply_multi(uop->location_proc, 0, NULL);
 }
@@ -1745,8 +1839,8 @@ user_output_location(Scheme_Port *p)
 static void
 user_output_count_lines(Scheme_Port *p)
 {
-  Scheme_Output_Port *port = (Scheme_Output_Port *)p;
+  Scheme_Output_Port *op = (Scheme_Output_Port *)p;
-  User_Output_Port *uop = (User_Output_Port *)port->port_data;
+  User_Output_Port *uop = (User_Output_Port *)op->port_data;
 
   scheme_apply_multi(uop->count_lines_proc, 0, NULL);
 }
@@ -1754,20 +1848,22 @@ user_output_count_lines(Scheme_Port *p)
 static int
 user_output_buffer_mode(Scheme_Port *p, int mode)
 {
-  Scheme_Output_Port *port = (Scheme_Output_Port *)p;
+  Scheme_Output_Port *op = (Scheme_Output_Port *)p;
-  User_Output_Port *uop = (User_Output_Port *)port->port_data;
+  User_Output_Port *uop = (User_Output_Port *)op->port_data;
 
   return user_buffer_mode(uop->buffer_mode_proc, mode, 1);
 }
 
 int scheme_is_user_port(Scheme_Object *port)
 {
-  if (SCHEME_INPORTP(port)) {
+  if (SCHEME_INPUT_PORTP(port)) {
-    return SAME_OBJ(scheme_user_input_port_type,
+    Scheme_Input_Port *ip;
-		    ((Scheme_Input_Port *)port)->sub_type);
+    ip = scheme_input_port_record(port);
+    return SAME_OBJ(scheme_user_input_port_type, ip->sub_type);
   } else {
-    return SAME_OBJ(scheme_user_output_port_type,
+    Scheme_Output_Port *op;
-		    ((Scheme_Output_Port *)port)->sub_type);
+    op = scheme_output_port_record(port);
+    return SAME_OBJ(scheme_user_output_port_type, op->sub_type);
   }
 }
 
@@ -2267,13 +2363,15 @@ static Scheme_Object *pipe_length(int argc, Scheme_Object **argv)
   int avail;
 
   o = argv[0];
-  if (SCHEME_OUTPORTP(o)) {
+  if (SCHEME_OUTPUT_PORTP(o)) {
-    Scheme_Output_Port *op = (Scheme_Output_Port *)o;
+    Scheme_Output_Port *op;
+    op = scheme_output_port_record(o);
     if (op->sub_type == scheme_pipe_write_port_type) {
       pipe = (Scheme_Pipe *)op->port_data;
     }
-  } else if (SCHEME_INPORTP(o)) {
+  } else if (SCHEME_INPUT_PORTP(o)) {
-    Scheme_Input_Port *ip = (Scheme_Input_Port *)o;
+    Scheme_Input_Port *ip;
+    ip = scheme_input_port_record(o);
     if (ip->sub_type == scheme_pipe_read_port_type) {
       pipe = (Scheme_Pipe *)ip->port_data;
     }
@@ -2302,34 +2400,34 @@ static Scheme_Object *pipe_length(int argc, Scheme_Object **argv)
 static Scheme_Object *
 input_port_p (int argc, Scheme_Object *argv[])
 {
-  return (SCHEME_INPORTP(argv[0]) ? scheme_true : scheme_false);
+  return (SCHEME_INPUT_PORTP(argv[0]) ? scheme_true : scheme_false);
 }
 
 static Scheme_Object *
 output_port_p (int argc, Scheme_Object *argv[])
 {
-  return (SCHEME_OUTPORTP(argv[0]) ? scheme_true : scheme_false);
+  return (SCHEME_OUTPUT_PORTP(argv[0]) ? scheme_true : scheme_false);
 }
 
 static Scheme_Object *current_input_port(int argc, Scheme_Object *argv[])
 {
   return scheme_param_config("current-input-port", scheme_make_integer(MZCONFIG_INPUT_PORT),
 			     argc, argv,
-			     -1, input_port_p, "input port", 0);
+			     -1, input_port_p, "input-port", 0);
 }
 
 static Scheme_Object *current_output_port(int argc, Scheme_Object *argv[])
 {
   return scheme_param_config("current-output-port", scheme_make_integer(MZCONFIG_OUTPUT_PORT),
 			     argc, argv,
-			     -1, output_port_p, "output port", 0);
+			     -1, output_port_p, "output-port", 0);
 }
 
 static Scheme_Object *current_error_port(int argc, Scheme_Object *argv[])
 {
   return scheme_param_config("current-error-port", scheme_make_integer(MZCONFIG_ERROR_PORT),
 			     argc, argv,
-			     -1, output_port_p, "output port", 0);
+			     -1, output_port_p, "output-port", 0);
 }
 
 static Scheme_Object *
@@ -2630,8 +2728,8 @@ Scheme_Object *do_get_output_string(const char *who, int is_byte,
   char *s;
   long size;
 
-  op = (Scheme_Output_Port *)argv[0];
+  op = scheme_output_port_record(argv[0]);
-  if (!SCHEME_OUTPORTP(argv[0])
+  if (!SCHEME_OUTPUT_PORTP(argv[0])
       || (op->sub_type != scheme_string_output_port_type))
     scheme_wrong_type(who, "string output port", 0, argc, argv);
 
@@ -2658,7 +2756,7 @@ get_output_char_string (int argc, Scheme_Object *argv[])
 static Scheme_Object *
 close_input_port (int argc, Scheme_Object *argv[])
 {
-  if (!SCHEME_INPORTP(argv[0]))
+  if (!SCHEME_INPUT_PORTP(argv[0]))
     scheme_wrong_type("close-input-port", "input-port", 0, argc, argv);
 
   scheme_close_input_port(argv[0]);
@@ -2668,7 +2766,7 @@ close_input_port (int argc, Scheme_Object *argv[])
 static Scheme_Object *
 close_output_port (int argc, Scheme_Object *argv[])
 {
-  if (!SCHEME_OUTPORTP(argv[0]))
+  if (!SCHEME_OUTPUT_PORTP(argv[0]))
     scheme_wrong_type("close-output-port", "output-port", 0, argc, argv);
 
   scheme_close_output_port(argv[0]);
@@ -2803,7 +2901,7 @@ static Scheme_Object *sch_default_read_handler(void *ignore, int argc, Scheme_Ob
 {
   Scheme_Object *src;
 
-  if (!SCHEME_INPORTP(argv[0]))
+  if (!SCHEME_INPUT_PORTP(argv[0]))
     scheme_wrong_type("default-port-read-handler", "input-port", 0, argc, argv);
 
   if ((Scheme_Object *)argv[0] == scheme_orig_stdin_port)
@@ -2844,8 +2942,9 @@ static Scheme_Object *do_read_f(const char *who, int argc, Scheme_Object *argv[]
 {
   Scheme_Object *port, *readtable = NULL;
   int pre_char = -1;
+  Scheme_Input_Port *ip;
 
-  if (argc && !SCHEME_INPORTP(argv[0]))
+  if (argc && !SCHEME_INPUT_PORTP(argv[0]))
     scheme_wrong_type(who, "input-port", 0, argc, argv);
 
   if (argc)
@@ -2857,10 +2956,12 @@ static Scheme_Object *do_read_f(const char *who, int argc, Scheme_Object *argv[]
     pre_char = extract_recur_args(who, argc, argv, 0, &readtable);
   }
 
-  if (((Scheme_Input_Port *)port)->read_handler && !honu_mode && !recur) {
+  ip = scheme_input_port_record(port);
+
+  if (ip->read_handler && !honu_mode && !recur) {
     Scheme_Object *o[1];
     o[0] = port;
-    return _scheme_apply(((Scheme_Input_Port *)port)->read_handler, 1, o);
+    return _scheme_apply(ip->read_handler, 1, o);
   } else {
     if (port == scheme_orig_stdin_port)
       scheme_flush_orig_outputs();
@@ -2893,8 +2994,9 @@ static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object
 {
   Scheme_Object *port, *readtable = NULL;
   int pre_char = -1;
+  Scheme_Input_Port *ip;
 
-  if ((argc > 1) && !SCHEME_INPORTP(argv[1]))
+  if ((argc > 1) && !SCHEME_INPUT_PORTP(argv[1]))
     scheme_wrong_type(who, "input-port", 1, argc, argv);
 
   if (argc > 1)
@@ -2906,12 +3008,14 @@ static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object
     pre_char = extract_recur_args(who, argc, argv, 1, &readtable);
   }
   
-  if (((Scheme_Input_Port *)port)->read_handler && !honu_mode && !recur) {
+  ip = scheme_input_port_record(port);
+
+  if (ip->read_handler && !honu_mode && !recur) {
     Scheme_Object *o[2], *result;
     o[0] = port;
-    o[1] = (argc ? argv[0] : ((Scheme_Input_Port *)port)->name);
+    o[1] = (argc ? argv[0] : ip->name);
 
-    result = _scheme_apply(((Scheme_Input_Port *)port)->read_handler, 2, o);
+    result = _scheme_apply(ip->read_handler, 2, o);
     if (SCHEME_STXP(result) || SCHEME_EOFP(result))
       return result;
     else {
@@ -2923,7 +3027,7 @@ static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object
   } else {
     Scheme_Object *src;
 
-    src = (argc ? argv[0] : ((Scheme_Input_Port *)port)->name);
+    src = (argc ? argv[0] : ip->name);
 
     if (port == scheme_orig_stdin_port)
       scheme_flush_orig_outputs();
@@ -2958,7 +3062,7 @@ do_read_char(char *name, int argc, Scheme_Object *argv[], int peek, int spec, in
   Scheme_Object *port;
   int ch;
 
-  if (argc && !SCHEME_INPORTP(argv[0]))
+  if (argc && !SCHEME_INPUT_PORTP(argv[0]))
     scheme_wrong_type(name, "input-port", 0, argc, argv);
 
   if (argc)
@@ -3086,7 +3190,7 @@ do_read_line (int as_bytes, const char *who, int argc, Scheme_Object *argv[])
   char *buf, *oldbuf, onstack[32];
   long size = 31, oldsize, i = 0;
 
-  if (argc && !SCHEME_INPORTP(argv[0]))
+  if (argc && !SCHEME_INPUT_PORTP(argv[0]))
     scheme_wrong_type(who, "input-port", 0, argc, argv);
 
   if (argc > 1) {
@@ -3245,8 +3349,8 @@ do_general_read_bytes(int as_bytes,
     delta = 0;
   }
 
-  if ((argc > (1+delta)) && !SCHEME_INPORTP(argv[1+delta]))
+  if ((argc > (1+delta)) && !SCHEME_INPUT_PORTP(argv[1+delta]))
-    scheme_wrong_type(who, "input port", 1+delta, argc, argv);
+    scheme_wrong_type(who, "input-port", 1+delta, argc, argv);
 
   if (alloc_mode) {
     start = 0;
@@ -3406,8 +3510,8 @@ peeked_read(int argc, Scheme_Object *argv[])
 
   if (argc > 3) {
     port = argv[3];
-    if (!SCHEME_INPORTP(port))
+    if (!SCHEME_INPUT_PORTP(port))
-      scheme_wrong_type("port-commit-peeked", "input port", 3, argc, argv);
+      scheme_wrong_type("port-commit-peeked", "input-port", 3, argc, argv);
   } else
     port = CURRENT_INPUT_PORT(scheme_current_config());
 
@@ -3477,8 +3581,8 @@ progress_evt(int argc, Scheme_Object *argv[])
   Scheme_Object *port, *v;
 
   if (argc) {
-    if (!SCHEME_INPORTP(argv[0])) {
+    if (!SCHEME_INPUT_PORTP(argv[0])) {
-      scheme_wrong_type("port-progress-evt", "input port", 0, argc, argv);
+      scheme_wrong_type("port-progress-evt", "input-port", 0, argc, argv);
       return NULL;
     }
     port = argv[0];
@@ -3511,7 +3615,7 @@ do_write_bytes_avail(int as_bytes, const char *who,
     return NULL;
   } else
     str = argv[0];
-  if ((argc > 1) && !SCHEME_OUTPORTP(argv[1]))
+  if ((argc > 1) && !SCHEME_OUTPUT_PORTP(argv[1]))
     scheme_wrong_type(who, "output-port", 1, argc, argv);
 
   scheme_get_substring_indices(who, str,
@@ -3581,22 +3685,25 @@ write_bytes_avail_evt(int argc, Scheme_Object *argv[])
 static Scheme_Object *
 do_write_special(const char *name, int argc, Scheme_Object *argv[], int nonblock, int get_evt)
 {
+  Scheme_Output_Port *op;
   Scheme_Object *port;
   int ok;
 
   if (argc > 1) {
-    if (!SCHEME_OUTPORTP(argv[1]))
+    if (!SCHEME_OUTPUT_PORTP(argv[1]))
       scheme_wrong_type(name, "output-port", 1, argc, argv);
     port = argv[1];
   } else
     port = CURRENT_OUTPUT_PORT(scheme_current_config());
 
-  if (((Scheme_Output_Port *)port)->write_special_fun) {
+  op = scheme_output_port_record(port);
+
+  if (op->write_special_fun) {
     if (get_evt) {
       return scheme_make_write_evt(name, port, argv[0], NULL, 0, 0);
     } else {
-      Scheme_Write_Special_Fun ws = ((Scheme_Output_Port *)port)->write_special_fun;
+      Scheme_Write_Special_Fun ws = op->write_special_fun;
-      ok = ws((Scheme_Output_Port *)port, argv[0], nonblock);
+      ok = ws(op, argv[0], nonblock);
     }
   } else {
     scheme_arg_mismatch(name,
@@ -3606,7 +3713,8 @@ do_write_special(const char *name, int argc, Scheme_Object *argv[], int nonblock
   }
 
   if (ok) {
-    Scheme_Port *ip = (Scheme_Port *)port;
+    Scheme_Port *ip;
+    ip = scheme_port_record(port);
     if (ip->position >= 0)
       ip->position += 1;
     if (ip->count_lines) {
@@ -3622,10 +3730,13 @@ do_write_special(const char *name, int argc, Scheme_Object *argv[], int nonblock
 
 static Scheme_Object *can_write_atomic(int argc, Scheme_Object *argv[])
 {
-  if (!SCHEME_OUTPORTP(argv[0]))
+  Scheme_Output_Port *op;
-    scheme_wrong_type("port-writes-atomic?", "output port", 0, argc, argv);
 
-  if (((Scheme_Output_Port *)argv[0])->write_string_evt_fun)
+  if (!SCHEME_OUTPUT_PORTP(argv[0]))
+    scheme_wrong_type("port-writes-atomic?", "output-port", 0, argc, argv);
+  
+  op = scheme_output_port_record(argv[0]);
+  if (op->write_string_evt_fun)
     return scheme_true;
   else
     return scheme_false;
@@ -3633,10 +3744,14 @@ static Scheme_Object *can_write_atomic(int argc, Scheme_Object *argv[])
 
 static Scheme_Object *can_provide_progress_evt(int argc, Scheme_Object *argv[])
 {
-  if (!SCHEME_INPORTP(argv[0]))
+  Scheme_Input_Port *ip;
-    scheme_wrong_type("port-provides-progress-evt?", "input port", 0, argc, argv);
 
-  if (((Scheme_Input_Port *)argv[0])->progress_evt_fun)
+  if (!SCHEME_INPUT_PORTP(argv[0]))
+    scheme_wrong_type("port-provides-progress-evt?", "input-port", 0, argc, argv);
+
+  ip = scheme_input_port_record(argv[0]);
+
+  if (ip->progress_evt_fun)
     return scheme_true;
   else
     return scheme_false;
@@ -3645,10 +3760,14 @@ static Scheme_Object *can_provide_progress_evt(int argc, Scheme_Object *argv[])
 static Scheme_Object *
 can_write_special(int argc, Scheme_Object *argv[])
 {
-  if (!SCHEME_OUTPORTP(argv[0]))
+  Scheme_Output_Port *op;
-    scheme_wrong_type("port-writes-special?", "output port", 0, argc, argv);
 
-  if (((Scheme_Output_Port *)argv[0])->write_special_fun)
+  if (!SCHEME_OUTPUT_PORTP(argv[0]))
+    scheme_wrong_type("port-writes-special?", "output-port", 0, argc, argv);
+
+  op = scheme_output_port_record(argv[0]);
+
+  if (op->write_special_fun)
     return scheme_true;
   else
     return scheme_false;
@@ -3699,8 +3818,8 @@ char_ready_p (int argc, Scheme_Object *argv[])
 {
   Scheme_Object *port;
 
-  if (argc && !SCHEME_INPORTP(argv[0]))
+  if (argc && !SCHEME_INPUT_PORTP(argv[0]))
-    scheme_wrong_type("char-ready?", "input port", 0, argc, argv);
+    scheme_wrong_type("char-ready?", "input-port", 0, argc, argv);
 
   if (argc)
     port = argv[0];
@@ -3715,8 +3834,8 @@ byte_ready_p (int argc, Scheme_Object *argv[])
 {
   Scheme_Object *port;
 
-  if (argc && !SCHEME_INPORTP(argv[0]))
+  if (argc && !SCHEME_INPUT_PORTP(argv[0]))
-    scheme_wrong_type("byte-ready?", "input port", 0, argc, argv);
+    scheme_wrong_type("byte-ready?", "input-port", 0, argc, argv);
 
   if (argc)
     port = argv[0];
@@ -3728,7 +3847,7 @@ byte_ready_p (int argc, Scheme_Object *argv[])
 
 static Scheme_Object *sch_default_display_handler(int argc, Scheme_Object *argv[])
 {
-  if (!SCHEME_OUTPORTP(argv[1]))
+  if (!SCHEME_OUTPUT_PORTP(argv[1]))
     scheme_wrong_type("default-port-display-handler", "output-port", 1, argc, argv);
 
   scheme_internal_display(argv[0], argv[1]);
@@ -3738,7 +3857,7 @@ static Scheme_Object *sch_default_display_handler(int argc, Scheme_Object *argv[
 
 static Scheme_Object *sch_default_write_handler(int argc, Scheme_Object *argv[])
 {
-  if (!SCHEME_OUTPORTP(argv[1]))
+  if (!SCHEME_OUTPUT_PORTP(argv[1]))
     scheme_wrong_type("default-port-write-handler", "output-port", 1, argc, argv);
 
   scheme_internal_write(argv[0], argv[1]);
@@ -3748,7 +3867,7 @@ static Scheme_Object *sch_default_write_handler(int argc, Scheme_Object *argv[])
 
 static Scheme_Object *sch_default_print_handler(int argc, Scheme_Object *argv[])
 {
-  if (!SCHEME_OUTPORTP(argv[1]))
+  if (!SCHEME_OUTPUT_PORTP(argv[1]))
     scheme_wrong_type("default-port-print-handler", "output-port", 1, argc, argv);
 
   return _scheme_apply(scheme_get_param(scheme_current_config(),
@@ -3758,7 +3877,7 @@ static Scheme_Object *sch_default_print_handler(int argc, Scheme_Object *argv[])
 
 static Scheme_Object *sch_default_global_port_print_handler(int argc, Scheme_Object *argv[])
 {
-  if (!SCHEME_OUTPORTP(argv[1]))
+  if (!SCHEME_OUTPUT_PORTP(argv[1]))
     scheme_wrong_type("default-global-port-print-handler", "output-port", 1, argc, argv);
 
   scheme_internal_print(argv[0], argv[1]);
@@ -3771,17 +3890,20 @@ display_write(char *name,
 	      int argc, Scheme_Object *argv[], int escape)
 {
   Scheme_Object *port;
+  Scheme_Output_Port *op;
 
   if (argc > 1) {
-    if (!SCHEME_OUTPORTP(argv[1]))
+    if (!SCHEME_OUTPUT_PORTP(argv[1]))
       scheme_wrong_type(name, "output-port", 1, argc, argv);
     port = argv[1];
   } else
     port = CURRENT_OUTPUT_PORT(scheme_current_config());
 
+  op = scheme_output_port_record(port);
+
   if (escape > 0) {
     /* display */
-    if (!((Scheme_Output_Port *)port)->display_handler) {
+    if (!op->display_handler) {
       Scheme_Object *v = argv[0];
       if (SCHEME_BYTE_STRINGP(v)) {
 	scheme_put_byte_string(name, port,
@@ -3801,13 +3923,13 @@ display_write(char *name,
       Scheme_Object *a[2];
       a[0] = argv[0];
       a[1] = port;
-      _scheme_apply_multi(((Scheme_Output_Port *)port)->display_handler, 2, a);
+      _scheme_apply_multi(op->display_handler, 2, a);
     }
   } else if (!escape) {
     /* write */
     Scheme_Object *h;
 
-    h = ((Scheme_Output_Port *)port)->write_handler;
+    h = op->write_handler;
 
     if (!h)
       scheme_internal_write(argv[0], port);
@@ -3825,7 +3947,7 @@ display_write(char *name,
     a[0] = argv[0];
     a[1] = port;
 
-    h = ((Scheme_Output_Port *)port)->print_handler;
+    h = op->print_handler;
 
     if (!h)
       sch_default_print_handler(2, a);
@@ -3859,7 +3981,7 @@ newline (int argc, Scheme_Object *argv[])
 {
   Scheme_Object *port;
 
-  if (argc && !SCHEME_OUTPORTP(argv[0]))
+  if (argc && !SCHEME_OUTPUT_PORTP(argv[0]))
     scheme_wrong_type("newline", "output-port", 0, argc, argv);
 
   if (argc)
@@ -3886,7 +4008,7 @@ write_byte (int argc, Scheme_Object *argv[])
     scheme_wrong_type("write-byte", "exact integer in [0,255]", 0, argc, argv);
 
   if (argc > 1) {
-    if (!SCHEME_OUTPORTP(argv[1]))
+    if (!SCHEME_OUTPUT_PORTP(argv[1]))
       scheme_wrong_type("write-byte", "output-port", 1, argc, argv);
     port = argv[1];
   } else
@@ -3912,7 +4034,7 @@ write_char (int argc, Scheme_Object *argv[])
   if (argc && !SCHEME_CHARP(argv[0]))
     scheme_wrong_type("write-char", "character", 0, argc, argv);
   if (argc > 1) {
-    if (!SCHEME_OUTPORTP(argv[1]))
+    if (!SCHEME_OUTPUT_PORTP(argv[1]))
       scheme_wrong_type("write-char", "output-port", 1, argc, argv);
     port = argv[1];
   } else
@@ -3932,10 +4054,10 @@ static Scheme_Object *port_read_handler(int argc, Scheme_Object *argv[])
 {
   Scheme_Input_Port *ip;
 
-  if (!SCHEME_INPORTP(argv[0]))
+  if (!SCHEME_INPUT_PORTP(argv[0]))
-    scheme_wrong_type("port-read-handler", "input port", 0, argc, argv);
+    scheme_wrong_type("port-read-handler", "input-port", 0, argc, argv);
 
-  ip = (Scheme_Input_Port *)argv[0];
+  ip = scheme_input_port_record(argv[0]);
   if (argc == 1) {
     if (ip->read_handler)
       return ip->read_handler;
@@ -3962,10 +4084,10 @@ static Scheme_Object *port_display_handler(int argc, Scheme_Object *argv[])
 {
   Scheme_Output_Port *op;
 
-  if (!SCHEME_OUTPORTP(argv[0]))
+  if (!SCHEME_OUTPUT_PORTP(argv[0]))
     scheme_wrong_type("port-display-handler", "output-port", 0, argc, argv);
 
-  op = (Scheme_Output_Port *)argv[0];
+  op = scheme_output_port_record(argv[0]);
   if (argc == 1) {
     if (op->display_handler)
       return op->display_handler;
@@ -3986,10 +4108,10 @@ static Scheme_Object *port_write_handler(int argc, Scheme_Object *argv[])
 {
   Scheme_Output_Port *op;
 
-  if (!SCHEME_OUTPORTP(argv[0]))
+  if (!SCHEME_OUTPUT_PORTP(argv[0]))
     scheme_wrong_type("port-write-handler", "output-port", 0, argc, argv);
 
-  op = (Scheme_Output_Port *)argv[0];
+  op = scheme_output_port_record(argv[0]);
   if (argc == 1) {
     if (op->write_handler)
       return op->write_handler;
@@ -4010,10 +4132,10 @@ static Scheme_Object *port_print_handler(int argc, Scheme_Object *argv[])
 {
   Scheme_Output_Port *op;
 
-  if (!SCHEME_OUTPORTP(argv[0]))
+  if (!SCHEME_OUTPUT_PORTP(argv[0]))
     scheme_wrong_type("port-print-handler", "output-port", 0, argc, argv);
 
-  op = (Scheme_Output_Port *)argv[0];
+  op = scheme_output_port_record(argv[0]);
   if (argc == 1) {
     if (op->print_handler)
       return op->print_handler;
@@ -4040,7 +4162,7 @@ static Scheme_Object *global_port_print_handler(int argc, Scheme_Object *argv[])
 
 static Scheme_Object *port_count_lines(int argc, Scheme_Object *argv[])
 {
-  if (!SCHEME_INPORTP(argv[0]) && !SCHEME_OUTPORTP(argv[0]))
+  if (!SCHEME_INPUT_PORTP(argv[0]) && !SCHEME_OUTPUT_PORTP(argv[0]))
     scheme_wrong_type("port-count-lines!", "port", 0, argc, argv);
 
   scheme_count_lines(argv[0]);
@@ -4060,7 +4182,7 @@ static Scheme_Object *port_next_location(int argc, Scheme_Object *argv[])
   Scheme_Object *a[3];
   long line, col, pos;
 
-  if (!SCHEME_INPORTP(argv[0]) && !SCHEME_OUTPORTP(argv[0]))
+  if (!SCHEME_INPUT_PORTP(argv[0]) && !SCHEME_OUTPUT_PORTP(argv[0]))
     scheme_wrong_type("port-next-location", "port", 0, argc, argv);
 
   scheme_tell_all(argv[0], &line, &col, &pos);
@@ -4161,11 +4283,15 @@ static Scheme_Object *do_load_handler(void *data)
 	  other = scheme_make_sized_byte_string(s, len + slen + 1, 0);
 	}
 
+        {
+          Scheme_Input_Port *ip;
+          ip = scheme_input_port_record(port);
           scheme_raise_exn(MZEXN_FAIL,
                            "default-load-handler: expected a `module' declaration for `%S', found: %T in: %V",
                            lhd->expected_module,
                            other,
-			 ((Scheme_Input_Port *)port)->name);
+                           ip->name);
+        }
 
 	return NULL;
       }
@@ -4173,10 +4299,13 @@ static Scheme_Object *do_load_handler(void *data)
       /* Check no more expressions: */
       d = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, -1, NULL, NULL, NULL);
       if (!SCHEME_EOFP(d)) {
+        Scheme_Input_Port *ip;
+        ip = scheme_input_port_record(port);
 	scheme_raise_exn(MZEXN_FAIL,
-			 "default-load-handler: expected only a `module' declaration for `%S', but found an extra expression in: %V",
+			 "default-load-handler: expected only a `module' declaration for `%S',"
+                         " but found an extra expression in: %V",
 			 lhd->expected_module,
-			 ((Scheme_Input_Port *)port)->name);
+			 ip->name);
 
 	return NULL;
       }
@@ -4189,6 +4318,11 @@ static Scheme_Object *do_load_handler(void *data)
 	d = scheme_make_immutable_pair(a, d);
 	obj = scheme_datum_to_syntax(d, obj, scheme_false, 0, 1);
       }
+    } else {
+      /* Add #%top-interaction, since we're in non-module mode: */
+      Scheme_Object *a;
+      a = scheme_make_pair(scheme_intern_symbol("#%top-interaction"), obj);
+      obj = scheme_datum_to_syntax(a, obj, scheme_false, 0, 0);
     }
 
     /* ... end special support for module loading ... */
@@ -4201,7 +4335,7 @@ static Scheme_Object *do_load_handler(void *data)
     if (genv->template_env && genv->template_env->rename)
       obj = scheme_add_rename(obj, genv->template_env->rename);
 
-    last_val = _scheme_apply_multi(scheme_get_param(config, MZCONFIG_EVAL_HANDLER),
+    last_val = _scheme_apply_multi_with_prompt(scheme_get_param(config, MZCONFIG_EVAL_HANDLER),
                                                1, &obj);
 
     /* If multi, we must save then: */
@@ -4218,10 +4352,12 @@ static Scheme_Object *do_load_handler(void *data)
   }
 
   if (SCHEME_SYMBOLP(lhd->expected_module) && !got_one) {
+    Scheme_Input_Port *ip;
+    ip = scheme_input_port_record(port);
     scheme_raise_exn(MZEXN_FAIL,
 		     "default-load-handler: expected a `module' declaration for `%S', but found end-of-file in: %V",
 		     lhd->expected_module,
-		     ((Scheme_Input_Port *)port)->name);
+		     ip->name);
 
     return NULL;
   }
@@ -4313,7 +4449,7 @@ static Scheme_Object *default_load(int argc, Scheme_Object *argv[])
   lhd->p = p;
   lhd->config = config;
   lhd->port = port;
-  name = ((Scheme_Input_Port *)port)->name;
+  name = scheme_input_port_record(port)->name;
   lhd->stxsrc = name;
   lhd->expected_module = expected_module;
 
@@ -4490,7 +4626,7 @@ flush_output(int argc, Scheme_Object *argv[])
 {
   Scheme_Object *op;
 
-  if (argc && !SCHEME_OUTPORTP(argv[0]))
+  if (argc && !SCHEME_OUTPUT_PORTP(argv[0]))
     scheme_wrong_type("flush-output", "output-port", 0, argc, argv);
 
   if (argc)

src/mzscheme/src/print.c

@@ -2765,7 +2765,7 @@ static Scheme_Object *custom_recur(int notdisplay, void *_vec, int argc, Scheme_
 
   if (!SCHEME_OUTPORTP(argv[1])) {
     scheme_wrong_type(notdisplay ? "write/recusrive" : "display/recursive",
-		      "output port", 1, argc, argv);
+		      "output-port", 1, argc, argv);
     return NULL;
   }
 

src/mzscheme/src/regexp.c

@@ -4845,13 +4845,13 @@ static Scheme_Object *gen_compare(char *name, int pos,
       && !SCHEME_CHAR_STRINGP(argv[0]))
     scheme_wrong_type(name, "regexp, byte-regexp, string, or byte string", 0, argc, argv);
   if ((peek || (!SCHEME_BYTE_STRINGP(argv[1]) && !SCHEME_CHAR_STRINGP(argv[1])))
-      && !SCHEME_INPORTP(argv[1]))
+      && !SCHEME_INPUT_PORTP(argv[1]))
     scheme_wrong_type(name, peek ? "input-port" : "string, byte string, or input port", 1, argc, argv);
   
   if (SCHEME_CHAR_STRINGP(argv[1])) {
     iport = NULL;
     endset = SCHEME_CHAR_STRLEN_VAL(argv[1]);
-  } else if (SCHEME_INPORTP(argv[1])) {
+  } else if (SCHEME_INPUT_PORTP(argv[1])) {
     iport = argv[1];
     endset = -2;
   } else {
@@ -4917,8 +4917,8 @@ static Scheme_Object *gen_compare(char *name, int pos,
 	  }
 	} else {
 	  if (SCHEME_TRUEP(argv[4])) {
-	    if (!SCHEME_OUTPORTP(argv[4]))
+	    if (!SCHEME_OUTPUT_PORTP(argv[4]))
-	      scheme_wrong_type(name, "output-port or #f", 4, argc, argv);
+	      scheme_wrong_type(name, "output port or #f", 4, argc, argv);
 	    oport = argv[4];
 	  }
 	}

src/mzscheme/src/schemef.h

@@ -240,6 +240,8 @@ MZ_EXTERN unsigned char scheme_uchar_combining_classes[];
 
 MZ_EXTERN Scheme_Object *scheme_eval(Scheme_Object *obj, Scheme_Env *env);
 MZ_EXTERN Scheme_Object *scheme_eval_multi(Scheme_Object *obj, Scheme_Env *env);
+MZ_EXTERN Scheme_Object *scheme_eval_with_prompt(Scheme_Object *obj, Scheme_Env *env);
+MZ_EXTERN Scheme_Object *scheme_eval_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env);
 
 MZ_EXTERN Scheme_Object *scheme_eval_compiled(Scheme_Object *obj, Scheme_Env *env);
 MZ_EXTERN Scheme_Object *scheme_eval_compiled_multi(Scheme_Object *obj, Scheme_Env *env);
@@ -251,9 +253,16 @@ MZ_EXTERN Scheme_Object *scheme_apply_multi(Scheme_Object *rator, int num_rands,
 MZ_EXTERN Scheme_Object *scheme_apply_no_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
 MZ_EXTERN Scheme_Object *scheme_apply_multi_no_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
 MZ_EXTERN Scheme_Object *scheme_apply_to_list(Scheme_Object *rator, Scheme_Object *argss);
+MZ_EXTERN Scheme_Object *scheme_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
+MZ_EXTERN Scheme_Object *scheme_apply_multi_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
+MZ_EXTERN Scheme_Object *_scheme_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
+MZ_EXTERN Scheme_Object *_scheme_apply_multi_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
 MZ_EXTERN Scheme_Object *scheme_eval_string(const char *str, Scheme_Env *env);
 MZ_EXTERN Scheme_Object *scheme_eval_string_multi(const char *str, Scheme_Env *env);
 MZ_EXTERN Scheme_Object *scheme_eval_string_all(const char *str, Scheme_Env *env, int all);
+MZ_EXTERN Scheme_Object *scheme_eval_string_with_prompt(const char *str, Scheme_Env *env);
+MZ_EXTERN Scheme_Object *scheme_eval_string_multi_with_prompt(const char *str, Scheme_Env *env);
+MZ_EXTERN Scheme_Object *scheme_eval_string_all_with_prompt(const char *str, Scheme_Env *env, int all);
 
 MZ_EXTERN Scheme_Object *_scheme_apply_known_prim_closure(Scheme_Object *rator, int argc,
 							  Scheme_Object **argv);
@@ -264,6 +273,11 @@ MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure(Scheme_Object *rator, int ar
 MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure_multi(Scheme_Object *rator, int argc,
 							  Scheme_Object **argv);
 
+MZ_EXTERN Scheme_Object *scheme_call_with_prompt(Scheme_Closed_Prim f, void *data);
+MZ_EXTERN Scheme_Object *scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data);
+MZ_EXTERN Scheme_Object *_scheme_call_with_prompt(Scheme_Closed_Prim f, void *data);
+MZ_EXTERN Scheme_Object *_scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data);
+
 MZ_EXTERN Scheme_Object *scheme_values(int c, Scheme_Object **v);
 
 MZ_EXTERN Scheme_Object *scheme_check_one_value(Scheme_Object *v);
@@ -384,6 +398,7 @@ MZ_EXTERN Scheme_Hash_Table *scheme_make_hash_table(int type);
 MZ_EXTERN Scheme_Hash_Table *scheme_make_hash_table_equal();
 MZ_EXTERN void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val);
 MZ_EXTERN Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key);
+XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_eq_hash_get(Scheme_Hash_Table *table, Scheme_Object *key);
 MZ_EXTERN int scheme_hash_table_equal(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2);
 MZ_EXTERN int scheme_is_hash_table_equal(Scheme_Object *o);
 MZ_EXTERN Scheme_Hash_Table *scheme_clone_hash_table(Scheme_Hash_Table *bt);
@@ -704,6 +719,12 @@ MZ_EXTERN Scheme_Object *scheme_write_special_nonblock(int argc, Scheme_Object *
 MZ_EXTERN Scheme_Object *scheme_make_write_evt(const char *who, Scheme_Object *port,
 					       Scheme_Object *special, char *str, long start, long size);
 
+MZ_EXTERN Scheme_Port *scheme_port_record(Scheme_Object *port);
+MZ_EXTERN Scheme_Input_Port *scheme_input_port_record(Scheme_Object *port);
+MZ_EXTERN Scheme_Output_Port *scheme_output_port_record(Scheme_Object *port);
+XFORM_NONGCING MZ_EXTERN int scheme_is_input_port(Scheme_Object *port);
+XFORM_NONGCING MZ_EXTERN int scheme_is_output_port(Scheme_Object *port);
+
 MZ_EXTERN Scheme_Object *scheme_make_port_type(const char *name);
 MZ_EXTERN Scheme_Input_Port *scheme_make_input_port(Scheme_Object *subtype, void *data,
 						    Scheme_Object *name,
@@ -911,7 +932,7 @@ MZ_EXTERN void scheme_struct_set(Scheme_Object *s, int pos, Scheme_Object *v);
 
 MZ_EXTERN Scheme_Object *scheme_make_struct_type_property(Scheme_Object *name);
 MZ_EXTERN Scheme_Object *scheme_make_struct_type_property_w_guard(Scheme_Object *name, Scheme_Object *guard);
-MZ_EXTERN Scheme_Object *scheme_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s);
+XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s);
 
 MZ_EXTERN Scheme_Object *scheme_make_location(Scheme_Object *src,
 					      Scheme_Object *line,

src/mzscheme/src/schemex.h

@@ -193,6 +193,8 @@ unsigned char *scheme_uchar_combining_classes;
 /*========================================================================*/
 Scheme_Object *(*scheme_eval)(Scheme_Object *obj, Scheme_Env *env);
 Scheme_Object *(*scheme_eval_multi)(Scheme_Object *obj, Scheme_Env *env);
+Scheme_Object *(*scheme_eval_with_prompt)(Scheme_Object *obj, Scheme_Env *env);
+Scheme_Object *(*scheme_eval_multi_with_prompt)(Scheme_Object *obj, Scheme_Env *env);
 Scheme_Object *(*scheme_eval_compiled)(Scheme_Object *obj, Scheme_Env *env);
 Scheme_Object *(*scheme_eval_compiled_multi)(Scheme_Object *obj, Scheme_Env *env);
 Scheme_Object *(*_scheme_eval_compiled)(Scheme_Object *obj, Scheme_Env *env);
@@ -202,9 +204,16 @@ Scheme_Object *(*scheme_apply_multi)(Scheme_Object *rator, int num_rands, Scheme
 Scheme_Object *(*scheme_apply_no_eb)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
 Scheme_Object *(*scheme_apply_multi_no_eb)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
 Scheme_Object *(*scheme_apply_to_list)(Scheme_Object *rator, Scheme_Object *argss);
+Scheme_Object *(*scheme_apply_with_prompt)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
+Scheme_Object *(*scheme_apply_multi_with_prompt)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
+Scheme_Object *(*_scheme_apply_with_prompt)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
+Scheme_Object *(*_scheme_apply_multi_with_prompt)(Scheme_Object *rator, int num_rands, Scheme_Object **rands);
 Scheme_Object *(*scheme_eval_string)(const char *str, Scheme_Env *env);
 Scheme_Object *(*scheme_eval_string_multi)(const char *str, Scheme_Env *env);
 Scheme_Object *(*scheme_eval_string_all)(const char *str, Scheme_Env *env, int all);
+Scheme_Object *(*scheme_eval_string_with_prompt)(const char *str, Scheme_Env *env);
+Scheme_Object *(*scheme_eval_string_multi_with_prompt)(const char *str, Scheme_Env *env);
+Scheme_Object *(*scheme_eval_string_all_with_prompt)(const char *str, Scheme_Env *env, int all);
 Scheme_Object *(*_scheme_apply_known_prim_closure)(Scheme_Object *rator, int argc,
 							  Scheme_Object **argv);
 Scheme_Object *(*_scheme_apply_known_prim_closure_multi)(Scheme_Object *rator, int argc,
@@ -213,6 +222,10 @@ Scheme_Object *(*_scheme_apply_prim_closure)(Scheme_Object *rator, int argc,
 						    Scheme_Object **argv);
 Scheme_Object *(*_scheme_apply_prim_closure_multi)(Scheme_Object *rator, int argc,
 							  Scheme_Object **argv);
+Scheme_Object *(*scheme_call_with_prompt)(Scheme_Closed_Prim f, void *data);
+Scheme_Object *(*scheme_call_with_prompt_multi)(Scheme_Closed_Prim f, void *data);
+Scheme_Object *(*_scheme_call_with_prompt)(Scheme_Closed_Prim f, void *data);
+Scheme_Object *(*_scheme_call_with_prompt_multi)(Scheme_Closed_Prim f, void *data);
 Scheme_Object *(*scheme_values)(int c, Scheme_Object **v);
 Scheme_Object *(*scheme_check_one_value)(Scheme_Object *v);
 /* Tail calls - only use these when you're writing new functions/syntax */
@@ -310,6 +323,7 @@ Scheme_Hash_Table *(*scheme_make_hash_table)(int type);
 Scheme_Hash_Table *(*scheme_make_hash_table_equal)();
 void (*scheme_hash_set)(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val);
 Scheme_Object *(*scheme_hash_get)(Scheme_Hash_Table *table, Scheme_Object *key);
+Scheme_Object *(*scheme_eq_hash_get)(Scheme_Hash_Table *table, Scheme_Object *key);
 int (*scheme_hash_table_equal)(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2);
 int (*scheme_is_hash_table_equal)(Scheme_Object *o);
 Scheme_Hash_Table *(*scheme_clone_hash_table)(Scheme_Hash_Table *bt);
@@ -588,6 +602,11 @@ Scheme_Object *(*scheme_write_special)(int argc, Scheme_Object *argv[]);
 Scheme_Object *(*scheme_write_special_nonblock)(int argc, Scheme_Object *argv[]);
 Scheme_Object *(*scheme_make_write_evt)(const char *who, Scheme_Object *port,
 					       Scheme_Object *special, char *str, long start, long size);
+Scheme_Port *(*scheme_port_record)(Scheme_Object *port);
+Scheme_Input_Port *(*scheme_input_port_record)(Scheme_Object *port);
+Scheme_Output_Port *(*scheme_output_port_record)(Scheme_Object *port);
+int (*scheme_is_input_port)(Scheme_Object *port);
+int (*scheme_is_output_port)(Scheme_Object *port);
 Scheme_Object *(*scheme_make_port_type)(const char *name);
 Scheme_Input_Port *(*scheme_make_input_port)(Scheme_Object *subtype, void *data,
 						    Scheme_Object *name,

src/mzscheme/src/schemex.inc

@@ -114,6 +114,8 @@
   scheme_extension_table->scheme_uchar_combining_classes = scheme_uchar_combining_classes;
   scheme_extension_table->scheme_eval = scheme_eval;
   scheme_extension_table->scheme_eval_multi = scheme_eval_multi;
+  scheme_extension_table->scheme_eval_with_prompt = scheme_eval_with_prompt;
+  scheme_extension_table->scheme_eval_multi_with_prompt = scheme_eval_multi_with_prompt;
   scheme_extension_table->scheme_eval_compiled = scheme_eval_compiled;
   scheme_extension_table->scheme_eval_compiled_multi = scheme_eval_compiled_multi;
   scheme_extension_table->_scheme_eval_compiled = _scheme_eval_compiled;
@@ -123,13 +125,24 @@
   scheme_extension_table->scheme_apply_no_eb = scheme_apply_no_eb;
   scheme_extension_table->scheme_apply_multi_no_eb = scheme_apply_multi_no_eb;
   scheme_extension_table->scheme_apply_to_list = scheme_apply_to_list;
+  scheme_extension_table->scheme_apply_with_prompt = scheme_apply_with_prompt;
+  scheme_extension_table->scheme_apply_multi_with_prompt = scheme_apply_multi_with_prompt;
+  scheme_extension_table->_scheme_apply_with_prompt = _scheme_apply_with_prompt;
+  scheme_extension_table->_scheme_apply_multi_with_prompt = _scheme_apply_multi_with_prompt;
   scheme_extension_table->scheme_eval_string = scheme_eval_string;
   scheme_extension_table->scheme_eval_string_multi = scheme_eval_string_multi;
   scheme_extension_table->scheme_eval_string_all = scheme_eval_string_all;
+  scheme_extension_table->scheme_eval_string_with_prompt = scheme_eval_string_with_prompt;
+  scheme_extension_table->scheme_eval_string_multi_with_prompt = scheme_eval_string_multi_with_prompt;
+  scheme_extension_table->scheme_eval_string_all_with_prompt = scheme_eval_string_all_with_prompt;
   scheme_extension_table->_scheme_apply_known_prim_closure = _scheme_apply_known_prim_closure;
   scheme_extension_table->_scheme_apply_known_prim_closure_multi = _scheme_apply_known_prim_closure_multi;
   scheme_extension_table->_scheme_apply_prim_closure = _scheme_apply_prim_closure;
   scheme_extension_table->_scheme_apply_prim_closure_multi = _scheme_apply_prim_closure_multi;
+  scheme_extension_table->scheme_call_with_prompt = scheme_call_with_prompt;
+  scheme_extension_table->scheme_call_with_prompt_multi = scheme_call_with_prompt_multi;
+  scheme_extension_table->_scheme_call_with_prompt = _scheme_call_with_prompt;
+  scheme_extension_table->_scheme_call_with_prompt_multi = _scheme_call_with_prompt_multi;
   scheme_extension_table->scheme_values = scheme_values;
   scheme_extension_table->scheme_check_one_value = scheme_check_one_value;
   scheme_extension_table->scheme_tail_apply = scheme_tail_apply;
@@ -207,6 +220,7 @@
   scheme_extension_table->scheme_make_hash_table_equal = scheme_make_hash_table_equal;
   scheme_extension_table->scheme_hash_set = scheme_hash_set;
   scheme_extension_table->scheme_hash_get = scheme_hash_get;
+  scheme_extension_table->scheme_eq_hash_get = scheme_eq_hash_get;
   scheme_extension_table->scheme_hash_table_equal = scheme_hash_table_equal;
   scheme_extension_table->scheme_is_hash_table_equal = scheme_is_hash_table_equal;
   scheme_extension_table->scheme_clone_hash_table = scheme_clone_hash_table;
@@ -393,6 +407,11 @@
   scheme_extension_table->scheme_write_special = scheme_write_special;
   scheme_extension_table->scheme_write_special_nonblock = scheme_write_special_nonblock;
   scheme_extension_table->scheme_make_write_evt = scheme_make_write_evt;
+  scheme_extension_table->scheme_port_record = scheme_port_record;
+  scheme_extension_table->scheme_input_port_record = scheme_input_port_record;
+  scheme_extension_table->scheme_output_port_record = scheme_output_port_record;
+  scheme_extension_table->scheme_is_input_port = scheme_is_input_port;
+  scheme_extension_table->scheme_is_output_port = scheme_is_output_port;
   scheme_extension_table->scheme_make_port_type = scheme_make_port_type;
   scheme_extension_table->scheme_make_input_port = scheme_make_input_port;
   scheme_extension_table->scheme_make_output_port = scheme_make_output_port;

src/mzscheme/src/schemexm.h

@@ -114,6 +114,8 @@
 #define scheme_uchar_combining_classes (scheme_extension_table->scheme_uchar_combining_classes)
 #define scheme_eval (scheme_extension_table->scheme_eval)
 #define scheme_eval_multi (scheme_extension_table->scheme_eval_multi)
+#define scheme_eval_with_prompt (scheme_extension_table->scheme_eval_with_prompt)
+#define scheme_eval_multi_with_prompt (scheme_extension_table->scheme_eval_multi_with_prompt)
 #define scheme_eval_compiled (scheme_extension_table->scheme_eval_compiled)
 #define scheme_eval_compiled_multi (scheme_extension_table->scheme_eval_compiled_multi)
 #define _scheme_eval_compiled (scheme_extension_table->_scheme_eval_compiled)
@@ -123,13 +125,24 @@
 #define scheme_apply_no_eb (scheme_extension_table->scheme_apply_no_eb)
 #define scheme_apply_multi_no_eb (scheme_extension_table->scheme_apply_multi_no_eb)
 #define scheme_apply_to_list (scheme_extension_table->scheme_apply_to_list)
+#define scheme_apply_with_prompt (scheme_extension_table->scheme_apply_with_prompt)
+#define scheme_apply_multi_with_prompt (scheme_extension_table->scheme_apply_multi_with_prompt)
+#define _scheme_apply_with_prompt (scheme_extension_table->_scheme_apply_with_prompt)
+#define _scheme_apply_multi_with_prompt (scheme_extension_table->_scheme_apply_multi_with_prompt)
 #define scheme_eval_string (scheme_extension_table->scheme_eval_string)
 #define scheme_eval_string_multi (scheme_extension_table->scheme_eval_string_multi)
 #define scheme_eval_string_all (scheme_extension_table->scheme_eval_string_all)
+#define scheme_eval_string_with_prompt (scheme_extension_table->scheme_eval_string_with_prompt)
+#define scheme_eval_string_multi_with_prompt (scheme_extension_table->scheme_eval_string_multi_with_prompt)
+#define scheme_eval_string_all_with_prompt (scheme_extension_table->scheme_eval_string_all_with_prompt)
 #define _scheme_apply_known_prim_closure (scheme_extension_table->_scheme_apply_known_prim_closure)
 #define _scheme_apply_known_prim_closure_multi (scheme_extension_table->_scheme_apply_known_prim_closure_multi)
 #define _scheme_apply_prim_closure (scheme_extension_table->_scheme_apply_prim_closure)
 #define _scheme_apply_prim_closure_multi (scheme_extension_table->_scheme_apply_prim_closure_multi)
+#define scheme_call_with_prompt (scheme_extension_table->scheme_call_with_prompt)
+#define scheme_call_with_prompt_multi (scheme_extension_table->scheme_call_with_prompt_multi)
+#define _scheme_call_with_prompt (scheme_extension_table->_scheme_call_with_prompt)
+#define _scheme_call_with_prompt_multi (scheme_extension_table->_scheme_call_with_prompt_multi)
 #define scheme_values (scheme_extension_table->scheme_values)
 #define scheme_check_one_value (scheme_extension_table->scheme_check_one_value)
 #define scheme_tail_apply (scheme_extension_table->scheme_tail_apply)
@@ -207,6 +220,7 @@
 #define scheme_make_hash_table_equal (scheme_extension_table->scheme_make_hash_table_equal)
 #define scheme_hash_set (scheme_extension_table->scheme_hash_set)
 #define scheme_hash_get (scheme_extension_table->scheme_hash_get)
+#define scheme_eq_hash_get (scheme_extension_table->scheme_eq_hash_get)
 #define scheme_hash_table_equal (scheme_extension_table->scheme_hash_table_equal)
 #define scheme_is_hash_table_equal (scheme_extension_table->scheme_is_hash_table_equal)
 #define scheme_clone_hash_table (scheme_extension_table->scheme_clone_hash_table)
@@ -393,6 +407,11 @@
 #define scheme_write_special (scheme_extension_table->scheme_write_special)
 #define scheme_write_special_nonblock (scheme_extension_table->scheme_write_special_nonblock)
 #define scheme_make_write_evt (scheme_extension_table->scheme_make_write_evt)
+#define scheme_port_record (scheme_extension_table->scheme_port_record)
+#define scheme_input_port_record (scheme_extension_table->scheme_input_port_record)
+#define scheme_output_port_record (scheme_extension_table->scheme_output_port_record)
+#define scheme_is_input_port (scheme_extension_table->scheme_is_input_port)
+#define scheme_is_output_port (scheme_extension_table->scheme_is_output_port)
 #define scheme_make_port_type (scheme_extension_table->scheme_make_port_type)
 #define scheme_make_input_port (scheme_extension_table->scheme_make_input_port)
 #define scheme_make_output_port (scheme_extension_table->scheme_make_output_port)

src/mzscheme/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 885
+#define EXPECTED_PRIM_COUNT 887
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

src/mzscheme/src/schpriv.h

@@ -92,6 +92,7 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]);
 
 extern long scheme_total_gc_time;
 extern int scheme_cont_capture_count;
+extern int scheme_continuation_application_count;
 
 int scheme_num_types(void);
 
@@ -266,6 +267,8 @@ extern Scheme_Object *scheme_default_prompt_tag;
 
 extern Scheme_Object *scheme_system_idle_channel;
 
+extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
+
 /*========================================================================*/
 /*                    thread state and maintenance                        */
 /*========================================================================*/
@@ -402,6 +405,7 @@ struct Scheme_Config {
 };
 
 extern Scheme_Object *scheme_parameterization_key;
+extern Scheme_Object *scheme_exn_handler_key;
 extern Scheme_Object *scheme_break_enabled_key;
 
 extern void scheme_flatten_config(Scheme_Config *c);
@@ -940,7 +944,6 @@ typedef struct Scheme_Stack_State {
   long runstack_offset;
   MZ_MARK_POS_TYPE cont_mark_pos;
   MZ_MARK_STACK_TYPE cont_mark_stack;
-  struct Scheme_Prompt *barrier_prompt;
 } Scheme_Stack_State;
 
 typedef struct Scheme_Dynamic_Wind {
@@ -952,29 +955,25 @@ typedef struct Scheme_Dynamic_Wind {
   void (*pre)(void *);
   void (*post)(void *);
   mz_jmp_buf *saveerr;
-  int next_meta; /* amount to move forward in the meta-continuation chain */
+  int next_meta; /* amount to move forward in the meta-continuation chain, starting with next */
   struct Scheme_Stack_State envss;
   struct Scheme_Dynamic_Wind *prev;
 } Scheme_Dynamic_Wind;
 
 typedef struct Scheme_Cont {
   Scheme_Object so;
-  short composable;
+  char composable, has_prompt_dw;
-  Scheme_Object *value; /* Set just before jump */
-  struct Scheme_Overflow *resume_to; /* Set just before jump */
-  struct Scheme_Cont *use_next_cont; /* Set just before jump */
-  int common_dw_depth; /* Set just before jump; id common dw record */
-  Scheme_Object *extra_marks; /* Set just before jump; vector extra keys and marks to add to meta-cont */
   struct Scheme_Meta_Continuation *meta_continuation;
   Scheme_Jumpup_Buf buf;
   Scheme_Dynamic_Wind *dw;
+  int next_meta;
   Scheme_Continuation_Jump_State cjs;
   Scheme_Stack_State ss;
+  struct Scheme_Prompt *barrier_prompt; /* NULL if no barrier between cont and prompt */
   Scheme_Object **runstack_start;
   long runstack_size;
   Scheme_Saved_Stack *runstack_saved;
   Scheme_Object *prompt_tag;
-  int prompt_depth;
   mz_jmp_buf *prompt_buf; /* needed for meta-prompt */
   MZ_MARK_POS_TYPE meta_tail_pos; /* to recognize opportunity for meta-tail calls */
   MZ_MARK_POS_TYPE cont_mark_pos_bottom; /* to splice cont mark values with meta-cont */
@@ -985,6 +984,7 @@ typedef struct Scheme_Cont {
   Scheme_Thread **cont_mark_stack_owner;
   long cont_mark_shareable, cont_mark_offset;
   void *stack_start;
+  Scheme_Object *prompt_id; /* allows direct-jump optimization */
   Scheme_Config *init_config;
   Scheme_Object *init_break_cell;
 #ifdef MZ_USE_JIT
@@ -992,11 +992,22 @@ typedef struct Scheme_Cont {
 #endif
   struct Scheme_Overflow *save_overflow;
   mz_jmp_buf *savebuf; /* save old error buffer here */
+
+  /* Arguments passed to a continuation invocation to the continuation restorer: */
+  Scheme_Object *value; /* argument(s) to continuation */
+  struct Scheme_Overflow *resume_to; /* meta-continuation return */
+  struct Scheme_Cont *use_next_cont; /* more meta-continuation return */
+  int common_dw_depth; /* id for common dw record */
+  Scheme_Dynamic_Wind *common_dw; /* shared part with source cont */
+  int common_next_meta; /* for common_dw */
+  Scheme_Object *extra_marks; /* vector of extra keys and marks to add to meta-cont */
+  struct Scheme_Prompt *shortcut_prompt; /* prompt common to save and restore enabling shortcut */
 } Scheme_Cont;
 
 typedef struct Scheme_Escaping_Cont {
   Scheme_Object so;
   struct Scheme_Stack_State envss;
+  struct Scheme_Prompt *barrier_prompt;
 #ifdef MZ_USE_JIT
   Scheme_Object *native_trace;
 #endif
@@ -1009,12 +1020,10 @@ int scheme_escape_continuation_ok(Scheme_Object *);
 
 #define scheme_save_env_stack_w_thread(ss, p) \
     (ss.runstack_offset = MZ_RUNSTACK - MZ_RUNSTACK_START, \
-     ss.cont_mark_stack = MZ_CONT_MARK_STACK, ss.cont_mark_pos = MZ_CONT_MARK_POS, \
+     ss.cont_mark_stack = MZ_CONT_MARK_STACK, ss.cont_mark_pos = MZ_CONT_MARK_POS)
-     ss.barrier_prompt = p->barrier_prompt)
 #define scheme_restore_env_stack_w_thread(ss, p) \
     (MZ_RUNSTACK = MZ_RUNSTACK_START + ss.runstack_offset, \
-     MZ_CONT_MARK_STACK = ss.cont_mark_stack, MZ_CONT_MARK_POS = ss.cont_mark_pos, \
+     MZ_CONT_MARK_STACK = ss.cont_mark_stack, MZ_CONT_MARK_POS = ss.cont_mark_pos)
-     p->barrier_prompt = ss.barrier_prompt)
 #define scheme_save_env_stack(ss) \
     scheme_save_env_stack_w_thread(ss, scheme_current_thread)
 #define scheme_restore_env_stack(ss) \
@@ -1052,6 +1061,7 @@ typedef struct Scheme_Meta_Continuation {
   char cm_caches; /* cached info in copied cm */
   char cm_shared; /* cm is shared, so copy before setting cache entries */
   int copy_after_captured; /* for mutating a meta-continuation in set_cont_stack_mark */
+  int depth;
   Scheme_Object *prompt_tag;
   /* The C stack: */
   Scheme_Overflow *overflow;
@@ -1068,15 +1078,15 @@ typedef struct Scheme_Meta_Continuation {
 
 typedef struct Scheme_Prompt {
   Scheme_Object so;
-  char is_barrier, is_captured;
+  char is_barrier;
-  int depth;
+  Scheme_Object *tag;
+  Scheme_Object *id;                  /* created as needed; allows direct-jump optimization for cont app */
   void *stack_boundary;               /* where to stop copying the C stack */
   void *boundary_overflow_id;         /* indicates the C stack segment */
   MZ_MARK_STACK_TYPE mark_boundary;   /* where to stop copying cont marks */
   MZ_MARK_POS_TYPE boundary_mark_pos; /* mark position of prompt */
   Scheme_Object **runstack_boundary_start; /* which stack has runstack_boundary */
   long runstack_boundary_offset;      /* where to stop copying the Scheme stack */
-  void *boundary_dw_id;               /* where to stop copying the dynamic-wind stack */
   mz_jmp_buf *prompt_buf;             /* to jump directly to the prompt */
   long runstack_size;                 /* needed for restore */
 } Scheme_Prompt;
@@ -1087,12 +1097,23 @@ typedef struct Scheme_Prompt {
 Scheme_Object *scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, 
                                                     Scheme_Object *key,
                                                     Scheme_Object *prompt_tag,
-                                                    Scheme_Meta_Continuation **meta_cont);
+                                                    Scheme_Meta_Continuation **_meta_cont,
+                                                    MZ_MARK_POS_TYPE *_pos);
 Scheme_Object *scheme_compose_continuation(Scheme_Cont *c, int num_rands, Scheme_Object *value);
 Scheme_Overflow *scheme_get_thread_end_overflow(void);
 void scheme_end_current_thread(void);
 void scheme_ensure_dw_id(Scheme_Dynamic_Wind *dw);
-void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post, int mc_depth);
+void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post, int mc_depth, struct Scheme_Cont *recheck);
+
+void scheme_drop_prompt_meta_continuations(Scheme_Object *prompt_tag);
+
+struct Scheme_Prompt *scheme_get_barrier_prompt(struct Scheme_Meta_Continuation **_meta_cont,
+                                                MZ_MARK_POS_TYPE *_pos);
+int scheme_is_cm_deeper(struct Scheme_Meta_Continuation *m1, MZ_MARK_POS_TYPE p1,
+                        struct Scheme_Meta_Continuation *m2, MZ_MARK_POS_TYPE p2);
+void scheme_recheck_prompt_and_barrier(struct Scheme_Cont *c);
+
+void scheme_about_to_move_C_stack(void);
 
 /*========================================================================*/
 /*                         semaphores and locks                           */
@@ -1850,7 +1871,8 @@ int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env);
 #define DEFINE_FOR_SYNTAX_EXPD 9
 #define REF_EXPD           10
 #define APPVALS_EXPD       11
-#define _COUNT_EXPD_       12
+#define SPLICE_EXPD        12
+#define _COUNT_EXPD_       13
 
 #define scheme_register_syntax(i, fo, fr, fv, fe, fj, cl, sh, pa)        \
      (scheme_syntax_optimizers[i] = fo, \

src/mzscheme/src/schuchar.inc

@@ -44,7 +44,7 @@ static unsigned short udata[] = {
  0x8a80, 0xa80, 0x8a80, 0x8a80, 0x8a80, 0x8a80, 0x8a80, 0x8a80, 0x8a80, 0x8a80, 0x8a80, 0x804, 0x804, 0x804, 0x1802, 0x804,
  0x1802, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80,
  0x8c80, 0xc80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x8c80, 0x804, 0x802, 0x804, 0x802, 0x8,
- 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8,
+ 0x8, 0x8, 0x8, 0x8, 0x8, 0x18, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8,
  0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8, 0x8,
  0x4011, 0x804, 0x802, 0x802, 0x802, 0x802, 0x802, 0x802, 0xd802, 0x802, 0x4c80, 0x804, 0x802, 0x1000, 0x802, 0x5802,
  0x802, 0x802, 0x4000, 0x4000, 0x5802, 0x4c80, 0x802, 0x1804, 0x5802, 0x4000, 0x4c80, 0x804, 0x4000, 0x4000, 0x4000, 0x804,

src/mzscheme/src/schvers.h

@@ -9,6 +9,6 @@
 
 
 #define MZSCHEME_VERSION_MAJOR 369
-#define MZSCHEME_VERSION_MINOR 1
+#define MZSCHEME_VERSION_MINOR 2
 
-#define MZSCHEME_VERSION "369.1" _MZ_SPECIAL_TAG
+#define MZSCHEME_VERSION "369.2" _MZ_SPECIAL_TAG

src/mzscheme/src/startup.inc

@@ -1619,10 +1619,7 @@
 "(-define(catch-ellipsis-error thunk sexp sloc)"
 "((let/ec esc"
 "(with-continuation-mark"
-" parameterization-key"
+" exception-handler-key"
-"(extend-parameterization"
-"(continuation-mark-set-first #f parameterization-key)"
-" current-exception-handler"
 "(lambda(exn)"
 "(esc"
 "(lambda()"
@@ -1632,7 +1629,7 @@
 " 'syntax"
 " \"incompatible ellipsis match counts for template\""
 " sexp"
-" sloc))))))"
+" sloc)))))"
 "(let((v(thunk)))"
 "(lambda() v))))))"
 "(-define substitute-stop 'dummy)"
@@ -2730,6 +2727,7 @@
 "(unless(continuation-prompt-available? handler-prompt-key) "
 "(error 'with-handlers"
 " \"exception handler used out of context\")))"
+"(define handler-prompt-key(make-continuation-prompt-tag))"
 "(define-syntaxes(with-handlers with-handlers*)"
 "(let((wh "
 "(lambda(disable-break?)"
@@ -2743,8 +2741,7 @@
 "(syntax->list #'(handler ...))))))"
 "(quasisyntax/loc stx"
 "(let((pred-name pred) ..."
-"(handler-name handler) ..."
+"(handler-name handler) ...)"
-"(handler-prompt-key(make-continuation-prompt-tag)))"
 "(let((bpz(continuation-mark-set-first #f break-enabled-key)))"
 "(with-continuation-mark"
 " break-enabled-key"
@@ -2754,9 +2751,9 @@
 "(with-continuation-mark "
 " break-enabled-key"
 " bpz"
-"(parameterize((current-exception-handler"
+"(with-continuation-mark "
+" exception-handler-key"
 "(lambda(e)"
-"(check-with-handlers-in-context handler-prompt-key)"
 "(abort-current-continuation"
 " handler-prompt-key"
 "(lambda()"
@@ -2764,11 +2761,17 @@
 " #'select-handler/no-breaks"
 " #'select-handler/breaks-as-is)"
 " e bpz"
-"(list(cons pred-name handler-name) ...)))))))"
+"(list(cons pred-name handler-name) ...)))))"
-" expr1 expr ...)))"
+"(let()"
+" expr1 expr ...))))"
 " handler-prompt-key"
 "(lambda(thunk)(thunk))))))))))))))"
 "(values(wh #t)(wh #f))))"
+"(define(call-with-exception-handler exnh thunk)"
+"(with-continuation-mark"
+" exception-handler-key"
+" exnh"
+"(thunk)))"
 "(define-syntax set!-values"
 "(lambda(stx)"
 "(syntax-case stx()"
@@ -2838,7 +2841,8 @@
 "(provide case do delay force promise?"
 " parameterize current-parameterization call-with-parameterization"
 " parameterize-break current-break-parameterization call-with-break-parameterization"
-" with-handlers with-handlers* set!-values"
+" with-handlers with-handlers* call-with-exception-handler"
+" set!-values"
 " let/cc let-struct fluid-let time))"
 );
   EVAL_ONE_STR(
@@ -2921,26 +2925,25 @@
 "((negative? lo)(-(find-between(- hi)(- lo))))"
 "(else(find-between lo hi)))))))"
 "(define(read-eval-print-loop)"
-"(let*((jump-key(gensym))"
-"(repl-error-escape-handler"
-"(lambda()"
-"(let((jump-k(continuation-mark-set-first #f jump-key)))"
-"(if jump-k"
-"(jump-k)"
-" (error 'repl-error-escape-handler \"used out of context\"))))))"
-"(parameterize((error-escape-handler repl-error-escape-handler))"
-"(let/ec done-k"
 "(let repl-loop()"
-"(let/ec k"
+"(call-with-continuation-prompt"
-"(with-continuation-mark jump-key k"
+"(lambda()"
 "(let((v((current-prompt-read))))"
-"(when(eof-object? v)(done-k(void)))"
+"(unless(eof-object? v)"
 "(call-with-values"
-"(lambda()((current-eval)(if(syntax? v)"
+"(lambda() "
-"(namespace-syntax-introduce v)"
+"(call-with-continuation-prompt"
-" v)))"
+"(lambda()"
-"(lambda results(for-each(current-print) results))))))"
+"(let((w(cons '#%top-interaction v)))"
-"(repl-loop))))))"
+"((current-eval)(if(syntax? v)"
+"(namespace-syntax-introduce "
+"(datum->syntax-object #f w v))"
+" w))))"
+"(default-continuation-prompt-tag)))"
+"(lambda results(for-each(current-print) results)))"
+"(abort-current-continuation(default-continuation-prompt-tag)))))"
+"(default-continuation-prompt-tag)"
+"(lambda args(repl-loop)))))"
 "(define load/cd"
 "(lambda(n)"
 "(unless(path-string? n)"
@@ -3544,7 +3547,17 @@
 "(stx-cdr stx))"
 " stx)"
 " (raise-syntax-error #f \"bad syntax\" stx))))"
-"(provide mzscheme-in-stx-module-begin))"
+"(define-syntax #%top-interaction"
+"(lambda(stx)"
+"(if(eq? 'top-level(syntax-local-context))"
+" 'ok"
+"(raise-syntax-error"
+" #f"
+" \"not at top level\""
+" stx))"
+"(datum->syntax-object stx(stx-cdr stx) stx stx)))"
+"(provide mzscheme-in-stx-module-begin"
+" #%top-interaction))"
 );
   EVAL_ONE_STR(
 "(module mzscheme #%kernel"
@@ -3563,6 +3576,7 @@
 "(all-from #%qqstx)"
 "(all-from #%define)"
 "(all-from-except #%kernel #%module-begin)"
+" #%top-interaction"
 "(rename mzscheme-in-stx-module-begin #%module-begin)"
 "(rename #%module-begin #%plain-module-begin)))"
 );
@@ -3603,7 +3617,7 @@
 "(rename r5rs:letrec letrec)"
 " let* begin lambda quote set!"
 " define-syntax let-syntax letrec-syntax"
-" #%app #%datum #%top))"
+" #%app #%datum #%top #%top-interaction))"
 );
   EVAL_ONE_STR(
 "(require(only mzscheme namespace-require/copy))"

src/mzscheme/src/startup.ss

@@ -1906,10 +1906,7 @@
   (-define (catch-ellipsis-error thunk sexp sloc)
       ((let/ec esc
 	 (with-continuation-mark
-	     parameterization-key
+	     exception-handler-key
-	     (extend-parameterization
-	      (continuation-mark-set-first #f parameterization-key)
-	      current-exception-handler
              (lambda (exn)
                (esc
                 (lambda ()
@@ -1919,7 +1916,7 @@
                        'syntax
                        "incompatible ellipsis match counts for template"
                        sexp
-			sloc))))))
+                       sloc)))))
 	   (let ([v (thunk)])
 	     (lambda () v))))))
 
@@ -3142,6 +3139,8 @@
       (error 'with-handlers
              "exception handler used out of context")))
 
+  (define handler-prompt-key (make-continuation-prompt-tag))
+
   (define-syntaxes (with-handlers with-handlers*)
     (let ([wh 
 	   (lambda (disable-break?)
@@ -3155,8 +3154,7 @@
 									       (syntax->list #'(handler ...))))])
 		    (quasisyntax/loc stx
 		      (let ([pred-name pred] ...
-			    [handler-name handler] ...
+			    [handler-name handler] ...)
-                            [handler-prompt-key (make-continuation-prompt-tag)])
 			;; Capture current break parameterization, so we can use it to
 			;;  evaluate the body
 			(let ([bpz (continuation-mark-set-first #f break-enabled-key)])
@@ -3176,9 +3174,9 @@
 			       (with-continuation-mark 
 				   break-enabled-key
 				   bpz
-				 (parameterize ([current-exception-handler
+                                 (with-continuation-mark 
+                                     exception-handler-key
                                      (lambda (e)
-                                                   (check-with-handlers-in-context handler-prompt-key)
                                        ;; Deliver a thunk to the escape handler:
                                        (abort-current-continuation
                                         handler-prompt-key
@@ -3187,13 +3185,20 @@
                                                  #'select-handler/no-breaks
                                                  #'select-handler/breaks-as-is)
                                            e bpz
-						       (list (cons pred-name handler-name) ...)))))])
+                                           (list (cons pred-name handler-name) ...)))))
-				   expr1 expr ...)))
+                                   (let ()
+                                     expr1 expr ...))))
                              handler-prompt-key
 			     ;; On escape, apply the handler thunk
 			     (lambda (thunk) (thunk))))))))])))])
       (values (wh #t) (wh #f))))
 
+  (define (call-with-exception-handler exnh thunk)
+    (with-continuation-mark
+        exception-handler-key
+        exnh
+      (thunk)))
+
   (define-syntax set!-values
     (lambda (stx)
       (syntax-case stx ()
@@ -3268,7 +3273,8 @@
   (provide case do delay force promise?
 	   parameterize current-parameterization call-with-parameterization
 	   parameterize-break current-break-parameterization call-with-break-parameterization
-	   with-handlers with-handlers* set!-values
+	   with-handlers with-handlers* call-with-exception-handler
+           set!-values
 	   let/cc let-struct fluid-let time))
 
 ;;----------------------------------------------------------------------
@@ -3360,30 +3366,30 @@
 	   [else (find-between lo hi)])))))
 
   (define (read-eval-print-loop)
-    (let* ([jump-key (gensym)]
-	   [repl-error-escape-handler
-	    (lambda ()
-	      (let ([jump-k (continuation-mark-set-first #f jump-key)])
-		(if jump-k
-		    (jump-k)
-		    (error 'repl-error-escape-handler "used out of context"))))])
-      ;; This parameterize is outside the loop so that
-      ;;  expressions evaluated in the REPL can set the
-      ;;  error escape handler. That's why we communicate the
-      ;;  actual escape target through a continuation mark.
-      (parameterize ([error-escape-handler repl-error-escape-handler])
-	(let/ec done-k
     (let repl-loop ()
-	    (let/ec k
+      ;; This prompt catches all error escapes, including from read and print.
-	      (with-continuation-mark jump-key k
+      (call-with-continuation-prompt
+       (lambda ()
          (let ([v ((current-prompt-read))])
-		  (when (eof-object? v) (done-k (void)))
+           (unless (eof-object? v)
              (call-with-values
-		      (lambda () ((current-eval) (if (syntax? v)
+                 (lambda () 
-						     (namespace-syntax-introduce v)
+                   ;; This prompt catches escapes during evaluation.
-						     v)))
+                   ;; Unlike the outer prompt, the handler prints
-		    (lambda results (for-each (current-print) results))))))
+                   ;; the results.
-	    (repl-loop))))))
+                   (call-with-continuation-prompt
+                    (lambda ()
+                      (let ([w (cons '#%top-interaction v)])
+                        ((current-eval) (if (syntax? v)
+                                            (namespace-syntax-introduce 
+                                             (datum->syntax-object #f w v))
+                                            w))))
+                    (default-continuation-prompt-tag)))
+               (lambda results (for-each (current-print) results)))
+             ;; Abort to loop. (Calling `repl-loop' directory would not be a tail call.)
+             (abort-current-continuation (default-continuation-prompt-tag)))))
+       (default-continuation-prompt-tag)
+       (lambda args (repl-loop)))))
 
   (define load/cd
     (lambda (n)
@@ -4046,7 +4052,18 @@
 	   stx)
 	  (raise-syntax-error #f "bad syntax" stx))))
 
-  (provide mzscheme-in-stx-module-begin))
+  (define-syntax #%top-interaction
+    (lambda (stx)
+      (if (eq? 'top-level (syntax-local-context))
+          'ok
+          (raise-syntax-error
+           #f
+           "not at top level"
+           stx))
+      (datum->syntax-object stx (stx-cdr stx) stx stx)))
+
+  (provide mzscheme-in-stx-module-begin
+           #%top-interaction))
 
 ;;----------------------------------------------------------------------
 ;; mzscheme: provide everything
@@ -4068,6 +4085,7 @@
 	   (all-from #%qqstx)
 	   (all-from #%define)
 	   (all-from-except #%kernel #%module-begin)
+           #%top-interaction
 	   (rename mzscheme-in-stx-module-begin #%module-begin)
 	   (rename #%module-begin #%plain-module-begin)))
 
@@ -4116,7 +4134,7 @@
 
 	   ;; We have to include the following MzScheme-isms to do anything,
 	   ;; but they're not legal R5RS names, anyway.
-	   #%app #%datum #%top))
+	   #%app #%datum #%top #%top-interaction))
 
 ;;----------------------------------------------------------------------
 ;; init namespace

src/mzscheme/src/string.c

@@ -1835,7 +1835,7 @@ sch_printf(int argc, Scheme_Object *argv[])
 static Scheme_Object *
 sch_fprintf(int argc, Scheme_Object *argv[])
 {
-  if (!SCHEME_OUTPORTP(argv[0]))
+  if (!SCHEME_OUTPUT_PORTP(argv[0]))
     scheme_wrong_type("fprintf", "output-port", 0, argc, argv);
 
   scheme_do_format("fprintf", argv[0], NULL, 0, 1, 2, argc, argv);

src/mzscheme/src/struct.c

@@ -26,6 +26,7 @@
 Scheme_Object *scheme_arity_at_least, *scheme_date;
 Scheme_Object *scheme_make_arity_at_least;
 Scheme_Object *scheme_source_property;
+Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
 
 /* locals */
 
@@ -60,6 +61,8 @@ static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[])
 static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *argv[]);
+static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]);
+static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Object *argv[]);
 
 static Scheme_Object *make_struct_type(int argc, Scheme_Object *argv[]);
 
@@ -99,6 +102,8 @@ static Scheme_Object *evt_property;
 static int evt_struct_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
 static int is_evt_struct(Scheme_Object *);
 
+static Scheme_Object *proc_property;
+
 static int wrapped_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
 static int nack_guard_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
 static int nack_evt_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
@@ -229,7 +234,7 @@ scheme_init_struct (Scheme_Env *env)
   {
     Scheme_Object *guard, *a[2], *pred, *access;
     guard = scheme_make_prim_w_arity(check_write_property_value_ok,
-				     "prop:custom-write-guard",
+				     "guard-for-prop:custom-write",
 				     2, 2);
 
     a[0] = scheme_intern_symbol("custom-write");
@@ -247,7 +252,7 @@ scheme_init_struct (Scheme_Env *env)
   {
     Scheme_Object *guard;
     guard = scheme_make_prim_w_arity(check_evt_property_value_ok,
-				     "prop:evt-guard",
+				     "guard-for-prop:evt",
 				     2, 2);
     evt_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("evt"),
                                                             guard);
@@ -259,6 +264,33 @@ scheme_init_struct (Scheme_Env *env)
 		   is_evt_struct, 1);
   }
 
+  {
+    REGISTER_SO(proc_property);
+    proc_property = scheme_make_struct_type_property(scheme_intern_symbol("procedure"));
+    scheme_add_global_constant("prop:procedure", proc_property, env);
+  }
+
+  {
+    Scheme_Object *guard;
+    REGISTER_SO(scheme_input_port_property);
+    REGISTER_SO(scheme_output_port_property);
+
+    guard = scheme_make_prim_w_arity(check_input_port_property_value_ok,
+				     "guard-for-prop:input-port",
+				     2, 2);
+    scheme_input_port_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("input-port"),
+                                                                          guard);
+    
+    guard = scheme_make_prim_w_arity(check_output_port_property_value_ok,
+				     "guard-for-prop:output-port",
+				     2, 2);
+    scheme_output_port_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("output-port"),
+                                                                           guard);
+    
+    scheme_add_global_constant("prop:input-port", scheme_input_port_property, env);
+    scheme_add_global_constant("prop:output-port", scheme_output_port_property, env);
+  }
+
   REGISTER_SO(scheme_recur_symbol);
   REGISTER_SO(scheme_display_symbol);
   REGISTER_SO(scheme_write_special_symbol);
@@ -451,7 +483,7 @@ scheme_init_struct (Scheme_Env *env)
   {
     Scheme_Object *guard;
     guard = scheme_make_prim_w_arity(check_exn_source_property_value_ok,
-				     "prop:exn:srclocs-guard",
+				     "guard-for-prop:exn:srclocs",
 				     2, 2);
     scheme_source_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("prop:exn:srclocs"),
 								      guard);
@@ -587,7 +619,7 @@ static Scheme_Object *prop_pred(int argc, Scheme_Object **args, Scheme_Object *p
   return scheme_false;
 }
 
-static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg, int error_ok, const char *name)
+XFORM_NONGCING static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg)
 {
   Scheme_Struct_Type *stype;
 
@@ -601,7 +633,7 @@ static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg,
   if (stype) {
     if (stype->num_props < 0) {
       Scheme_Object *v;
-      v = (Scheme_Object *)scheme_hash_get((Scheme_Hash_Table *)stype->props, prop);
+      v = (Scheme_Object *)scheme_eq_hash_get((Scheme_Hash_Table *)stype->props, prop);
       if (v)
 	return v;
     } else {
@@ -613,17 +645,21 @@ static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg,
     }
   }
   
-  if (error_ok) /* hack; see scheme_struct_type_property_ref */
-    scheme_wrong_type(name ? name : "property accessor", 
-		      "struct or struct-type with property", 
-		      0, 1, (Scheme_Object **)&arg);
   return NULL;
 }
 
 static Scheme_Object *prop_accessor(int argc, Scheme_Object **args, Scheme_Object *prim)
 {
-  return do_prop_accessor(SCHEME_PRIM_CLOSURE_ELS(prim)[0], args[0], 1, 
+  Scheme_Object *v;
-			  ((Scheme_Primitive_Proc *)prim)->name);
+
+  v = do_prop_accessor(SCHEME_PRIM_CLOSURE_ELS(prim)[0], args[0]);
+  
+  if (!v)
+    scheme_wrong_type(((Scheme_Primitive_Proc *)prim)->name, 
+		      "struct or struct-type with property",
+                      0, 1, args);
+  
+  return v;
 }
 
 static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[])
@@ -693,7 +729,7 @@ Scheme_Object *scheme_make_struct_type_property(Scheme_Object *name)
 
 Scheme_Object *scheme_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s)
 {
-  return do_prop_accessor(prop, s, 0, NULL);
+  return do_prop_accessor(prop, s);
 }
 
 static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[])
@@ -726,10 +762,20 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche
 /*                            evt structs                                 */
 /*========================================================================*/
 
+static int extract_accessor_offset(Scheme_Object *acc)
+{
+  Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(acc)[0];
+
+  if (i->struct_type->name_pos)
+    return i->struct_type->parent_types[i->struct_type->name_pos - 1]->num_slots;
+  else
+    return 0;
+}
+
 static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[])
 /* This is the guard for prop:evt */
 {
-  Scheme_Object *v, *l;
+  Scheme_Object *v, *l, *acc;
   int pos, num_islots;
 
   v = argv[0];
@@ -742,7 +788,7 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
   
   if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0))
 	|| (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v))))
-    scheme_arg_mismatch("prop:evt-guard",
+    scheme_arg_mismatch("guard-for-prop:evt",
 			"property value is not a evt, procedure (arity 1), or exact non-negative integer: ",
 			v);
 
@@ -751,6 +797,7 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
   num_islots = SCHEME_INT_VAL(SCHEME_CAR(l));
   l = SCHEME_CDR(l);
   l = SCHEME_CDR(l);
+  acc = SCHEME_CAR(l);
   l = SCHEME_CDR(l);
   l = SCHEME_CDR(l);
   l = SCHEME_CAR(l);
@@ -761,7 +808,7 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
     pos = SCHEME_INT_VAL(v);
 
   if (pos >= num_islots) {
-    scheme_arg_mismatch("evt-property-guard",
+    scheme_arg_mismatch("guard-for-prop:evt",
 			"field index >= initialized-field count for structure type: ",
 			v);
   }
@@ -772,11 +819,14 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[
   }
 
   if (!SCHEME_PAIRP(l)) {
-    scheme_arg_mismatch("evt-property-guard",
+    scheme_arg_mismatch("guard-for-prop:evt",
 			"field index not declared immutable: ",
 			v);
   }
 
+  pos += extract_accessor_offset(acc);
+  v = scheme_make_integer(pos);
+
   return v;
 }
 
@@ -786,6 +836,17 @@ static int evt_struct_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo)
 
   v = scheme_struct_type_property_ref(evt_property, o);
 
+  if (!v) {
+    /* Must be an input or output port: */
+    if (SCHEME_INPUT_PORTP(o)) {
+      v = (Scheme_Object *)scheme_input_port_record(o);
+    } else {
+      v = (Scheme_Object *)scheme_output_port_record(o);
+    }
+    scheme_set_sync_target(sinfo, v, NULL, NULL, 0, 1);
+    return 0;
+  }
+
   if (SCHEME_INTP(v))
     v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)];
 
@@ -825,7 +886,85 @@ static int evt_struct_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo)
 
 static int is_evt_struct(Scheme_Object *o)
 {
-  return !!scheme_struct_type_property_ref(evt_property, o);
+  if (scheme_struct_type_property_ref(evt_property, o))
+    return 1;
+  if (scheme_struct_type_property_ref(scheme_input_port_property, o))
+    return 1;
+  if (scheme_struct_type_property_ref(scheme_output_port_property, o))
+    return 1;
+  return 0;
+}
+
+/*========================================================================*/
+/*                            port structs                                */
+/*========================================================================*/
+
+static Scheme_Object *check_port_property_value_ok(const char *name, int input, int argc, Scheme_Object *argv[])
+/* This is the guard for prop:input-port and prop:output-port */
+{
+  Scheme_Object *v, *l, *acc;
+  int pos, num_islots;
+
+  v = argv[0];
+
+  if ((input && SCHEME_INPUT_PORTP(v))
+      || (!input && SCHEME_OUTPUT_PORTP(v)))
+    return v;
+
+  if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0))
+	|| (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v))))
+    scheme_arg_mismatch(name,
+                        (input
+                         ? "property value is not an input port or exact non-negative integer: "
+                         : "property value is not an output port or exact non-negative integer: "),
+			v);
+  
+  l = argv[1];
+  l = SCHEME_CDR(l);
+  num_islots = SCHEME_INT_VAL(SCHEME_CAR(l));
+  l = SCHEME_CDR(l);
+  l = SCHEME_CDR(l);
+  acc = SCHEME_CAR(l);
+  l = SCHEME_CDR(l);
+  l = SCHEME_CDR(l);
+  l = SCHEME_CAR(l);
+
+  if (SCHEME_BIGNUMP(v))
+    pos = num_islots; /* too big */
+  else
+    pos = SCHEME_INT_VAL(v);
+
+  if (pos >= num_islots) {
+    scheme_arg_mismatch(name,
+			"field index >= initialized-field count for structure type: ",
+			v);
+  }
+
+  for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
+    if (SCHEME_INT_VAL(SCHEME_CAR(l)) == pos)
+      break;
+  }
+
+  if (!SCHEME_PAIRP(l)) {
+    scheme_arg_mismatch(name,
+			"field index not declared immutable: ",
+			v);
+  }
+
+  pos += extract_accessor_offset(acc);
+  v = scheme_make_integer(pos);
+
+  return v;
+}
+
+static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[])
+{
+  return check_port_property_value_ok("guard-for-prop:input-port", 1, argc, argv);
+}
+
+static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Object *argv[])
+{
+  return check_port_property_value_ok("guard-for-prop:output-port", 0, argc, argv);
 }
 
 /*========================================================================*/
@@ -839,7 +978,7 @@ static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *arg
   v = argv[0];
 
   if (!scheme_check_proc_arity(NULL, 3, 0, argc, argv)) {
-    scheme_arg_mismatch("prop:custom-write-guard",
+    scheme_arg_mismatch("guard-for-prop:custom-write",
 			"not a procedure of arity 3: ",
 			v); 
   }
@@ -2255,6 +2394,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
 {
   Scheme_Struct_Type *struct_type, *parent_type;
   int j, depth;
+  int props_delta = 0, prop_needs_const = 0;
   
   parent_type = (Scheme_Struct_Type *)parent;
 
@@ -2323,17 +2463,37 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
     uninit_val = scheme_false;
   struct_type->uninit_val = uninit_val;
 
+  if (props) {
+    Scheme_Object *l;
+    for (l = props; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
+      if (SAME_OBJ(SCHEME_CAAR(l), proc_property)) {
         if (proc_attr) {
-    if (SCHEME_INTP(proc_attr) || SCHEME_BIGNUMP(proc_attr)) {
+          scheme_arg_mismatch("make-struct-type", 
+                              "given both a prop:procedure property value and a procedure specification: ", 
+                              proc_attr);
+        }
+        proc_attr = SCHEME_CDR(SCHEME_CAR(l));
+        if (SCHEME_INTP(proc_attr))
+          prop_needs_const = 1;
+        props_delta = 1;
+        break;
+      }
+    }
+  }
+
+  if (proc_attr) {
+    Scheme_Object *pa = proc_attr;
+
+    if (SCHEME_INTP(pa) || SCHEME_BIGNUMP(pa)) {
       long pos;
 
-      if (SCHEME_INTP(proc_attr))
+      if (SCHEME_INTP(pa))
-	pos = SCHEME_INT_VAL(proc_attr);
+	pos = SCHEME_INT_VAL(pa);
       else
 	pos = struct_type->num_slots; /* too big */
 
       if (pos >= struct_type->num_islots) {
-	scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", proc_attr);
+	scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", pa);
 	return NULL;
       }
 
@@ -2341,16 +2501,16 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
 	if (parent_type->proc_attr) {
 	  scheme_arg_mismatch("make-struct-type", 
 			      "parent type already has procedure specification, new one disallowed: ",
-			      proc_attr);
+			      pa);
 	  return NULL;
 	}
 
 	pos += parent_type->num_slots;
-	proc_attr = scheme_make_integer(pos);
+	pa = scheme_make_integer(pos);
       }
     }
 
-    struct_type->proc_attr = proc_attr;
+    struct_type->proc_attr = pa;
   }
 
   if ((struct_type->proc_attr && SCHEME_INTP(struct_type->proc_attr))
@@ -2365,11 +2525,8 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
     ims = (char *)scheme_malloc_atomic(n);
     memset(ims, 0, n);
 
-    if (SCHEME_INTP(struct_type->proc_attr)) {
+    if (proc_attr && SCHEME_INTP(proc_attr) && !prop_needs_const) {
-      p = SCHEME_INT_VAL(struct_type->proc_attr);
+      p = SCHEME_INT_VAL(proc_attr);
-      if (parent_type)
-	p -= parent_type->num_slots;
-      if (p >= 0)
       ims[p] = 1;
     }
 
@@ -2397,6 +2554,15 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
       ims[p] = 1;
     }
 
+    if (proc_attr && SCHEME_INTP(proc_attr) && prop_needs_const) {
+      p = SCHEME_INT_VAL(proc_attr);
+      if (!ims[p]) {
+        scheme_arg_mismatch("make-struct-type", 
+                            "field is not specified as immutable for a prop:procedure index: ", 
+                            proc_attr);
+      }
+    }
+    
     struct_type->immutables = ims;
   }
 
@@ -2410,7 +2576,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
 
     can_override = scheme_make_hash_table(SCHEME_hash_ptr);
 
-    num_props = scheme_list_length(props);
+    num_props = scheme_list_length(props) - props_delta;
     if ((struct_type->num_props < 0) || (struct_type->num_props + num_props > PROP_USE_HT_COUNT)) {
       Scheme_Hash_Table *ht;
 
@@ -2438,6 +2604,12 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
       for (l = props; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
 	a = SCHEME_CAR(l);
 	prop = SCHEME_CAR(a);
+        if (SAME_OBJ(prop, proc_property)) {
+          if (props_delta)
+            props_delta = 0;
+          else
+            break;
+        } else {
           if (scheme_hash_get(ht, prop)) {
             /* Property is already in the superstruct_type */
             if (!scheme_hash_get(can_override, prop))
@@ -2450,6 +2622,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
           
           scheme_hash_set(ht, prop, propv);
         }
+      }
 
       struct_type->props = (Scheme_Object **)ht;
       struct_type->num_props = -1;
@@ -2474,6 +2647,12 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
 
 	prop = SCHEME_CAR(a);
 
+        if (SAME_OBJ(prop, proc_property)) {
+          if (props_delta)
+            props_delta = 0;
+          else
+            break;
+        } else {
           /* Check whether already in table: */
           for (j = 0; j < num_props; j++) {
             if (SAME_OBJ(SCHEME_CAR(pa[j]), prop))
@@ -2494,6 +2673,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
           a = scheme_make_pair(prop, propv);
           pa[j] = a;
         }
+      }
       
       struct_type->num_props = num_props;
       struct_type->props = pa;
@@ -2849,7 +3029,7 @@ static Scheme_Object *exn_source_get(int argc, Scheme_Object **argv)
 static Scheme_Object *check_exn_source_property_value_ok(int argc, Scheme_Object *argv[])
      /* This is the guard for prop:exn:srclocs */
 {
-  scheme_check_proc_arity("prop:exn:srclocs-guard", 1, 0, argc, argv);
+  scheme_check_proc_arity("guard-for-prop:exn:srclocs", 1, 0, argc, argv);
 
   return argv[0];
 }

src/mzscheme/src/syntax.c

@@ -74,6 +74,8 @@ static Scheme_Object *begin_syntax (Scheme_Object *form, Scheme_Comp_Env *env, S
 static Scheme_Object *begin_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
 static Scheme_Object *begin0_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
 static Scheme_Object *begin0_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
+static Scheme_Object *expression_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
+static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
 
 static Scheme_Object *unquote_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
 static Scheme_Object *unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
@@ -98,6 +100,7 @@ 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 *apply_values_execute(Scheme_Object *data);
+static Scheme_Object *splice_execute(Scheme_Object *data);
 
 static Scheme_Object *bangboxenv_execute(Scheme_Object *data);
 static Scheme_Object *bangboxvalue_execute(Scheme_Object *data);
@@ -110,16 +113,19 @@ static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *expr, Optimize
 static Scheme_Object *case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info);
 static Scheme_Object *begin0_optimize(Scheme_Object *data, Optimize_Info *info);
 static Scheme_Object *apply_values_optimize(Scheme_Object *data, Optimize_Info *info);
+static Scheme_Object *splice_optimize(Scheme_Object *data, Optimize_Info *info);
 
 static Scheme_Object *begin0_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
 static Scheme_Object *set_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
 static Scheme_Object *apply_values_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
+static Scheme_Object *splice_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
 
 static Scheme_Object *begin0_shift(Scheme_Object *data, int delta, int after_depth);
 static Scheme_Object *set_shift(Scheme_Object *data, int delta, int after_depth);
 static Scheme_Object *ref_shift(Scheme_Object *data, int delta, int after_depth);
 static Scheme_Object *case_lambda_shift(Scheme_Object *data, int delta, int after_depth);
 static Scheme_Object *apply_values_shift(Scheme_Object *data, int delta, int after_depth);
+static Scheme_Object *splice_shift(Scheme_Object *data, int delta, int after_depth);
 
 static Scheme_Object *define_values_resolve(Scheme_Object *data, Resolve_Info *info);
 static Scheme_Object *ref_resolve(Scheme_Object *data, Resolve_Info *info);
@@ -129,6 +135,7 @@ static Scheme_Object *define_for_syntaxes_resolve(Scheme_Object *expr, Resolve_I
 static Scheme_Object *case_lambda_resolve(Scheme_Object *expr, Resolve_Info *info);
 static Scheme_Object *begin0_resolve(Scheme_Object *data, Resolve_Info *info);
 static Scheme_Object *apply_values_resolve(Scheme_Object *data, Resolve_Info *info);
+static Scheme_Object *splice_resolve(Scheme_Object *data, Resolve_Info *info);
 
 static void define_values_validate(Scheme_Object *data, Mz_CPort *port, 
                                    char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
@@ -162,6 +169,10 @@ static void apply_values_validate(Scheme_Object *data, Mz_CPort *port,
                                   char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
                                   int depth, int letlimit, int delta,
                                   int num_toplevels, int num_stxes, int num_lifts);
+static void splice_validate(Scheme_Object *data, Mz_CPort *port, 
+                            char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
+                            int depth, int letlimit, int delta,
+                            int num_toplevels, int num_stxes, int num_lifts);
 static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, 
                                 char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
                                 int depth, int letlimit, int delta,
@@ -179,6 +190,7 @@ 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 *apply_values_jit(Scheme_Object *data);
+static Scheme_Object *splice_jit(Scheme_Object *data);
 static Scheme_Object *bangboxvalue_jit(Scheme_Object *data);
 
 static Scheme_Object *expand_lam(int argc, Scheme_Object **argv);
@@ -293,6 +305,12 @@ scheme_init_syntax (Scheme_Env *env)
 			 apply_values_execute, apply_values_jit, 
 			 apply_values_clone, apply_values_shift, 1);
 
+  scheme_register_syntax(SPLICE_EXPD,
+			 splice_optimize,
+			 splice_resolve, splice_validate,
+			 splice_execute, splice_jit, 
+			 splice_clone, splice_shift, 0);
+
   scheme_register_syntax(BOXENV_EXPD, 
 			 NULL, NULL, bangboxenv_validate,
 			 bangboxenv_execute, NULL, 
@@ -357,6 +375,11 @@ scheme_init_syntax (Scheme_Env *env)
 							ref_expand), 
 			    env);
 
+  scheme_add_global_keyword("#%expression", 
+			    scheme_make_compiled_syntax(expression_syntax,
+							expression_expand), 
+			    env);
+
   scheme_add_global_keyword("case-lambda", 
 			    scheme_make_compiled_syntax(case_lambda_syntax, 
 							case_lambda_expand), 
@@ -4186,6 +4209,12 @@ do_begin_syntax(char *name,
 
   forms = scheme_make_sequence_compilation(body, zero ? -1 : 1);
 
+  if (!zero
+      && SAME_TYPE(SCHEME_TYPE(forms), scheme_sequence_type)
+      && scheme_is_toplevel(env)) {
+    return scheme_make_syntax_compiled(SPLICE_EXPD, forms);
+  }
+
   if (!zero || (NOT_SAME_TYPE(SCHEME_TYPE(forms), scheme_begin0_sequence_type)))
     return forms;
 
@@ -4291,6 +4320,134 @@ begin0_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *ere
   return do_begin_expand("begin0", form, env, erec, drec, 1);
 }
 
+/**********************************************************************/
+/*                    top-level splicing begin                        */
+/**********************************************************************/
+
+static Scheme_Object *splice_one_expr(void *expr, int argc, Scheme_Object **argv)
+{
+  return _scheme_eval_linked_expr_multi((Scheme_Object *)expr);
+}
+
+static Scheme_Object *splice_execute(Scheme_Object *data)
+{
+  Scheme_Sequence *seq = (Scheme_Sequence *)data;
+  int i, cnt = seq->count - 1;
+
+  for (i = 0; i < cnt; i++) {
+    (void)_scheme_call_with_prompt_multi(splice_one_expr, seq->array[i]);
+  }
+
+  return _scheme_eval_linked_expr_multi(seq->array[cnt]);
+}
+
+static Scheme_Object *splice_jit(Scheme_Object *data)
+{
+  return scheme_jit_expr(data);
+}
+
+static Scheme_Object *
+splice_optimize(Scheme_Object *data, Optimize_Info *info)
+{
+  data = scheme_optimize_expr(data, info);
+  
+  if (SCHEME_TYPE(data) != scheme_sequence_type)
+    return data;
+
+  return scheme_make_syntax_compiled(SPLICE_EXPD, data);
+}
+
+static Scheme_Object *
+splice_resolve(Scheme_Object *data, Resolve_Info *rslv)
+{
+  return scheme_make_syntax_resolved(SPLICE_EXPD, 
+                                     scheme_resolve_expr(data, rslv));
+}
+
+static Scheme_Object *
+splice_shift(Scheme_Object *data, int delta, int after_depth)
+{
+  return scheme_make_syntax_compiled(SPLICE_EXPD,
+                                     scheme_optimize_shift(data, delta, after_depth));
+}
+
+static Scheme_Object *
+splice_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
+{
+  data = scheme_optimize_clone(dup_ok, data, info, delta, closure_depth);
+  if (!data) return NULL;
+  return scheme_make_syntax_compiled(SPLICE_EXPD, data);
+}
+
+static void splice_validate(Scheme_Object *data, Mz_CPort *port, 
+                            char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
+                            int depth, int letlimit, int delta, 
+                            int num_toplevels, int num_stxes, int num_lifts)
+{
+  scheme_validate_expr(port, data, stack, ht, tls,
+                       depth, letlimit, delta, 
+                       num_toplevels, num_stxes, num_lifts,
+                       NULL, 0);
+}
+
+/**********************************************************************/
+/*                    #%non-module and #%expression                   */
+/**********************************************************************/
+
+static Scheme_Object *check_single(Scheme_Object *form, Scheme_Comp_Env *top_only)
+{
+  Scheme_Object *rest;
+
+  check_form(form, form);
+
+  rest = SCHEME_STX_CDR(form);
+  if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))))
+    scheme_wrong_syntax(NULL, NULL, form, "bad syntax (wrong number of parts)");
+
+  if (top_only && !scheme_is_toplevel(top_only))
+    scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)");
+
+  return SCHEME_STX_CAR(rest);
+}
+
+static Scheme_Object *
+single_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int top_only)
+{
+  return scheme_compile_expr(check_single(form, top_only ? env: NULL), env, rec, drec);
+}
+
+static Scheme_Object *
+single_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec, 
+              int top_only, int simplify)
+{
+  Scheme_Object *expr, *form_name;
+
+  expr = check_single(form, top_only ? env : NULL);
+  expr = scheme_expand_expr(expr, env, erec, drec);
+
+  if (simplify && (erec[drec].depth == -1)) {
+    return expr;
+  }
+
+  form_name = SCHEME_STX_CAR(form);
+
+  return scheme_datum_to_syntax(icons(form_name, icons(expr, scheme_null)), 
+				form, form,
+				0, 2);
+}
+
+static Scheme_Object *expression_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
+{
+  return single_syntax(form, scheme_no_defines(env), rec, drec, 0);
+}
+
+static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
+{
+  return single_expand(form, scheme_no_defines(env), erec, drec, 0,
+                       !scheme_is_toplevel(env));
+}
+
+
 /**********************************************************************/
 /*                      unquote, unquote-splicing                     */
 /**********************************************************************/

src/mzscheme/src/thread.c

@@ -178,6 +178,7 @@ static Scheme_Custodian *last_custodian;
 static Scheme_Object *scheduled_kills;
 
 Scheme_Object *scheme_parameterization_key;
+Scheme_Object *scheme_exn_handler_key;
 Scheme_Object *scheme_break_enabled_key;
 
 long scheme_total_gc_time;
@@ -754,8 +755,10 @@ void scheme_init_parameterization(Scheme_Env *env)
   Scheme_Object *v;
   Scheme_Env *newenv;
 
+  REGISTER_SO(scheme_exn_handler_key);
   REGISTER_SO(scheme_parameterization_key);
   REGISTER_SO(scheme_break_enabled_key);
+  scheme_exn_handler_key = scheme_make_symbol("exnh");
   scheme_parameterization_key = scheme_make_symbol("paramz");
   scheme_break_enabled_key = scheme_make_symbol("break-on?");
   
@@ -765,6 +768,9 @@ void scheme_init_parameterization(Scheme_Env *env)
   v = scheme_intern_symbol("#%paramz");
   newenv = scheme_primitive_module(v, env);
   
+  scheme_add_global_constant("exception-handler-key", 
+			     scheme_exn_handler_key,
+			     newenv);
   scheme_add_global_constant("parameterization-key", 
 			     scheme_parameterization_key,
 			     newenv);
@@ -786,6 +792,7 @@ void scheme_init_parameterization(Scheme_Env *env)
 
 
   scheme_finish_primitive_module(newenv);
+  scheme_protect_primitive_provide(newenv, NULL);
 }
 
 static Scheme_Object *collect_garbage(int c, Scheme_Object *p[])
@@ -2526,11 +2533,6 @@ static Scheme_Object *make_subprocess(Scheme_Object *child_thunk,
       maybe_recycle_cell = NULL;
   }
 
-  config = scheme_init_error_escape_proc(config);
-  config = scheme_extend_config(config, MZCONFIG_EXN_HANDLER,
-				scheme_get_thread_param(config, cells,
-							MZCONFIG_INIT_EXN_HANDLER));
-  
   child = make_thread(config, cells, break_cell, mgr);
 
   /* Use child_thunk name, if any, for the thread name: */
@@ -2884,15 +2886,6 @@ Scheme_Object *scheme_call_as_nested_thread(int argc, Scheme_Object *argv[], voi
   {
     Scheme_Config *config;
     config = scheme_current_config();
-    config = scheme_init_error_escape_proc(config);
-    if (!nested_exn_handler) {
-      REGISTER_SO(nested_exn_handler);
-      nested_exn_handler = scheme_make_prim_w_arity(def_nested_exn_handler,
-						    "nested-thread-exception-handler",
-						    1, 1);
-    }
-    config = scheme_extend_config(config, MZCONFIG_EXN_HANDLER, nested_exn_handler);
-
     np->init_config = config;
   }
   {
@@ -2946,6 +2939,14 @@ Scheme_Object *scheme_call_as_nested_thread(int argc, Scheme_Object *argv[], voi
   if (p != scheme_main_thread)
     scheme_weak_suspend_thread(p);
 
+  if (!nested_exn_handler) {
+    REGISTER_SO(nested_exn_handler);
+    nested_exn_handler = scheme_make_prim_w_arity(def_nested_exn_handler,
+                                                  "nested-thread-exception-handler",
+                                                  1, 1);
+  }
+  scheme_set_cont_mark(scheme_exn_handler_key, nested_exn_handler);
+
   /* Call thunk, catch escape: */
   np->error_buf = &newbuf;
   if (scheme_setjmp(newbuf)) {
@@ -3969,6 +3970,11 @@ void scheme_weak_resume_thread(Scheme_Thread *r)
   }
 }
 
+void scheme_about_to_move_C_stack(void)
+{
+  wait_until_suspend_ok();
+}
+
 static Scheme_Object *
 sch_sleep(int argc, Scheme_Object *args[])
 {
@@ -5533,7 +5539,19 @@ static Scheme_Object *do_param(void *data, int argc, Scheme_Object *argv[]);
 
 Scheme_Config *scheme_current_config()
 {
-  return (Scheme_Config *)scheme_extract_one_cc_mark(NULL, scheme_parameterization_key);
+  Scheme_Object *v;
+
+  v = scheme_extract_one_cc_mark(NULL, scheme_parameterization_key);
+
+  if (!SAME_TYPE(scheme_config_type, SCHEME_TYPE(v))) {
+    /* Someone has grabbed parameterization-key out of #%paramz
+       and misused it.
+       Printing an error message requires consulting parameters,
+       so just escape. */
+    scheme_longjmp(scheme_error_buf, 1);
+  }
+
+  return (Scheme_Config *)v;
 }
 
 static Scheme_Config *do_extend_config(Scheme_Config *c, Scheme_Object *key, Scheme_Object *cell)

src/mzscheme/src/type.c

@@ -355,12 +355,10 @@ static void FIXUP_cjs(Scheme_Continuation_Jump_State *cjs)
 
 static void MARK_stack_state(Scheme_Stack_State *ss)
 {
-  gcMARK(ss->barrier_prompt);
 }
 
 static void FIXUP_stack_state(Scheme_Stack_State *ss)
 {
-  gcFIXUP(ss->barrier_prompt);
 }
 
 static void MARK_jmpup(Scheme_Jumpup_Buf *buf)