301.7

svn: r2304

collects/compiler/mzc.h

@@ -45,10 +45,10 @@ static MZC_INLINE Scheme_Object *MZC_GLOBAL_ASSIGN(Scheme_Object *vec, int pos,
     (DO_FUEL_POLL, _scheme_direct_apply_primitive_multi(prim, argc, argv))
 #define _scheme_direct_apply_primitive_poll(prim, argc, argv) \
     (DO_FUEL_POLL, _scheme_direct_apply_primitive(prim, argc, argv))
-#define _scheme_direct_apply_closed_primitive_multi_poll(prim, argc, argv) \
+#define _scheme_direct_apply_primitive_closure_multi_poll(prim, argc, argv) \
-    (DO_FUEL_POLL, _scheme_direct_apply_closed_primitive_multi(prim, argc, argv))
+    (DO_FUEL_POLL, _scheme_direct_apply_primitive_closure_multi(prim, argc, argv))
-#define _scheme_direct_apply_closed_primitive_poll(prim, argc, argv) \
+#define _scheme_direct_apply_primitive_closure_poll(prim, argc, argv) \
-    (DO_FUEL_POLL, _scheme_direct_apply_closed_primitive(prim, argc, argv))
+    (DO_FUEL_POLL, _scheme_direct_apply_primitive_closure(prim, argc, argv))
 
 #ifdef KEEP_CLOSURE_COUNT
 static int closure_alloc_cnt;
@@ -67,31 +67,39 @@ static void closure_alloc_inc()
 # define CLOSURE_ALLOC_PP /**/
 #endif
 
+typedef struct {
+  Scheme_Primitive_Proc prim;
 #ifdef MZ_PRECISE_GC
+  int count;
+#endif
+} Scheme_Primitive_Closure_Post;
+
 # define MZC_INSTALL_DATA_PTR(rec) rec
-# define MZC_PARAM_TO_SWITCH(void_param) *(unsigned int *)((Scheme_Closed_Primitive_Post_Ext_Proc *)void_param)->a
+# define MZC_PARAM_TO_SWITCH(void_param) *(unsigned long *)(((Scheme_Primitive_Closure *)void_param)->val)
 # define MZC_ENV_POINTER(t, ct, void_param) (&(((const ct *)void_param)->data))
+
+
+#ifdef SIXTY_FOUR_BIT_INTEGERS
+# define MZ_LOG_WORD_SIZE 4
 #else
-# define MZC_INSTALL_DATA_PTR(rec) &rec->data
+# define MZ_LOG_WORD_SIZE 2
-# define MZC_PARAM_TO_SWITCH(void_param) *(unsigned int*)void_param
-# define MZC_ENV_POINTER(t, ct, void_param) ((const t *)void_param)
 #endif
 
 #define _scheme_make_c_proc_closure(cfunc, rec, name, amin, amax, flags) \
-  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure_post(&rec->prim, cfunc, MZC_INSTALL_DATA_PTR(rec), \
+  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure_post(((Scheme_Primitive_Closure *)&rec->prim), cfunc, \
 								    name, amin, amax, flags, \
-                                                                    sizeof(rec->data)>>2))
+                                                                    sizeof(rec->data)>>MZ_LOG_WORD_SIZE))
 
 #define _scheme_make_c_proc_closure_empty(cfunc, rec, name, amin, amax, flags) \
-  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure(&rec->prim, cfunc, NULL, name, amin, amax, flags))
+  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure(&rec->prim, cfunc, name, amin, amax, flags))
 
 #define _scheme_make_c_case_proc_closure(cfunc, rec, name, ccnt, cses, flags) \
-  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure_post(&rec->prim, cfunc, MZC_INSTALL_DATA_PTR(rec), \
+  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure_post(((Scheme_Primitive_Closure *)&rec->prim), cfunc, \
 									 name, ccnt, cses, flags, \
-                                                                         sizeof(rec->data)>>2))
+                                                                         sizeof(rec->data)>>MZ_LOG_WORD_SIZE))
 
 #define _scheme_make_c_case_proc_closure_empty(cfunc, rec, name, ccnt, cses, flags) \
-  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure(&rec->prim, cfunc, NULL, name, ccnt, cses, flags))
+  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure(&rec->prim, cfunc, name, ccnt, cses, flags))
 
 #define NO_MULTIPLE_VALUES(res) \
 	if (res == SCHEME_MULTIPLE_VALUES) \
@@ -118,8 +126,8 @@ typedef struct {
   Scheme_Object *val;
 } _Scheme_WCM_Rec;
 
-#define _scheme_apply_ckp(f, argc, argv) (SCHEME_CLSD_PRIMP(f) ? _scheme_apply_closed_prim(f, argc, argv) : _scheme_apply(f, argc, argv))
+#define _scheme_apply_ckp(f, argc, argv) (SCHEME_CLSD_PRIMP(f) ? _scheme_apply_prim_closure(f, argc, argv) : _scheme_apply(f, argc, argv))
-#define _scheme_apply_multi_ckp(f, argc, argv) (SCHEME_CLSD_PRIMP(f) ? _scheme_apply_closed_prim_multi(f, argc, argv) : _scheme_apply_multi(f, argc, argv))
+#define _scheme_apply_multi_ckp(f, argc, argv) (SCHEME_CLSD_PRIMP(f) ? _scheme_apply_prim_closure_multi(f, argc, argv) : _scheme_apply_multi(f, argc, argv))
 
 #define MZC_EQP(ltp, av, bv) (SAME_OBJ(av, bv))
 #define MZC_EQVP(ltp, av, bv) (SAME_OBJ(av, bv) || scheme_eqv(av, bv))
@@ -291,10 +299,10 @@ static MSC_IZE(inline) Scheme_Object *mzc_force_value(Scheme_Object *v)
   return _scheme_force_value(v);
 }
 
-#define _scheme_direct_apply_closed_primitive_multi_fv(prim, argc, argv) \
+#define _scheme_direct_apply_primitive_closure_multi_fv(prim, argc, argv) \
-    mzc_force_value(_scheme_direct_apply_closed_primitive_multi(prim, argc, argv))
+    mzc_force_value(_scheme_direct_apply_primitive_closure_multi(prim, argc, argv))
-#define _scheme_direct_apply_closed_primitive_fv(prim, argc, argv) \
+#define _scheme_direct_apply_primitive_closure_fv(prim, argc, argv) \
-    scheme_check_one_value(_scheme_direct_apply_closed_primitive_multi_fv(prim, argc, argv))
+    scheme_check_one_value(_scheme_direct_apply_primitive_closure_multi_fv(prim, argc, argv))
 
 static int mzc_strlen(const char *c) {
   int l;
@@ -329,14 +337,14 @@ _mzc_direct_apply_primitive(Scheme_Object *prim, int argc, Scheme_Object **argv)
   return _scheme_direct_apply_primitive(prim, argc, argv);
 }
 static MZC_INLINE Scheme_Object *
-_mzc_direct_apply_closed_primitive_multi(Scheme_Object *prim, int argc, Scheme_Object **argv)
+_mzc_direct_apply_primitive_closure_multi(Scheme_Object *prim, int argc, Scheme_Object **argv)
 {
-  return _scheme_direct_apply_closed_primitive_multi(prim, argc, argv);
+  return _scheme_direct_apply_primitive_closure_multi(prim, argc, argv);
 }
 static MZC_INLINE Scheme_Object *
-_mzc_direct_apply_closed_primitive(Scheme_Object *prim, int argc, Scheme_Object **argv)
+_mzc_direct_apply_primitive_closure(Scheme_Object *prim, int argc, Scheme_Object **argv)
 {
-  return _scheme_direct_apply_closed_primitive(prim, argc, argv);
+  return _scheme_direct_apply_primitive_closure(prim, argc, argv);
 }
 END_XFORM_SUSPEND;
 #else
@@ -344,13 +352,15 @@ END_XFORM_SUSPEND;
          _scheme_direct_apply_primitive_multi(prim, argc, argv)
 # define _mzc_direct_apply_primitive(prim, argc, argv) \
          _scheme_direct_apply_primitive(prim, argc, argv)
-# define _mzc_direct_apply_closed_primitive_multi(prim, argc, argv) \
+# define _mzc_direct_apply_primitive_closure_multi(prim, argc, argv) \
-         _scheme_direct_apply_closed_primitive_multi(prim, argc, argv)
+         _scheme_direct_apply_primitive_closure_multi(prim, argc, argv)
-# define _mzc_direct_apply_closed_primitive(prim, argc, argv) \
+# define _mzc_direct_apply_primitive_closure(prim, argc, argv) \
-         _scheme_direct_apply_closed_primitive(prim, argc, argv)
+         _scheme_direct_apply_primitive_closure(prim, argc, argv)
 #endif
 
 #define _mzc_apply(r,n,rs) _scheme_apply(r,n,rs)
 #define _mzc_apply_multi(r,n,rs) _scheme_apply_multi(r,n,rs)
-#define _mzc_apply_known_closed_prim(r,n,rs) _scheme_apply_known_closed_prim(r,n,rs)
+#define _mzc_apply_known_prim_closure(r,n,rs) _scheme_apply_known_prim_closure(r,n,rs)
-#define _mzc_apply_known_closed_prim_multi(r,n,rs) _scheme_apply_known_closed_prim_multi(r,n,rs)
+#define _mzc_apply_known_prim_closure_multi(r,n,rs) _scheme_apply_known_prim_closure_multi(r,n,rs)
+
+#define MZC_PRIM_CLS_DATA(prim) (prim)

collects/compiler/private/vm2c.ss

@@ -417,7 +417,7 @@
 		     number
 		     (cond
 		      [(procedure-vehicle? v)
-		       "void * void_param, int argc, Scheme_Object *argv[]"]
+		       "int argc, Scheme_Object *argv[], Scheme_Object *void_param"]
 		      [else
 		       (compiler:internal-error
 			#f
@@ -494,10 +494,10 @@
 				[(scheme-bucket) "Scheme_Bucket *"]
 				[(scheme-per-load-static) "struct Scheme_Per_Load_Statics *"]
 				[(label) "int"]
-				[(prim) "Scheme_Closed_Primitive_Post_Proc"]
+				[(prim) "Scheme_Primitive_Closure_Post"]
-				[(prim-empty) "Scheme_Closed_Primitive_Proc"]
+				[(prim-empty) "Scheme_Primitive_Proc"]
-				[(prim-case) "Scheme_Closed_Case_Primitive_Post_Proc"]
+				[(prim-case) "Scheme_Primitive_Closure_Post"]
-				[(prim-case-empty) "Scheme_Closed_Case_Primitive_Proc"]
+				[(prim-case-empty) "Scheme_Primitive_Proc"]
 				[(begin0-saver) "_Scheme_Begin0_Rec"]
 				[(wcm-saver) "_Scheme_WCM_Rec"]
 				[else (compiler:internal-error 
@@ -1331,12 +1331,12 @@
 		(let ([c (vm:tail-apply-argc ast)])
 		  (emit ", ~a, ~a, scheme_current_thread)" c (if (zero? c) "NULL" 'tail_buf)))]
 	       
-	       ;; (tail-call <label> <closure>) -> void_param = SCHEME_CLSD_PRIM_DATA(<closure>);
+	       ;; (tail-call <label> <closure>) -> void_param = MZC_PRIM_CLS_DATA(<closure>);
 	       ;;                                  goto LOC<label>;
 	       [(vm:tail-call? ast)
 		(when (vm:tail-call-set-env? ast)
 		  (emit-indentation)
-		  (emit "void_param = SCHEME_CLSD_PRIM_DATA(")
+		  (emit "void_param = MZC_PRIM_CLS_DATA(")
 		  (process (vm:tail-call-closure ast) indent-level #f #t)
 		  (emit ");~n"))
 		;; be nice to threads & user breaks:
@@ -1400,8 +1400,8 @@
 			       (not (memq (object-name v) (internal-tail-chain-prims))))
 			  (if (or (vm:apply-multi? ast)
 				  (primitive-result-arity v))
-			      "direct_apply_closed_primitive_multi"
+			      "direct_apply_primitive_closure_multi"
-			      "direct_apply_closed_primitive")]
+			      "direct_apply_primitive_closure")]
 			 [(and (primitive? v)
 			       (not (memq (object-name v) (internal-tail-chain-prims))))
 			  (if (or (vm:apply-multi? ast)
@@ -1411,13 +1411,13 @@
 			 [(vm:apply-known? ast) 
 			  (if (vm:apply-multi? ast)
 			      (if (compiler:option:disable-interrupts)
-				  "direct_apply_closed_primitive_multi_fv"
+				  "direct_apply_primitive_closure_multi_fv"
-				  "apply_known_closed_prim_multi")
+				  "apply_known_prim_closure_multi")
 			      (if (compiler:option:disable-interrupts)
 				  (if (compiler:option:unsafe)
-				      "direct_apply_closed_primitive_multi_fv"
+				      "direct_apply_primitive_closure_multi_fv"
-				      "direct_apply_closed_primitive_fv")
+				      "direct_apply_primitive_closure_fv")
-				  "apply_known_closed_prim"))]
+				  "apply_known_prim_closure"))]
 			 [(vm:apply-multi? ast) "apply_multi"]
 			 [else "apply"])))
 		(process (vm:apply-closure ast) indent-level #f #t)
@@ -1438,7 +1438,7 @@
 		  (emit ", ~a)" top_level_n))]
 	       
 	       [(vm:call? ast)
-		(emit-expr "_scheme_force_value(compiled(SCHEME_CLSD_PRIM_DATA(")
+		(emit-expr "_scheme_force_value(compiled(MZC_PRIM_CLS_DATA(")
 		(process (vm:call-closure ast) indent-level #f #t)
 		(emit "), 0, arg))")]
 

collects/tests/mzscheme/contmark.ss

@@ -154,51 +154,92 @@
 		 v)
 	       'x))))
 
-;; full continuation, mark replaced
+;; continuation, mark replaced
-(wcm-test '(11 10)
+(let* ([extract
-	  (lambda ()
+	(lambda (k)
-	    (let ([k (with-continuation-mark 'x 10
+	  (continuation-mark-set->list 
-		       (begin0
+	   (continuation-marks k)
-			(with-continuation-mark 'x 11
+	   'x))]
-			  (let/cc k 
+       [go
-			    (with-continuation-mark 'x 12
+	(lambda (call/xc in?)
-			      k)))
+	  (wcm-test '(11 10)
-			(+ 2 3)))])
+		    (lambda ()
-	      (continuation-mark-set->list 
+		      (let ([k (with-continuation-mark 'x 10
-	       (continuation-marks k)
+				 (begin0
-	       'x))))
+				  (with-continuation-mark 'x 11
+				    (call/xc 
+				     (lambda (k )
+				       (with-continuation-mark 'x 12
+					 (if in?
+					     (extract k)
+					     k)))))
+				  (+ 2 3)))])
+			(if in?
+			    k
+			    (extract k))))))])
+  (go call/cc #t)
+  (go call/cc #f)
+  (go call/ec #t))
 
-;; nested full continuation, mark replaced
+;; nested continuation, mark replaced
-(wcm-test '(12 10)
+(let* ([extract
-	  (lambda ()
+	(lambda (k)
-	    (let ([k (with-continuation-mark 'x 10
+	  (continuation-mark-set->list 
-		       (begin0
+	   (continuation-marks k)
-			(with-continuation-mark 'x 11
+	   'x))]
-			  (let/cc k0
+       [go
-			    (with-continuation-mark 'x 12
+	(lambda (call/xc in?)
-			      (let/cc k 
+	  (wcm-test '(12 10)
-				k))))
+		    (lambda ()
-			(+ 2 3)))])
+		      (let ([k (with-continuation-mark 'x 10
-	      (continuation-mark-set->list 
+				 (begin0
-	       (continuation-marks k)
+				  (with-continuation-mark 'x 11
-	       'x))))
+				    (call/xc
+				     (lambda (k0)
+				       (with-continuation-mark 'x 12
+					 (call/xc 
+					  (lambda (k) 
+					    (if in?
+						(extract k)
+						k)))))))
+				  (+ 2 3)))])
+			(if in?
+			    k
+			    (extract k))))))])
+  (go call/cc #t)
+  (go call/cc #f)
+  (go call/ec #t))
 
-;; nested full continuation, mark shared
+;; nested continuation, mark shared
-(wcm-test '(12 11 10)
+(let* ([extract
-	  (lambda ()
+	(lambda (k)
-	    (let ([k (with-continuation-mark 'x 10
+	  (continuation-mark-set->list 
-		       (begin0
+	   (continuation-marks k)
-			(with-continuation-mark 'x 11
+	   'x))]
-			  (let/cc k0
+       [go
-			    (begin0
+	(lambda (call/xc in?)
-			     (with-continuation-mark 'x 12
+	  (wcm-test '(12 11 10)
-			       (let/cc k 
+		    (lambda ()
-				 k))
+		      (let ([k (with-continuation-mark 'x 10
-			     (cons 4 5))))
+				 (begin0
-			(cons 2 3)))])
+				  (with-continuation-mark 'x 11
-	      (continuation-mark-set->list 
+				    (call/xc 
-	       (continuation-marks k)
+				     (lambda (k0)
-	       'x))))
+				       (begin0
+					(with-continuation-mark 'x 12
+					  (call/xc 
+					   (lambda (k)
+					     (if in?
+						 (extract k)
+						 k))))
+					(cons 4 5)))))
+				  (cons 2 3)))])
+			(if in?
+			    k
+			    (extract k))))))])
+  (go call/cc #t)
+  (go call/cc #f)
+  (go call/ec #t))
 
 ;; escape continuation, same thread
 (wcm-test '(11 10)

notes/mzscheme/HISTORY

@@ -1,4 +1,17 @@
 
+Version 301.7
+Inside MzScheme: added scheme_make_prim_closure_w_arity(), etc.
+
+Version 301.6
+The body of `let/cc' and the procedure passed to `call/ec' are
+ evaluated/called as a tail expression/call
+Added struct-type-make-constructor and struct-type-make-predicate
+Added JIT support for 3m
+
+Version 301.5
+For nested captured continuations, the shared continuation tail is
+ represented by shared data
+
 Version 301.4
 Added just-in-time native-code compiler with a new eval-jit-enabled
  parameter

src/configure

@@ -8291,14 +8291,6 @@ fi
 
 fi
 
-   if test "${no_x}" = "yes" ; then
-     echo "******************************************************"
-     echo "configure: cannot find X11 headers and/or libraries,"
-     echo "           which are needed to compile MrEd"
-     echo "******************************************************"
-     echo configure aborted
-     exit 1
-   fi
   fi
 
   MAKE_MRED=mr

src/mzscheme/configure.ac

@@ -304,14 +304,6 @@ if test "${enable_mred}" = "yes" ; then
    :
   else
    AC_PATH_XTRA
-   if test "${no_x}" = "yes" ; then
-     echo "******************************************************"
-     echo "configure: cannot find X11 headers and/or libraries,"
-     echo "           which are needed to compile MrEd"
-     echo "******************************************************"
-     echo configure aborted
-     exit 1
-   fi
   fi
 
   MAKE_MRED=mr

src/mzscheme/include/mzscheme.exp

@@ -116,10 +116,10 @@ scheme_apply_to_list
 scheme_eval_string
 scheme_eval_string_multi
 scheme_eval_string_all
-_scheme_apply_known_closed_prim
+_scheme_apply_known_prim_closure
-_scheme_apply_known_closed_prim_multi
+_scheme_apply_known_prim_closure_multi
-_scheme_apply_closed_prim
+_scheme_apply_prim_closure
-_scheme_apply_closed_prim_multi
+_scheme_apply_prim_closure_multi
 scheme_values
 scheme_check_one_value
 scheme_tail_apply
@@ -181,14 +181,16 @@ scheme_is_hash_table_equal
 scheme_clone_hash_table
 scheme_make_prim
 scheme_make_noneternal_prim
-scheme_make_closed_prim
 scheme_make_prim_w_arity
 scheme_make_folding_prim
 scheme_make_noncm_prim
 scheme_make_noneternal_prim_w_arity
+scheme_make_prim_w_everything
+scheme_make_prim_closure_w_arity
+scheme_make_folding_prim_closure
+scheme_make_closed_prim
 scheme_make_closed_prim_w_arity
 scheme_make_folding_closed_prim
-scheme_make_prim_w_everything
 scheme_make_closed_prim_w_everything
 scheme_prim_is_method
 scheme_make_pair

src/mzscheme/include/mzscheme3m.exp

@@ -116,10 +116,10 @@ scheme_apply_to_list
 scheme_eval_string
 scheme_eval_string_multi
 scheme_eval_string_all
-_scheme_apply_known_closed_prim
+_scheme_apply_known_prim_closure
-_scheme_apply_known_closed_prim_multi
+_scheme_apply_known_prim_closure_multi
-_scheme_apply_closed_prim
+_scheme_apply_prim_closure
-_scheme_apply_closed_prim_multi
+_scheme_apply_prim_closure_multi
 scheme_values
 scheme_check_one_value
 scheme_tail_apply
@@ -188,14 +188,16 @@ scheme_is_hash_table_equal
 scheme_clone_hash_table
 scheme_make_prim
 scheme_make_noneternal_prim
-scheme_make_closed_prim
 scheme_make_prim_w_arity
 scheme_make_folding_prim
 scheme_make_noncm_prim
 scheme_make_noneternal_prim_w_arity
+scheme_make_prim_w_everything
+scheme_make_prim_closure_w_arity
+scheme_make_folding_prim_closure
+scheme_make_closed_prim
 scheme_make_closed_prim_w_arity
 scheme_make_folding_closed_prim
-scheme_make_prim_w_everything
 scheme_make_closed_prim_w_everything
 scheme_prim_is_method
 scheme_make_pair

src/mzscheme/include/mzwin.def

@@ -173,14 +173,16 @@ EXPORTS
  scheme_clone_hash_table
  scheme_make_prim
  scheme_make_noneternal_prim
- scheme_make_closed_prim
  scheme_make_prim_w_arity
  scheme_make_folding_prim
  scheme_make_noncm_prim
  scheme_make_noneternal_prim_w_arity
+ scheme_make_prim_w_everything
+ scheme_make_prim_closure_w_arity
+ scheme_make_folding_prim_closure
+ scheme_make_closed_prim
  scheme_make_closed_prim_w_arity
  scheme_make_folding_closed_prim
- scheme_make_prim_w_everything
  scheme_make_closed_prim_w_everything
  scheme_prim_is_method
  scheme_make_pair

src/mzscheme/include/scheme.h

@@ -193,10 +193,6 @@ extern "C"
 
 typedef short Scheme_Type;
 
-/* Used to use `short' for app arg counts, etc., but adding limit
-   checks is difficult, and seems arbitrary. We can switch back
-   to short if the expense turns out to be noticable; in that case
-   also define MZSHORT_IS_SHORT. */
 typedef int mzshort;
 
 typedef unsigned int mzchar;
@@ -577,17 +573,17 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
 #define SCHEME_PRIM_IS_BINARY_INLINED 512
 #define SCHEME_PRIM_IS_USER_PARAMETER 1024
 #define SCHEME_PRIM_IS_METHOD 2048
-#define SCHEME_PRIM_IS_POST_DATA 4096
+#define SCHEME_PRIM_IS_CLOSURE 4096
 #define SCHEME_PRIM_IS_NONCM 8192
 #define SCHEME_PRIM_IS_UNARY_INLINED 16384
 
 #define SCHEME_PRIM_PROC_FLAGS(x) (((Scheme_Prim_Proc_Header *)x)->flags)
 
-typedef struct Scheme_Object *
+typedef struct Scheme_Object *(Scheme_Prim)(int argc, Scheme_Object *argv[]);
-(Scheme_Prim)(int argc, struct Scheme_Object *argv[]);
 
-typedef struct Scheme_Object *
+typedef struct Scheme_Object *(Scheme_Primitive_Closure_Proc)(int argc, struct Scheme_Object *argv[], Scheme_Object *p);
-(Scheme_Closed_Prim)(void *d, int argc, struct Scheme_Object *argv[]);
+
+#define SCHEME_MAX_ARGS 0x3FFFFFFE
 
 typedef struct {
   Scheme_Object so;
@@ -596,16 +592,40 @@ typedef struct {
 
 typedef struct {
   Scheme_Prim_Proc_Header pp;
-  Scheme_Prim *prim_val;
+  Scheme_Primitive_Closure_Proc *prim_val;
   const char *name;
-  mzshort mina, maxa;
+  mzshort mina;
+  /* If mina < 0; mina is negated case count minus one for a case-lambda
+     generated by mzc, where the primitive checks argument arity
+     itself, and mu.cases is available instead of mu.maxa. */
+  union {
+    mzshort *cases;
+    mzshort maxa;   /* > SCHEME_MAX_ARGS => any number of arguments */
+  } mu;
 } Scheme_Primitive_Proc;
 
 typedef struct {
   Scheme_Primitive_Proc pp;
   mzshort minr, maxr;
+  /* Never combined with a closure */
 } Scheme_Prim_W_Result_Arity;
 
+typedef struct Scheme_Primitive_Closure {
+  Scheme_Primitive_Proc p;
+  /* The rest is here only if SCHEME_PRIM_IS_CLOSURE
+     is set in p.pp.flags. */
+#ifdef MZ_PRECISE_GC
+  mzshort count;
+#endif
+  Scheme_Object *val[1];
+} Scheme_Primitive_Closure;
+
+#define SCHEME_PRIM_CLOSURE_ELS(p) ((Scheme_Primitive_Closure *)p)->val
+
+/* ------ Old-style primitive closures ------- */
+
+typedef struct Scheme_Object *(Scheme_Closed_Prim)(void *d, int argc, struct Scheme_Object *argv[]);
+
 typedef struct {
   Scheme_Prim_Proc_Header pp;
   Scheme_Closed_Prim *prim_val;
@@ -627,88 +647,45 @@ typedef struct {
 
 /* ------------------------------------------------- */
 /*                 mzc closure glue
-    The following structures are used by mzc to implement closures
+    The following are used by mzc to implement closures.
-    where the closure data is allocated as part of the
-    Scheme_Closed_Primitive_Proc record.  In 3m mode, a length must be
-    included, and all of the closur-data elements are assumed to be
-    pointers. Furthermore, in 3m mode, a cases and non-cases closure
-    must have closure data starting at the same point, since two
-    kinds can flow to the same MZC_PARAM_TO_SWITCH().
 */
 
-typedef struct {
+#define _scheme_fill_prim_closure(rec, cfunc, nm, amin, amax, flgs) \
-  union {
+  ((rec)->pp.so.type = scheme_prim_type, \
-    Scheme_Closed_Primitive_Proc p;
-#ifdef MZ_PRECISE_GC
-    Scheme_Closed_Case_Primitive_Proc other;
-#endif
-  } u;
-#ifdef MZ_PRECISE_GC
-  mzshort len;
-#endif
-} Scheme_Closed_Primitive_Post_Proc;
-
-typedef struct {
-  Scheme_Closed_Primitive_Post_Proc p;
-  void *a[1];
-} Scheme_Closed_Primitive_Post_Ext_Proc;
-
-typedef struct {
-  union {
-    Scheme_Closed_Case_Primitive_Proc p;
-#ifdef MZ_PRECISE_GC
-    Scheme_Closed_Primitive_Proc other;
-#endif
-  } u;
-#ifdef MZ_PRECISE_GC
-  mzshort len;
-#endif
-} Scheme_Closed_Case_Primitive_Post_Proc;
-
-typedef struct {
-  Scheme_Closed_Case_Primitive_Post_Proc p;
-  void *a[1];
-} Scheme_Closed_Case_Primitive_Post_Ext_Proc;
-
-#define _scheme_fill_prim_closure(rec, cfunc, dt, nm, amin, amax, flgs) \
-  ((rec)->pp.so.type = scheme_closed_prim_type, \
    (rec)->prim_val = cfunc, \
-   (rec)->data = (void *)(dt), \
    (rec)->name = nm, \
-   (rec)->mina = amin, \
+   (rec)->mina = amin,	  \
-   (rec)->maxa = amax, \
+   (rec)->mu.maxa = (amax == -1 ? SCHEME_MAX_ARGS + 1 : amax), \
    (rec)->pp.flags = flgs, \
    rec)
 
 #ifdef MZ_PRECISE_GC
-# define _scheme_fill_prim_closure_post(rec, cfunc, dt, nm, amin, amax, flgs, ln) \
+# define _scheme_fill_prim_closure_post(rec, cfunc, nm, amin, amax, flgs, ln) \
-  ((rec)->len = ln,							\
+  ((rec)->count = ln,							\
-   _scheme_fill_prim_closure(&(rec)->u.p, cfunc, dt, nm, amin, amax,	\
+   _scheme_fill_prim_closure(&(rec)->p, cfunc, nm, amin, amax,	\
-			     flgs | SCHEME_PRIM_IS_POST_DATA))
+			     flgs | SCHEME_PRIM_IS_CLOSURE))
 #else
-# define _scheme_fill_prim_closure_post(rec, cfunc, dt, nm, amin, amax, flgs, ln) \
+# define _scheme_fill_prim_closure_post(rec, cfunc, nm, amin, amax, flgs, ln) \
-  _scheme_fill_prim_closure(&(rec)->u.p, cfunc, dt, nm, amin, amax, flgs)
+  _scheme_fill_prim_closure(&(rec)->p, cfunc, nm, amin, amax, flgs)
 #endif
 
-#define _scheme_fill_prim_case_closure(rec, cfunc, dt, nm, ccount, cses, flgs) \
+#define _scheme_fill_prim_case_closure(rec, cfunc, nm, ccount, cses, flgs) \
-  ((rec)->p.pp.so.type = scheme_closed_prim_type, \
+  ((rec)->pp.so.type = scheme_prim_type, \
-   (rec)->p.prim_val = cfunc, \
+   (rec)->prim_val = cfunc, \
-   (rec)->p.data = (void *)(dt), \
+   (rec)->name = nm, \
-   (rec)->p.name = nm, \
+   (rec)->mina = -(ccount+1), \
-   (rec)->p.mina = -2, \
+   (rec)->pp.flags = flgs, \
-   (rec)->p.maxa = -(ccount), \
+   (rec)->mu.cases = cses, \
-   (rec)->p.pp.flags = flgs, \
-   (rec)->cases = cses, \
    rec)
 
 #ifdef MZ_PRECISE_GC
-# define _scheme_fill_prim_case_closure_post(rec, cfunc, dt, nm, ccount, cses, flgs, ln) \
+# define _scheme_fill_prim_case_closure_post(rec, cfunc, nm, ccount, cses, flgs, ln) \
-  ((rec)->len = ln,							\
+  ((rec)->count = ln,							\
-   _scheme_fill_prim_case_closure(&(rec)->u.p, cfunc, dt, nm, ccount, cses, \
+   _scheme_fill_prim_case_closure(&((rec)->p), cfunc, nm, ccount, cses,	\
-				  flgs | SCHEME_PRIM_IS_POST_DATA))
+				  flgs | SCHEME_PRIM_IS_CLOSURE))
 #else
-# define _scheme_fill_prim_case_closure_post(rec, cfunc, dt, nm, ccount, cses, flgs, ln) \
+# define _scheme_fill_prim_case_closure_post(rec, cfunc, nm, ccount, cses, flgs, ln) \
-  _scheme_fill_prim_case_closure(&(rec)->u.p, cfunc, dt, nm, ccount, cses, flgs)
+  _scheme_fill_prim_case_closure(&((rec)->p), cfunc, nm, ccount, cses, flgs)
 #endif
 
 /* ------------------------------------------------- */
@@ -721,7 +698,7 @@ typedef struct {
 #define SCHEME_ECONTP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_escaping_cont_type)
 #define SCHEME_CONT_MARK_SETP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_cont_mark_set_type)
 #define SCHEME_PROC_STRUCTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type)
-#define SCHEME_STRUCT_PROCP(obj) (SCHEME_CLSD_PRIMP(obj) && (((Scheme_Closed_Primitive_Proc *)(obj))->pp.flags & SCHEME_PRIM_IS_STRUCT_PROC))
+#define SCHEME_STRUCT_PROCP(obj) (SCHEME_PRIMP(obj) && (((Scheme_Primitive_Proc *)(obj))->pp.flags & SCHEME_PRIM_IS_STRUCT_PROC))
 #define SCHEME_CLOSUREP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_closure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_case_closure_type))
 
 #define SCHEME_PRIM(obj)     (((Scheme_Primitive_Proc *)(obj))->prim_val)
@@ -1322,9 +1299,13 @@ typedef void (*Scheme_Invoke_Proc)(Scheme_Env *env, long phase_shift,
 #define _scheme_tail_eval_wp scheme_tail_eval_wp
 
 #define _scheme_direct_apply_primitive_multi(prim, argc, argv) \
-    (((Scheme_Primitive_Proc *)prim)->prim_val(argc, argv))
+  (((Scheme_Primitive_Proc *)prim)->prim_val(argc, argv, prim))
 #define _scheme_direct_apply_primitive(prim, argc, argv) \
-    scheme_check_one_value(_scheme_direct_apply_primitive_multi(prim, argc, argv))
+  scheme_check_one_value(_scheme_direct_apply_primitive_multi(prim, argc, argv))
+#define _scheme_direct_apply_primitive_closure_multi(prim, argc, argv) \
+  _scheme_direct_apply_primitive_multi(prim, argc, argv)
+#define _scheme_direct_apply_primitive_closure(prim, argc, argv) \
+  _scheme_direct_apply_primitive(prim, argc, argv)
 #define _scheme_direct_apply_closed_primitive_multi(prim, argc, argv) \
     (((Scheme_Closed_Primitive_Proc *)prim)->prim_val(((Scheme_Closed_Primitive_Proc *)prim)->data, argc, argv))
 #define _scheme_direct_apply_closed_primitive(prim, argc, argv) \

src/mzscheme/src/error.c

@@ -988,6 +988,9 @@ void scheme_wrong_count_m(const char *name, int minc, int maxc,
   if (!argc || !minc)
     is_method = 0;
 
+  if (maxc > SCHEME_MAX_ARGS)
+    maxc = -1;
+
   s = make_arity_expect_string(name, -1, minc, maxc, argc, argv, &len, is_method);
 
   scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, "%t", s, len);
@@ -1028,7 +1031,15 @@ char *scheme_make_arity_expect_string(Scheme_Object *proc,
   if (SCHEME_PRIMP(proc)) {
     name = ((Scheme_Primitive_Proc *)proc)->name;
     mina = ((Scheme_Primitive_Proc *)proc)->mina;
-    maxa = ((Scheme_Primitive_Proc *)proc)->maxa;
+    if (mina < 0) {
+      /* set min1 to -2 to indicates cases */
+      mina = -2;
+      maxa = 0;
+    } else {
+      maxa = ((Scheme_Primitive_Proc *)proc)->mu.maxa;
+      if (maxa > SCHEME_MAX_ARGS)
+	maxa = -1;
+    }
   } else if (SCHEME_CLSD_PRIMP(proc)) {
     name = ((Scheme_Closed_Primitive_Proc *)proc)->name;
     mina = ((Scheme_Closed_Primitive_Proc *)proc)->mina;

src/mzscheme/src/eval.c

@@ -3647,9 +3647,9 @@ static Scheme_Object *do_apply_known_k(void)
 
   p->ku.k.p2 = NULL;
 
-  return _scheme_apply_known_closed_prim_multi((Scheme_Object *)p->ku.k.p1, 
+  return _scheme_apply_known_prim_closure_multi((Scheme_Object *)p->ku.k.p1, 
-					       p->ku.k.i1, 
+						p->ku.k.i1, 
-					       argv);
+						argv);
 }
 
 #if 0
@@ -3665,36 +3665,36 @@ static Scheme_Object *do_apply_known_k(void)
 # define DEBUG_CHECK_TYPE(v) /**/
 #endif
 
-Scheme_Object *_scheme_apply_known_closed_prim_multi(Scheme_Object *rator,
+Scheme_Object *_scheme_apply_known_prim_closure_multi(Scheme_Object *rator,
-						     int argc,
+						      int argc,
-						     Scheme_Object **argv)
+						      Scheme_Object **argv)
 {
 #define PRIM_CHECK_ARITY 0
 #define PRIM_CHECK_MULTI 0
 #include "schapp.inc"
 }
 
-Scheme_Object *_scheme_apply_closed_prim_multi(Scheme_Object *rator,
+Scheme_Object *_scheme_apply_prim_closure_multi(Scheme_Object *rator,
-					       int argc,
+						int argc,
-					       Scheme_Object **argv)
+						Scheme_Object **argv)
 {
 #define PRIM_CHECK_ARITY 1
 #define PRIM_CHECK_MULTI 0
 #include "schapp.inc"
 }
 
-Scheme_Object *_scheme_apply_known_closed_prim(Scheme_Object *rator,
+Scheme_Object *_scheme_apply_known_prim_closure(Scheme_Object *rator,
-					       int argc,
+						int argc,
-					       Scheme_Object **argv)
+						Scheme_Object **argv)
 {
 #define PRIM_CHECK_ARITY 0
 #define PRIM_CHECK_MULTI 1
 #include "schapp.inc"
 }
 
-Scheme_Object *_scheme_apply_closed_prim(Scheme_Object *rator,
+Scheme_Object *_scheme_apply_prim_closure(Scheme_Object *rator,
-					 int argc,
+					  int argc,
-					 Scheme_Object **argv)
+					  Scheme_Object **argv)
 {
 #define PRIM_CHECK_ARITY 1
 #define PRIM_CHECK_MULTI 1
@@ -3909,6 +3909,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
 
     if (type == scheme_prim_type) {
       GC_CAN_IGNORE Scheme_Primitive_Proc *prim;
+      GC_CAN_IGNORE Scheme_Primitive_Closure_Proc *f;
       
 #define VACATE_TAIL_BUFFER_USE_RUNSTACK() \
       if (rands == p->tail_buffer) {                                \
@@ -3936,14 +3937,15 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
       prim = (Scheme_Primitive_Proc *)obj;
 
       if (num_rands < prim->mina 
-	  || (num_rands > prim->maxa && prim->maxa >= 0)) {
+	  || (num_rands > prim->mu.maxa && prim->mina >= 0)) {
-	scheme_wrong_count_m(prim->name, prim->mina, prim->maxa,
+	scheme_wrong_count_m(prim->name, prim->mina, prim->mu.maxa,
 			     num_rands, rands,
 			     prim->pp.flags & SCHEME_PRIM_IS_METHOD);
 	return NULL; /* Shouldn't get here */
       }
 
-      v = prim->prim_val(num_rands, rands);
+      f = prim->prim_val;
+      v = f(num_rands, rands, (Scheme_Object *)prim);
 
       DEBUG_CHECK_TYPE(v);
     } else if (type == scheme_closure_type) {
@@ -4128,28 +4130,6 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
       }
 
       goto eval_top;
-    } else if (type == scheme_closed_prim_type) {
-      GC_CAN_IGNORE Scheme_Closed_Primitive_Proc *prim;
-      
-      DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
-
-      VACATE_TAIL_BUFFER_USE_RUNSTACK();
-
-      UPDATE_THREAD_RSPTR();
-
-      prim = (Scheme_Closed_Primitive_Proc *)obj;
-      
-      if (num_rands < prim->mina 
-	  || (num_rands > prim->maxa && prim->maxa >= 0)) {
-	scheme_wrong_count_m(prim->name, prim->mina, prim->maxa, 
-			     num_rands, rands,
-			     prim->pp.flags & SCHEME_PRIM_IS_METHOD);
-	return NULL; /* Shouldn't get here */
-      }
-      
-      v = prim->prim_val(prim->data, num_rands, rands);
-
-      DEBUG_CHECK_TYPE(v);
     } else if (type == scheme_case_closure_type) {
       Scheme_Case_Lambda *seq;
       Scheme_Closure_Data *data;
@@ -4361,6 +4341,28 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
       DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
 
       goto apply_top;
+    } else if (type == scheme_closed_prim_type) {
+      GC_CAN_IGNORE Scheme_Closed_Primitive_Proc *prim;
+      
+      DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
+
+      VACATE_TAIL_BUFFER_USE_RUNSTACK();
+
+      UPDATE_THREAD_RSPTR();
+
+      prim = (Scheme_Closed_Primitive_Proc *)obj;
+      
+      if (num_rands < prim->mina 
+	  || (num_rands > prim->maxa && prim->maxa >= 0)) {
+	scheme_wrong_count_m(prim->name, prim->mina, prim->maxa, 
+			     num_rands, rands,
+			     prim->pp.flags & SCHEME_PRIM_IS_METHOD);
+	return NULL; /* Shouldn't get here */
+      }
+      
+      v = prim->prim_val(prim->data, num_rands, rands);
+
+      DEBUG_CHECK_TYPE(v);
     } else {
       UPDATE_THREAD_RSPTR_FOR_ERROR();
       if (rands == p->tail_buffer)

src/mzscheme/src/fun.c

@@ -436,6 +436,57 @@ scheme_make_void (void)
 /*                          primitive procedures                          */
 /*========================================================================*/
 
+static Scheme_Object *
+make_prim_closure(Scheme_Prim *fun, int eternal,
+		  const char *name,
+		  mzshort mina, mzshort maxa,
+		  int flags,
+		  mzshort minr, mzshort maxr,
+		  int closed, int count, Scheme_Object **vals)
+{
+  Scheme_Primitive_Proc *prim;
+  int hasr, size;
+
+  hasr = ((minr != 1) || (maxr != 1));
+  size = (hasr 
+	  ? sizeof(Scheme_Prim_W_Result_Arity) 
+	  : (closed
+	     ? (sizeof(Scheme_Primitive_Closure)
+		+ ((count - 1) * sizeof(Scheme_Object *)))
+	     : sizeof(Scheme_Primitive_Proc)));
+
+  if (eternal && scheme_starting_up && !closed)
+    prim = (Scheme_Primitive_Proc *)scheme_malloc_eternal_tagged(size);
+  else
+    prim = (Scheme_Primitive_Proc *)scheme_malloc_tagged(size);
+  prim->pp.so.type = scheme_prim_type;
+  prim->prim_val = (Scheme_Primitive_Closure_Proc *)fun;
+  prim->name = name;
+  prim->mina = mina;
+  if (maxa < 0)
+    maxa = SCHEME_MAX_ARGS + 1;
+  prim->mu.maxa = maxa;
+  prim->pp.flags = (flags
+		    | (scheme_defining_primitives ? SCHEME_PRIM_IS_PRIMITIVE : 0)
+		    | (hasr ? SCHEME_PRIM_IS_MULTI_RESULT : 0)
+		    | (closed ? SCHEME_PRIM_IS_CLOSURE : 0));
+
+  if (hasr) {
+    ((Scheme_Prim_W_Result_Arity *)prim)->minr = minr;
+    ((Scheme_Prim_W_Result_Arity *)prim)->maxr = maxr;
+  }
+  if (closed) {
+#ifdef MZ_PRECISE_GC
+    ((Scheme_Primitive_Closure *)prim)->count = count;
+#endif
+    memcpy(((Scheme_Primitive_Closure *)prim)->val,
+	   vals,
+	   count * sizeof(Scheme_Object *));
+  }
+
+  return (Scheme_Object *)prim;
+}
+
 Scheme_Object *
 scheme_make_prim_w_everything(Scheme_Prim *fun, int eternal,
 			      const char *name,
@@ -443,49 +494,33 @@ scheme_make_prim_w_everything(Scheme_Prim *fun, int eternal,
 			      int flags,
 			      mzshort minr, mzshort maxr)
 {
-  Scheme_Primitive_Proc *prim;
+  return make_prim_closure(fun, eternal,
-  int hasr, size;
+			   name,
-
+			   mina, maxa,
-  hasr = ((minr != 1) || (maxr != 1));
+			   flags,
-  size = hasr ? sizeof(Scheme_Prim_W_Result_Arity) : sizeof(Scheme_Primitive_Proc);
+			   minr, maxr,
-
+			   0, 0, NULL);
-  if (eternal && scheme_starting_up)
-    prim = (Scheme_Primitive_Proc *)scheme_malloc_eternal_tagged(size);
-  else
-    prim = (Scheme_Primitive_Proc *)scheme_malloc_tagged(size);
-  prim->pp.so.type = scheme_prim_type;
-  SCHEME_PRIM(prim) = fun;
-  prim->name = name;
-  prim->mina = mina;
-  prim->maxa = maxa;
-  prim->pp.flags = (flags
-		    | (scheme_defining_primitives ? SCHEME_PRIM_IS_PRIMITIVE : 0)
-		    | (hasr ? SCHEME_PRIM_IS_MULTI_RESULT : 0));
-
-  if (hasr) {
-    ((Scheme_Prim_W_Result_Arity *)prim)->minr = minr;
-    ((Scheme_Prim_W_Result_Arity *)prim)->maxr = maxr;
-  }
-
-  return (Scheme_Object *)prim;
 }
 
 Scheme_Object *scheme_make_prim(Scheme_Prim *fun)
 {
-  return scheme_make_prim_w_everything(fun, 1, NULL, 0, -1, 0, 1, 1);
+  return make_prim_closure(fun, 1, NULL, 0, -1, 0, 1, 1,
+			   0, 0, NULL);
 }
 
 Scheme_Object *
 scheme_make_noneternal_prim (Scheme_Prim *fun)
 {
-  return scheme_make_prim_w_everything(fun, 0, NULL, 0, -1, 0, 1, 1);
+  return make_prim_closure(fun, 0, NULL, 0, -1, 0, 1, 1,
+			   0, 0, NULL);
 }
 
 Scheme_Object *
 scheme_make_prim_w_arity(Scheme_Prim *fun, const char *name,
 			 mzshort mina, mzshort maxa)
 {
-  return scheme_make_prim_w_everything(fun, 1, name, mina, maxa, 0, 1, 1);
+  return make_prim_closure(fun, 1, name, mina, maxa, 0, 1, 1,
+			   0, 0, NULL);
 }
 
 Scheme_Object *
@@ -493,12 +528,13 @@ scheme_make_folding_prim(Scheme_Prim *fun, const char *name,
 			 mzshort mina, mzshort maxa,
 			 short folding)
 {
-  return scheme_make_prim_w_everything(fun, 1, name, mina, maxa,
+  return make_prim_closure(fun, 1, name, mina, maxa,
-				       (folding 
+			   (folding 
-					? (SCHEME_PRIM_IS_FOLDING
+			    ? (SCHEME_PRIM_IS_FOLDING
-					   | SCHEME_PRIM_IS_NONCM)
+			       | SCHEME_PRIM_IS_NONCM)
-					: 0),
+			    : 0),
-				       1, 1);
+			   1, 1,
+			   0, 0, NULL);
 }
 
 Scheme_Object *
@@ -506,17 +542,44 @@ scheme_make_noncm_prim(Scheme_Prim *fun, const char *name,
 		       mzshort mina, mzshort maxa)
 {
   /* A non-cm primitive leaves the mark stack unchanged when it returns,
-     and it can't return multiple values. */
+     it can't return multiple values or a tail call, and it cannot
-  return scheme_make_prim_w_everything(fun, 1, name, mina, maxa,
+     use its third argument (i.e., the closure pointer) */
-				       SCHEME_PRIM_IS_NONCM,
+  return make_prim_closure(fun, 1, name, mina, maxa,
-				       1, 1);
+			   SCHEME_PRIM_IS_NONCM,
+			   1, 1,
+			   0, 0, NULL);
 }
 
 Scheme_Object *
 scheme_make_noneternal_prim_w_arity(Scheme_Prim *fun, const char *name,
 				    mzshort mina, mzshort maxa)
 {
-  return scheme_make_prim_w_everything(fun, 0, name, mina, maxa, 0, 1, 1);
+  return make_prim_closure(fun, 0, name, mina, maxa, 0, 1, 1,
+			   0, 0, NULL);
+}
+
+Scheme_Object *scheme_make_prim_closure_w_arity(Scheme_Primitive_Closure_Proc *prim,
+						int size, Scheme_Object **vals,
+						const char *name,
+						mzshort mina, mzshort maxa)
+{
+  return make_prim_closure((Scheme_Prim *)prim, 1, name, mina, maxa, 0, 1, 1,
+			   1, size, vals);
+
+}
+
+Scheme_Object *scheme_make_folding_prim_closure(Scheme_Primitive_Closure_Proc *prim,
+						int size, Scheme_Object **vals,
+						const char *name,
+						mzshort mina, mzshort maxa,
+						short functional)
+{
+  return make_prim_closure((Scheme_Prim *)prim, 1, name, mina, maxa,
+			   (functional
+			    ? SCHEME_PRIM_IS_FOLDING
+			    : 0),
+			   1, 1,
+			   1, size, vals);
 }
 
 Scheme_Object *
@@ -1716,77 +1779,28 @@ Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, long a)
 {
   Scheme_Type type;
   mzshort mina, maxa;
-  int drop = 0;
+  int drop = 0, cases_count = 0;
+  mzshort *cases = NULL;
 
  top:
 
   type = SCHEME_TYPE(p);
   if (type == scheme_prim_type) {
     mina = ((Scheme_Primitive_Proc *)p)->mina;
-    maxa = ((Scheme_Primitive_Proc *)p)->maxa;
+    maxa = ((Scheme_Primitive_Proc *)p)->mu.maxa;
+    if (mina < 0) {
+      cases = ((Scheme_Primitive_Proc *)p)->mu.cases;
+      cases_count = -(mina + 1);
+    } else {
+      if (maxa > SCHEME_MAX_ARGS)
+	maxa = -1;
+    }
   } else if (type == scheme_closed_prim_type) {
     mina = ((Scheme_Closed_Primitive_Proc *)p)->mina;
     maxa = ((Scheme_Closed_Primitive_Proc *)p)->maxa;
-
     if (mina == -2) {
-      mzshort *cases = ((Scheme_Closed_Case_Primitive_Proc *)p)->cases;
+      cases_count = -maxa;
-      int count = -maxa, i;
+      cases = ((Scheme_Closed_Case_Primitive_Proc *)p)->cases;
-
-      if (a == -1) {
-	Scheme_Object *arity, *a, *last = NULL;
-
-	arity = scheme_alloc_list(count);
-
-	for (i = 0, a = arity; i < count; i++) {
-	  Scheme_Object *av;
-	  int mn, mx;
-	  mn = cases[2 * i];
-	  mx = cases[(2 * i) + 1];
-
-	  if (mn >= drop) {
-	    mn -= drop;
-	    if (mx > 0)
-	      mx -= drop;
-
-	    av = scheme_make_arity(mn, mx);
-
-	    SCHEME_CAR(a) = av;
-	    last = a;
-	    a = SCHEME_CDR(a);
-	  }
-	}
-
-	/* If drop > 0, might have found no matches */
-	if (!SCHEME_NULLP(a)) {
-	  if (last)
-	    SCHEME_CDR(last) = scheme_null;
-	  else
-	    arity = scheme_null;
-	}
-
-	return arity;
-      }
-
-      if (a == -2) {
-	for (i = 0; i < count; i++) {
-	  if (cases[(2 * i) + 1] < 0)
-	    return scheme_true;
-	}
-
-	return scheme_false;
-      }
-
-      a += drop;
-
-      for (i = 0; i < count; i++) {
-	int na, xa;
-	na = cases[2 * i];
-	xa = cases[(2 * i) + 1];
-	if ((a >= na) && ((xa < 0) || (a <= xa)))
-	  return scheme_true;
-      }
-
-      return scheme_false;
     }
   } else if (type == scheme_cont_type || type == scheme_escaping_cont_type) {
     mina = 0;
@@ -1953,6 +1967,66 @@ Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, long a)
     }
   }
 
+  if (cases) {
+    int count = cases_count, i;
+
+    if (a == -1) {
+      Scheme_Object *arity, *a, *last = NULL;
+
+      arity = scheme_alloc_list(count);
+
+      for (i = 0, a = arity; i < count; i++) {
+	Scheme_Object *av;
+	int mn, mx;
+	mn = cases[2 * i];
+	mx = cases[(2 * i) + 1];
+
+	if (mn >= drop) {
+	  mn -= drop;
+	  if (mx > 0)
+	    mx -= drop;
+
+	  av = scheme_make_arity(mn, mx);
+
+	  SCHEME_CAR(a) = av;
+	  last = a;
+	  a = SCHEME_CDR(a);
+	}
+      }
+
+      /* If drop > 0, might have found no matches */
+      if (!SCHEME_NULLP(a)) {
+	if (last)
+	  SCHEME_CDR(last) = scheme_null;
+	else
+	  arity = scheme_null;
+      }
+
+      return arity;
+    }
+
+    if (a == -2) {
+      for (i = 0; i < count; i++) {
+	if (cases[(2 * i) + 1] < 0)
+	  return scheme_true;
+      }
+
+      return scheme_false;
+    }
+
+    a += drop;
+
+    for (i = 0; i < count; i++) {
+      int na, xa;
+      na = cases[2 * i];
+      xa = cases[(2 * i) + 1];
+      if ((a >= na) && ((xa < 0) || (a <= xa)))
+	return scheme_true;
+    }
+
+    return scheme_false;
+  }
+
   if (a == -1) {
     if (mina < drop)
       return scheme_null;

src/mzscheme/src/jit.c

@@ -922,7 +922,7 @@ static int generate_direct_prim_tail_call(mz_jit_state *jitter, int num_rands)
     JIT_UPDATE_THREAD_RSPTR();
   }
   jit_movi_i(JIT_R1, num_rands);
-  mz_prepare(2);
+  mz_prepare(2); /* a prim takes 3 args, but a NONCM prim ignores the 3rd */
   CHECK_LIMIT();
   jit_pusharg_p(JIT_RUNSTACK);
   jit_pusharg_i(JIT_R1);
@@ -1042,7 +1042,7 @@ static int generate_direct_prim_non_tail_call(mz_jit_state *jitter, int num_rand
   }
 
   jit_movi_i(JIT_R1, num_rands);
-  mz_prepare(2);
+  mz_prepare(2); /* a prim takes 3 args, but a NONCM prim ignores the 3rd */
   CHECK_LIMIT();
   jit_pusharg_p(JIT_RUNSTACK);
   jit_pusharg_i(JIT_R1);
@@ -1152,14 +1152,15 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc
     jit_ldxi_i(JIT_R0, JIT_V1, &((Scheme_Primitive_Proc *)0x0)->mina);
     ref7 = jit_bnei_i(jit_forward(), JIT_R0, num_rands);
     /* Fast prim application */
-    jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Primitive_Proc *)0x0)->prim_val);
+    jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Primitive_Proc *)0x0)->prim_val);
     if (need_set_rs) {
       JIT_UPDATE_THREAD_RSPTR();
     }
-    mz_prepare(2);
+    mz_prepare(3);
+    jit_pusharg_p(JIT_V1);
     jit_pusharg_p(JIT_RUNSTACK);
     jit_pusharg_i(JIT_R0);
-    (void)mz_finishr(JIT_V1);
+    (void)mz_finishr(JIT_R1);
     CHECK_LIMIT();
     jit_retval(JIT_R0);
     if (!multi_ok) {
@@ -1291,8 +1292,8 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
 
   if (SCHEME_PRIMP(rator)) {
     if ((num_rands >= ((Scheme_Primitive_Proc *)rator)->mina)
-	&& ((num_rands <= ((Scheme_Primitive_Proc *)rator)->maxa)
+	&& ((num_rands <= ((Scheme_Primitive_Proc *)rator)->mu.maxa)
-	    || (((Scheme_Primitive_Proc *)rator)->maxa < 0))
+	    || (((Scheme_Primitive_Proc *)rator)->mina < 0))
 	&& is_noncm(rator))
       direct_prim = 1;
   } else {
@@ -2902,7 +2903,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
 #else
       int then_short_ok = 1;
 #endif
-	  START_JIT_DATA();
+      START_JIT_DATA();
 
 #ifdef MZ_USE_JIT_PPC
       /* It's possible that the code for a then
@@ -3663,8 +3664,15 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
   CHECK_LIMIT();
 
   /* *** stack_cache_pop_code *** */
+  /* DANGER: this code must save and restore (or avoid)
+     any registers that a function call would normally save 
+     and restore. JIT_AUX, which is used by things like jit_ldi,
+     is such a register for PPC. */
   stack_cache_pop_code = jit_get_ip().ptr;
   jit_movr_p(JIT_R0, JIT_RET);
+#ifdef MZ_USE_JIT_PPC
+  jit_movr_p(JIT_R(3), JIT_AUX);
+#endif
   /* Decrement stack_cache_stack_pos */
   jit_ldi_i(JIT_R1, &stack_cache_stack_pos);
   jit_subi_i(JIT_R2, JIT_R1, 1);
@@ -3676,6 +3684,9 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
   (void)jit_movi_p(JIT_R2, &stack_cache_stack);
   jit_ldxr_p(JIT_R2, JIT_R2, JIT_R1);
   jit_movr_p(JIT_RET, JIT_R0);
+#ifdef MZ_USE_JIT_PPC
+  jit_movr_p(JIT_AUX, JIT_R(3));
+#endif
   jit_jmpr(JIT_R2);
   CHECK_LIMIT();
 

src/mzscheme/src/mzmark.c

@@ -650,31 +650,60 @@ static int prim_proc_SIZE(void *p) {
   Scheme_Primitive_Proc *prim = (Scheme_Primitive_Proc *)p;
 
   return
-  ((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
+  ((prim->pp.flags & SCHEME_PRIM_IS_CLOSURE)
-   ? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
+   ? (gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Closure))
-   : gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc)));
+      + ((Scheme_Primitive_Closure *)prim)->count - 1)
+   : ((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
+      ? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
+      : gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc))));
 }
 
 static int prim_proc_MARK(void *p) {
   Scheme_Primitive_Proc *prim = (Scheme_Primitive_Proc *)p;
 
   gcMARK(prim->name);
+  if (prim->mina < 0) {
+    gcMARK(prim->mu.cases);
+  }
+  if (prim->pp.flags & SCHEME_PRIM_IS_CLOSURE) {
+    Scheme_Primitive_Closure *cc = (Scheme_Primitive_Closure *)prim;
+    int i;
+    for (i = cc->count; i--; ) {
+      gcMARK(cc->val[i]);
+    }
+  }  
   
   return
-  ((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
+  ((prim->pp.flags & SCHEME_PRIM_IS_CLOSURE)
-   ? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
+   ? (gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Closure))
-   : gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc)));
+      + ((Scheme_Primitive_Closure *)prim)->count - 1)
+   : ((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
+      ? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
+      : gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc))));
 }
 
 static int prim_proc_FIXUP(void *p) {
   Scheme_Primitive_Proc *prim = (Scheme_Primitive_Proc *)p;
 
   gcFIXUP(prim->name);
+  if (prim->mina < 0) {
+    gcFIXUP(prim->mu.cases);
+  }
+  if (prim->pp.flags & SCHEME_PRIM_IS_CLOSURE) {
+    Scheme_Primitive_Closure *cc = (Scheme_Primitive_Closure *)prim;
+    int i;
+    for (i = cc->count; i--; ) {
+      gcFIXUP(cc->val[i]);
+    }
+  }  
   
   return
-  ((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
+  ((prim->pp.flags & SCHEME_PRIM_IS_CLOSURE)
-   ? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
+   ? (gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Closure))
-   : gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc)));
+      + ((Scheme_Primitive_Closure *)prim)->count - 1)
+   : ((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
+      ? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
+      : gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc))));
 }
 
 #define prim_proc_IS_ATOMIC 0
@@ -688,14 +717,8 @@ static int closed_prim_proc_SIZE(void *p) {
   ((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
    ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
    : ((c->mina == -2)
-      ? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
+      ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
-	 ? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_Proc))
+      : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
-	    + ((Scheme_Closed_Case_Primitive_Post_Proc *)c)->len - 1)
-	 : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc)))
-      : ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
-	 ? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Post_Ext_Proc))
-	    + ((Scheme_Closed_Primitive_Post_Proc *)c)->len - 1)
-	 : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc)))));
 }
 
 static int closed_prim_proc_MARK(void *p) {
@@ -703,23 +726,6 @@ static int closed_prim_proc_MARK(void *p) {
 
   gcMARK(c->name);
   gcMARK(SCHEME_CLSD_PRIM_DATA(c));
-  if (c->pp.flags & SCHEME_PRIM_IS_POST_DATA) {
-    if (c->mina == -2) {
-      Scheme_Closed_Case_Primitive_Post_Ext_Proc *cc;
-      int i;
-      cc = (Scheme_Closed_Case_Primitive_Post_Ext_Proc *)c;
-      for (i = cc->p.len; i--; ) {
-	gcMARK(cc->a[i]);
-      }
-    } else {
-      Scheme_Closed_Primitive_Post_Ext_Proc *cc;
-      int i;
-      cc = (Scheme_Closed_Primitive_Post_Ext_Proc *)c;
-      for (i = cc->p.len; i--; ) {
-	gcMARK(cc->a[i]);
-      }
-    }
-  }
   if (c->mina == -2) {
     gcMARK(((Scheme_Closed_Case_Primitive_Proc *)c)->cases);
   }
@@ -728,14 +734,8 @@ static int closed_prim_proc_MARK(void *p) {
   ((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
    ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
    : ((c->mina == -2)
-      ? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
+      ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
-	 ? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_Proc))
+      : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
-	    + ((Scheme_Closed_Case_Primitive_Post_Proc *)c)->len - 1)
-	 : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc)))
-      : ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
-	 ? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Post_Ext_Proc))
-	    + ((Scheme_Closed_Primitive_Post_Proc *)c)->len - 1)
-	 : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc)))));
 }
 
 static int closed_prim_proc_FIXUP(void *p) {
@@ -743,23 +743,6 @@ static int closed_prim_proc_FIXUP(void *p) {
 
   gcFIXUP(c->name);
   gcFIXUP(SCHEME_CLSD_PRIM_DATA(c));
-  if (c->pp.flags & SCHEME_PRIM_IS_POST_DATA) {
-    if (c->mina == -2) {
-      Scheme_Closed_Case_Primitive_Post_Ext_Proc *cc;
-      int i;
-      cc = (Scheme_Closed_Case_Primitive_Post_Ext_Proc *)c;
-      for (i = cc->p.len; i--; ) {
-	gcFIXUP(cc->a[i]);
-      }
-    } else {
-      Scheme_Closed_Primitive_Post_Ext_Proc *cc;
-      int i;
-      cc = (Scheme_Closed_Primitive_Post_Ext_Proc *)c;
-      for (i = cc->p.len; i--; ) {
-	gcFIXUP(cc->a[i]);
-      }
-    }
-  }
   if (c->mina == -2) {
     gcFIXUP(((Scheme_Closed_Case_Primitive_Proc *)c)->cases);
   }
@@ -768,14 +751,8 @@ static int closed_prim_proc_FIXUP(void *p) {
   ((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
    ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
    : ((c->mina == -2)
-      ? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
+      ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
-	 ? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_Proc))
+      : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
-	    + ((Scheme_Closed_Case_Primitive_Post_Proc *)c)->len - 1)
-	 : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc)))
-      : ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
-	 ? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Post_Ext_Proc))
-	    + ((Scheme_Closed_Primitive_Post_Proc *)c)->len - 1)
-	 : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc)))));
 }
 
 #define closed_prim_proc_IS_ATOMIC 0

src/mzscheme/src/mzmarksrc.c

@@ -244,11 +244,24 @@ prim_proc {
 
  mark:
   gcMARK(prim->name);
+  if (prim->mina < 0) {
+    gcMARK(prim->mu.cases);
+  }
+  if (prim->pp.flags & SCHEME_PRIM_IS_CLOSURE) {
+    Scheme_Primitive_Closure *cc = (Scheme_Primitive_Closure *)prim;
+    int i;
+    for (i = cc->count; i--; ) {
+      gcMARK(cc->val[i]);
+    }
+  }  
   
  size:
-  ((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
+  ((prim->pp.flags & SCHEME_PRIM_IS_CLOSURE)
-   ? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
+   ? (gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Closure))
-   : gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc)));
+      + ((Scheme_Primitive_Closure *)prim)->count - 1)
+   : ((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
+      ? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
+      : gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc))));
 }
 
 closed_prim_proc {
@@ -257,23 +270,6 @@ closed_prim_proc {
  mark:
   gcMARK(c->name);
   gcMARK(SCHEME_CLSD_PRIM_DATA(c));
-  if (c->pp.flags & SCHEME_PRIM_IS_POST_DATA) {
-    if (c->mina == -2) {
-      Scheme_Closed_Case_Primitive_Post_Ext_Proc *cc;
-      int i;
-      cc = (Scheme_Closed_Case_Primitive_Post_Ext_Proc *)c;
-      for (i = cc->p.len; i--; ) {
-	gcMARK(cc->a[i]);
-      }
-    } else {
-      Scheme_Closed_Primitive_Post_Ext_Proc *cc;
-      int i;
-      cc = (Scheme_Closed_Primitive_Post_Ext_Proc *)c;
-      for (i = cc->p.len; i--; ) {
-	gcMARK(cc->a[i]);
-      }
-    }
-  }
   if (c->mina == -2) {
     gcMARK(((Scheme_Closed_Case_Primitive_Proc *)c)->cases);
   }
@@ -282,14 +278,8 @@ closed_prim_proc {
   ((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
    ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
    : ((c->mina == -2)
-      ? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
+      ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
-	 ? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_Proc))
+      : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
-	    + ((Scheme_Closed_Case_Primitive_Post_Proc *)c)->len - 1)
-	 : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc)))
-      : ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
-	 ? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Post_Ext_Proc))
-	    + ((Scheme_Closed_Primitive_Post_Proc *)c)->len - 1)
-	 : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc)))));
 }
 
 scm_closure {

src/mzscheme/src/schapp.inc

@@ -1,8 +1,9 @@
 
   MZ_MARK_STACK_TYPE old_cont_mark_stack;
-  Scheme_Object *v;
+  GC_CAN_IGNORE Scheme_Object *v;
-  Scheme_Closed_Primitive_Proc *prim;
+  GC_CAN_IGNORE Scheme_Primitive_Closure *prim;
-  Scheme_Thread *p = scheme_current_thread;
+  GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
+  GC_CAN_IGNORE Scheme_Primitive_Closure_Proc *f;
 
 #if !PRIM_NO_STACK_CHECK
 # ifdef DO_STACK_CHECK
@@ -33,11 +34,11 @@
   DO_CHECK_FOR_BREAK(p, ;);
 #endif
 
-  prim = (Scheme_Closed_Primitive_Proc *)rator;
+  prim = (Scheme_Primitive_Closure *)rator;
 
 #if PRIM_CHECK_ARITY
-  if (argc < prim->mina || (argc > prim->maxa && prim->maxa >= 0)) {
+  if (argc < prim->p.mina || (argc > prim->p.mu.maxa && prim->p.mina >= 0)) {
-    scheme_wrong_count(prim->name, prim->mina, prim->maxa, argc, argv);
+    scheme_wrong_count(prim->p.name, prim->p.mina, prim->p.mu.maxa, argc, argv);
     return NULL; /* Shouldn't get here */
   }
 #endif
@@ -45,7 +46,9 @@
   MZ_CONT_MARK_POS++;
   old_cont_mark_stack = MZ_CONT_MARK_STACK;
 
-  v = prim->prim_val(prim->data, argc, argv);
+  f = prim->p.prim_val;
+  v = f(argc, argv, (Scheme_Object *)prim);
+
 #if !PRIM_NO_CHECK_VALUE
   v = _scheme_force_value(v);
 #endif

src/mzscheme/src/schemef.h

@@ -253,14 +253,14 @@ 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_apply_known_closed_prim(Scheme_Object *rator, int argc,
+MZ_EXTERN Scheme_Object *_scheme_apply_known_prim_closure(Scheme_Object *rator, int argc,
-					       Scheme_Object **argv);
+							  Scheme_Object **argv);
-MZ_EXTERN Scheme_Object *_scheme_apply_known_closed_prim_multi(Scheme_Object *rator, int argc,
+MZ_EXTERN Scheme_Object *_scheme_apply_known_prim_closure_multi(Scheme_Object *rator, int argc,
-						     Scheme_Object **argv);
+								Scheme_Object **argv);
-MZ_EXTERN Scheme_Object *_scheme_apply_closed_prim(Scheme_Object *rator, int argc,
+MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure(Scheme_Object *rator, int argc,
-					 Scheme_Object **argv);
+						    Scheme_Object **argv);
-MZ_EXTERN Scheme_Object *_scheme_apply_closed_prim_multi(Scheme_Object *rator, int argc,
+MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure_multi(Scheme_Object *rator, int argc,
-					       Scheme_Object **argv);
+							  Scheme_Object **argv);
 
 MZ_EXTERN Scheme_Object *scheme_values(int c, Scheme_Object **v);
 
@@ -389,7 +389,6 @@ MZ_EXTERN Scheme_Hash_Table *scheme_clone_hash_table(Scheme_Hash_Table *bt);
 
 MZ_EXTERN Scheme_Object *scheme_make_prim(Scheme_Prim *prim);
 MZ_EXTERN Scheme_Object *scheme_make_noneternal_prim(Scheme_Prim *prim);
-MZ_EXTERN Scheme_Object *scheme_make_closed_prim(Scheme_Closed_Prim *prim, void *data);
 MZ_EXTERN Scheme_Object *scheme_make_prim_w_arity(Scheme_Prim *prim, const char *name,
 					mzshort mina, mzshort maxa);
 MZ_EXTERN Scheme_Object *scheme_make_folding_prim(Scheme_Prim *prim,
@@ -402,18 +401,30 @@ MZ_EXTERN Scheme_Object *scheme_make_noncm_prim(Scheme_Prim *prim,
 MZ_EXTERN Scheme_Object *scheme_make_noneternal_prim_w_arity(Scheme_Prim *prim,
 						   const char *name,
 						   mzshort mina, mzshort maxa);
-MZ_EXTERN Scheme_Object *scheme_make_closed_prim_w_arity(Scheme_Closed_Prim *prim,
-					       void *data, const char *name,
-					       mzshort mina, mzshort maxa);
-MZ_EXTERN Scheme_Object *scheme_make_folding_closed_prim(Scheme_Closed_Prim *prim,
-					       void *data, const char *name,
-					       mzshort mina, mzshort maxa,
-					       short functional);
 MZ_EXTERN Scheme_Object *scheme_make_prim_w_everything(Scheme_Prim *fun, int eternal,
 						       const char *name,
 						       mzshort mina, mzshort maxa,
 						       int folding,
 						       mzshort minr, mzshort maxr);
+
+MZ_EXTERN Scheme_Object *scheme_make_prim_closure_w_arity(Scheme_Primitive_Closure_Proc *prim,
+							  int size, Scheme_Object **vals,
+							  const char *name,
+							  mzshort mina, mzshort maxa);
+MZ_EXTERN Scheme_Object *scheme_make_folding_prim_closure(Scheme_Primitive_Closure_Proc *prim,
+							  int size, Scheme_Object **vals,
+							  const char *name,
+							  mzshort mina, mzshort maxa,
+							  short functional);
+
+MZ_EXTERN Scheme_Object *scheme_make_closed_prim(Scheme_Closed_Prim *prim, void *data);
+MZ_EXTERN Scheme_Object *scheme_make_closed_prim_w_arity(Scheme_Closed_Prim *prim,
+							 void *data, const char *name,
+							 mzshort mina, mzshort maxa);
+MZ_EXTERN Scheme_Object *scheme_make_folding_closed_prim(Scheme_Closed_Prim *prim,
+							 void *data, const char *name,
+							 mzshort mina, mzshort maxa,
+							 short functional);
 MZ_EXTERN Scheme_Object *scheme_make_closed_prim_w_everything(Scheme_Closed_Prim *fun,
 							      void *data,
 							      const char *name,

src/mzscheme/src/schemex.h

@@ -203,14 +203,14 @@ Scheme_Object *(*scheme_apply_to_list)(Scheme_Object *rator, Scheme_Object *args
 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_apply_known_closed_prim)(Scheme_Object *rator, int argc,
+Scheme_Object *(*_scheme_apply_known_prim_closure)(Scheme_Object *rator, int argc,
-					       Scheme_Object **argv);
+							  Scheme_Object **argv);
-Scheme_Object *(*_scheme_apply_known_closed_prim_multi)(Scheme_Object *rator, int argc,
+Scheme_Object *(*_scheme_apply_known_prim_closure_multi)(Scheme_Object *rator, int argc,
-						     Scheme_Object **argv);
+								Scheme_Object **argv);
-Scheme_Object *(*_scheme_apply_closed_prim)(Scheme_Object *rator, int argc,
+Scheme_Object *(*_scheme_apply_prim_closure)(Scheme_Object *rator, int argc,
-					 Scheme_Object **argv);
+						    Scheme_Object **argv);
-Scheme_Object *(*_scheme_apply_closed_prim_multi)(Scheme_Object *rator, int argc,
+Scheme_Object *(*_scheme_apply_prim_closure_multi)(Scheme_Object *rator, int argc,
-					       Scheme_Object **argv);
+							  Scheme_Object **argv);
 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 */
@@ -313,7 +313,6 @@ Scheme_Hash_Table *(*scheme_clone_hash_table)(Scheme_Hash_Table *bt);
 /*========================================================================*/
 Scheme_Object *(*scheme_make_prim)(Scheme_Prim *prim);
 Scheme_Object *(*scheme_make_noneternal_prim)(Scheme_Prim *prim);
-Scheme_Object *(*scheme_make_closed_prim)(Scheme_Closed_Prim *prim, void *data);
 Scheme_Object *(*scheme_make_prim_w_arity)(Scheme_Prim *prim, const char *name,
 					mzshort mina, mzshort maxa);
 Scheme_Object *(*scheme_make_folding_prim)(Scheme_Prim *prim,
@@ -326,18 +325,28 @@ Scheme_Object *(*scheme_make_noncm_prim)(Scheme_Prim *prim,
 Scheme_Object *(*scheme_make_noneternal_prim_w_arity)(Scheme_Prim *prim,
 						   const char *name,
 						   mzshort mina, mzshort maxa);
-Scheme_Object *(*scheme_make_closed_prim_w_arity)(Scheme_Closed_Prim *prim,
-					       void *data, const char *name,
-					       mzshort mina, mzshort maxa);
-Scheme_Object *(*scheme_make_folding_closed_prim)(Scheme_Closed_Prim *prim,
-					       void *data, const char *name,
-					       mzshort mina, mzshort maxa,
-					       short functional);
 Scheme_Object *(*scheme_make_prim_w_everything)(Scheme_Prim *fun, int eternal,
 						       const char *name,
 						       mzshort mina, mzshort maxa,
 						       int folding,
 						       mzshort minr, mzshort maxr);
+Scheme_Object *(*scheme_make_prim_closure_w_arity)(Scheme_Primitive_Closure_Proc *prim,
+							  int size, Scheme_Object **vals,
+							  const char *name,
+							  mzshort mina, mzshort maxa);
+Scheme_Object *(*scheme_make_folding_prim_closure)(Scheme_Primitive_Closure_Proc *prim,
+							  int size, Scheme_Object **vals,
+							  const char *name,
+							  mzshort mina, mzshort maxa,
+							  short functional);
+Scheme_Object *(*scheme_make_closed_prim)(Scheme_Closed_Prim *prim, void *data);
+Scheme_Object *(*scheme_make_closed_prim_w_arity)(Scheme_Closed_Prim *prim,
+							 void *data, const char *name,
+							 mzshort mina, mzshort maxa);
+Scheme_Object *(*scheme_make_folding_closed_prim)(Scheme_Closed_Prim *prim,
+							 void *data, const char *name,
+							 mzshort mina, mzshort maxa,
+							 short functional);
 Scheme_Object *(*scheme_make_closed_prim_w_everything)(Scheme_Closed_Prim *fun,
 							      void *data,
 							      const char *name,

src/mzscheme/src/schemex.inc

@@ -124,10 +124,10 @@
   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_apply_known_closed_prim = _scheme_apply_known_closed_prim;
+  scheme_extension_table->_scheme_apply_known_prim_closure = _scheme_apply_known_prim_closure;
-  scheme_extension_table->_scheme_apply_known_closed_prim_multi = _scheme_apply_known_closed_prim_multi;
+  scheme_extension_table->_scheme_apply_known_prim_closure_multi = _scheme_apply_known_prim_closure_multi;
-  scheme_extension_table->_scheme_apply_closed_prim = _scheme_apply_closed_prim;
+  scheme_extension_table->_scheme_apply_prim_closure = _scheme_apply_prim_closure;
-  scheme_extension_table->_scheme_apply_closed_prim_multi = _scheme_apply_closed_prim_multi;
+  scheme_extension_table->_scheme_apply_prim_closure_multi = _scheme_apply_prim_closure_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;
@@ -209,14 +209,16 @@
   scheme_extension_table->scheme_clone_hash_table = scheme_clone_hash_table;
   scheme_extension_table->scheme_make_prim = scheme_make_prim;
   scheme_extension_table->scheme_make_noneternal_prim = scheme_make_noneternal_prim;
-  scheme_extension_table->scheme_make_closed_prim = scheme_make_closed_prim;
   scheme_extension_table->scheme_make_prim_w_arity = scheme_make_prim_w_arity;
   scheme_extension_table->scheme_make_folding_prim = scheme_make_folding_prim;
   scheme_extension_table->scheme_make_noncm_prim = scheme_make_noncm_prim;
   scheme_extension_table->scheme_make_noneternal_prim_w_arity = scheme_make_noneternal_prim_w_arity;
+  scheme_extension_table->scheme_make_prim_w_everything = scheme_make_prim_w_everything;
+  scheme_extension_table->scheme_make_prim_closure_w_arity = scheme_make_prim_closure_w_arity;
+  scheme_extension_table->scheme_make_folding_prim_closure = scheme_make_folding_prim_closure;
+  scheme_extension_table->scheme_make_closed_prim = scheme_make_closed_prim;
   scheme_extension_table->scheme_make_closed_prim_w_arity = scheme_make_closed_prim_w_arity;
   scheme_extension_table->scheme_make_folding_closed_prim = scheme_make_folding_closed_prim;
-  scheme_extension_table->scheme_make_prim_w_everything = scheme_make_prim_w_everything;
   scheme_extension_table->scheme_make_closed_prim_w_everything = scheme_make_closed_prim_w_everything;
   scheme_extension_table->scheme_prim_is_method = scheme_prim_is_method;
   scheme_extension_table->scheme_make_pair = scheme_make_pair;

src/mzscheme/src/schemexm.h

@@ -124,10 +124,10 @@
 #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_apply_known_closed_prim (scheme_extension_table->_scheme_apply_known_closed_prim)
+#define _scheme_apply_known_prim_closure (scheme_extension_table->_scheme_apply_known_prim_closure)
-#define _scheme_apply_known_closed_prim_multi (scheme_extension_table->_scheme_apply_known_closed_prim_multi)
+#define _scheme_apply_known_prim_closure_multi (scheme_extension_table->_scheme_apply_known_prim_closure_multi)
-#define _scheme_apply_closed_prim (scheme_extension_table->_scheme_apply_closed_prim)
+#define _scheme_apply_prim_closure (scheme_extension_table->_scheme_apply_prim_closure)
-#define _scheme_apply_closed_prim_multi (scheme_extension_table->_scheme_apply_closed_prim_multi)
+#define _scheme_apply_prim_closure_multi (scheme_extension_table->_scheme_apply_prim_closure_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)
@@ -209,14 +209,16 @@
 #define scheme_clone_hash_table (scheme_extension_table->scheme_clone_hash_table)
 #define scheme_make_prim (scheme_extension_table->scheme_make_prim)
 #define scheme_make_noneternal_prim (scheme_extension_table->scheme_make_noneternal_prim)
-#define scheme_make_closed_prim (scheme_extension_table->scheme_make_closed_prim)
 #define scheme_make_prim_w_arity (scheme_extension_table->scheme_make_prim_w_arity)
 #define scheme_make_folding_prim (scheme_extension_table->scheme_make_folding_prim)
 #define scheme_make_noncm_prim (scheme_extension_table->scheme_make_noncm_prim)
 #define scheme_make_noneternal_prim_w_arity (scheme_extension_table->scheme_make_noneternal_prim_w_arity)
+#define scheme_make_prim_w_everything (scheme_extension_table->scheme_make_prim_w_everything)
+#define scheme_make_prim_closure_w_arity (scheme_extension_table->scheme_make_prim_closure_w_arity)
+#define scheme_make_folding_prim_closure (scheme_extension_table->scheme_make_folding_prim_closure)
+#define scheme_make_closed_prim (scheme_extension_table->scheme_make_closed_prim)
 #define scheme_make_closed_prim_w_arity (scheme_extension_table->scheme_make_closed_prim_w_arity)
 #define scheme_make_folding_closed_prim (scheme_extension_table->scheme_make_folding_closed_prim)
-#define scheme_make_prim_w_everything (scheme_extension_table->scheme_make_prim_w_everything)
 #define scheme_make_closed_prim_w_everything (scheme_extension_table->scheme_make_closed_prim_w_everything)
 #define scheme_prim_is_method (scheme_extension_table->scheme_prim_is_method)
 #define scheme_make_pair (scheme_extension_table->scheme_make_pair)

src/mzscheme/src/schnapp.inc

@@ -5,41 +5,18 @@
 
     if (t == scheme_prim_type) {
       Scheme_Object *v;
-      Scheme_Primitive_Proc *prim;
+      GC_CAN_IGNORE Scheme_Primitive_Proc *prim;
+      GC_CAN_IGNORE Scheme_Primitive_Closure_Proc *f;
 
       prim = (Scheme_Primitive_Proc *)rator;
 
-      if (argc < prim->mina || (argc > prim->maxa && prim->maxa >= 0)) {
+      if (argc < prim->mina || (argc > prim->mu.maxa && prim->mina >= 0)) {
-	scheme_wrong_count(prim->name, prim->mina, prim->maxa, argc, argv);
+	scheme_wrong_count(prim->name, prim->mina, prim->mu.maxa, argc, argv);
 	return NULL; /* Shouldn't get here */
       }
 
-      v = prim->prim_val(argc, argv);
+      f = (Scheme_Primitive_Closure_Proc *)prim->prim_val;
-
+      v = f(argc, argv, (Scheme_Object *)prim);
-#if PRIM_CHECK_VALUE
-      v = _scheme_force_value(v);
-#endif
-
-#if PRIM_CHECK_MULTI
-      if (v == SCHEME_MULTIPLE_VALUES) {
-	scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL);
-	return NULL; /* Shouldn't get here */
-      }
-#endif
-
-      return v;
-    } else if (t == scheme_closed_prim_type) {
-      Scheme_Object *v;
-      Scheme_Closed_Primitive_Proc *prim;
-
-      prim = (Scheme_Closed_Primitive_Proc *)rator;
-
-      if (argc < prim->mina || (argc > prim->maxa && prim->maxa >= 0)) {
-	scheme_wrong_count(prim->name, prim->mina, prim->maxa, argc, argv);
-	return NULL; /* Shouldn't get here */
-      }
-
-      v = prim->prim_val(prim->data, argc, argv);
 
 #if PRIM_CHECK_VALUE
       v = _scheme_force_value(v);

src/mzscheme/src/schvers.h

@@ -9,6 +9,6 @@
 
 
 #define MZSCHEME_VERSION_MAJOR 301
-#define MZSCHEME_VERSION_MINOR 6
+#define MZSCHEME_VERSION_MINOR 7
 
-#define MZSCHEME_VERSION "301.6" _MZ_SPECIAL_TAG
+#define MZSCHEME_VERSION "301.7" _MZ_SPECIAL_TAG

src/mzscheme/src/struct.c

@@ -565,9 +565,10 @@ static Scheme_Object *current_code_inspector(int argc, Scheme_Object *argv[])
 /*                             properties                                 */
 /*========================================================================*/
 
-static Scheme_Object *prop_pred(Scheme_Object *prop, int argc, Scheme_Object **args)
+static Scheme_Object *prop_pred(int argc, Scheme_Object **args, Scheme_Object *prim)
 {
   Scheme_Struct_Type *stype;
+  Scheme_Object *prop = SCHEME_PRIM_CLOSURE_ELS(prim)[0];
 
   if (SCHEME_STRUCTP(args[0]))
     stype = ((Scheme_Structure *)args[0])->stype;
@@ -590,14 +591,14 @@ static Scheme_Object *prop_pred(Scheme_Object *prop, int argc, Scheme_Object **a
   return scheme_false;
 }
 
-static Scheme_Object *prop_accessor(Scheme_Object *prop, int argc, Scheme_Object **args)
+static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg, int error_ok)
 {
   Scheme_Struct_Type *stype;
 
-  if (SCHEME_STRUCTP(args[0]))
+  if (SCHEME_STRUCTP(arg))
-    stype = ((Scheme_Structure *)args[0])->stype;
+    stype = ((Scheme_Structure *)arg)->stype;
-  else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_struct_type_type))
+  else if (SAME_TYPE(SCHEME_TYPE(arg), scheme_struct_type_type))
-    stype = (Scheme_Struct_Type *)args[0];
+    stype = (Scheme_Struct_Type *)arg;
   else
     stype = NULL;
 
@@ -616,13 +617,18 @@ static Scheme_Object *prop_accessor(Scheme_Object *prop, int argc, Scheme_Object
     }
   }
   
-  if (argc < 2) /* hack; see scheme_struct_type_property_ref */
+  if (error_ok) /* hack; see scheme_struct_type_property_ref */
     scheme_wrong_type("property accessor", 
 		      "struct or struct-type with property", 
-		      0, argc, args);
+		      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);
+}
+
 static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[])
 {
   Scheme_Struct_Property *p;
@@ -652,20 +658,20 @@ static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[])
   name[len] = '?';
   name[len+1] = 0;
 
-  v = scheme_make_folding_closed_prim((Scheme_Closed_Prim *)prop_pred,
+  v = scheme_make_folding_prim_closure(prop_pred,
-				      (void *)p,
+				       1, a,
-				      name,
+				       name,
-				      1, 1, 0);
+				       1, 1, 0);
   a[1] = v;
 
   name = MALLOC_N_ATOMIC(char, len + 10);
   memcpy(name, SCHEME_SYM_VAL(argv[0]), len);
   memcpy(name + len, "-accessor", 10);
 
-  v = scheme_make_folding_closed_prim((Scheme_Closed_Prim *)prop_accessor,
+  v = scheme_make_folding_prim_closure(prop_accessor,
-				      (void *)p,
+				       1, a,
-				      name,
+				       name,
-				      1, 1, 0);
+				       1, 1, 0);
   a[2] = v;
 
   return scheme_values(3, a);
@@ -690,7 +696,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 prop_accessor(prop, 2, &s); /* 2 is a hack! */
+  return do_prop_accessor(prop, s, 0);
 }
 
 static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[])
@@ -978,13 +984,20 @@ scheme_make_struct_instance(Scheme_Object *_stype, int argc, Scheme_Object **arg
   return (Scheme_Object *)inst;
 }
 
-static Scheme_Object *struct_pred(Scheme_Struct_Type *stype, int argc, Scheme_Object **args)
+static Scheme_Object *
+make_struct_instance(int argc, Scheme_Object **args, Scheme_Object *prim)
 {
-  if (SCHEME_STRUCTP(args[0])
+  return scheme_make_struct_instance(SCHEME_PRIM_CLOSURE_ELS(prim)[0], argc, args);
-      && STRUCT_TYPEP(stype, ((Scheme_Structure *)args[0])))
+}
-    return scheme_true;
+
-  else
+static Scheme_Object *struct_pred(int argc, Scheme_Object **args, Scheme_Object *prim)
-    return scheme_false;
+{
+  if (SCHEME_STRUCTP(args[0])) {
+    Scheme_Struct_Type *stype = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
+    if (STRUCT_TYPEP(stype, ((Scheme_Structure *)args[0])))
+      return scheme_true;
+  }
+  return scheme_false;
 }
 
 static int parse_pos(const char *who, Struct_Proc_Info *i, Scheme_Object **args, int argc)
@@ -1041,10 +1054,11 @@ static int parse_pos(const char *who, Struct_Proc_Info *i, Scheme_Object **args,
   return pos;
 }
 
-static Scheme_Object *struct_getter(Struct_Proc_Info *i, int argc, Scheme_Object **args)
+static Scheme_Object *struct_getter(int argc, Scheme_Object **args, Scheme_Object *prim)
 {
   Scheme_Structure *inst;
   int pos;
+  Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
 
   inst = (Scheme_Structure *)args[0];
 
@@ -1069,11 +1083,12 @@ static Scheme_Object *struct_getter(Struct_Proc_Info *i, int argc, Scheme_Object
   return inst->slots[pos];
 }
 
-static Scheme_Object *struct_setter(Struct_Proc_Info *i, int argc, Scheme_Object **args)
+static Scheme_Object *struct_setter(int argc, Scheme_Object **args, Scheme_Object *prim)
 {
   Scheme_Structure *inst;
   int pos;
   Scheme_Object *v;
+  Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
 
   if (!SCHEME_STRUCTP(args[0])) {
     scheme_wrong_type(i->func_name, 
@@ -1426,7 +1441,7 @@ int scheme_inspector_sees_part(Scheme_Object *s, Scheme_Object *insp, int pos)
 
 
 #define STRUCT_PROCP(o, t) \
-    (SCHEME_STRUCT_PROCP(o) && (((Scheme_Closed_Primitive_Proc *)o)->pp.flags & t))
+    (SCHEME_STRUCT_PROCP(o) && (((Scheme_Primitive_Proc *)o)->pp.flags & t))
 
 static Scheme_Object *
 struct_setter_p(int argc, Scheme_Object *argv[])
@@ -1469,7 +1484,7 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
   if (!STRUCT_PROCP(argv[0], (getter
 			      ? SCHEME_PRIM_IS_STRUCT_GETTER
 			      : SCHEME_PRIM_IS_STRUCT_SETTER))
-      || (((Scheme_Closed_Primitive_Proc *)argv[0])->mina == (getter ? 1 : 2))) {
+      || (((Scheme_Primitive_Proc *)argv[0])->mina == (getter ? 1 : 2))) {
     scheme_wrong_type(who, (getter 
 			    ? "accessor procedure that requires a field index"
 			    : "mutator procedure that requires a field index"),
@@ -1477,7 +1492,7 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
     return NULL;
   }
 
-  i = (Struct_Proc_Info *)((Scheme_Closed_Primitive_Proc *)argv[0])->data;
+  i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(argv[0])[0];
 
   pos = parse_pos(who, i, argv, argc);
   
@@ -1930,22 +1945,24 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
 		 char *func_name, 
 		 Scheme_ProcT proc_type, int field_num)
 {
-  Scheme_Object *p;
+  Scheme_Object *p, *a[1];
   short flags = SCHEME_PRIM_IS_STRUCT_PROC;
 
   if (proc_type == SCHEME_CONSTR) {
-    p = scheme_make_folding_closed_prim((Scheme_Closed_Prim *)scheme_make_struct_instance,
+    a[0] = (Scheme_Object *)struct_type;
-					(void *)struct_type,
+    p = scheme_make_folding_prim_closure(make_struct_instance,
-					func_name,
+					 1, a,
-					struct_type->num_islots,
+					 func_name,
-					struct_type->num_islots,
+					 struct_type->num_islots,
-					0);
+					 struct_type->num_islots,
+					 0);
     flags |= SCHEME_PRIM_IS_STRUCT_CONSTR;
   } else if (proc_type == SCHEME_PRED) {
-    p = scheme_make_folding_closed_prim((Scheme_Closed_Prim *)struct_pred,
+    a[0] = (Scheme_Object *)struct_type;
-					(void *)struct_type,
+    p = scheme_make_folding_prim_closure(struct_pred,
-					func_name,
+					 1, a,
-					1, 1, 1);
+					 func_name,
+					 1, 1, 1);
     flags |= SCHEME_PRIM_IS_STRUCT_PRED;
   } else {
     Struct_Proc_Info *i;
@@ -1965,20 +1982,22 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
     else
       need_pos = 0;
 
+    a[0] = (Scheme_Object *)i;
+
     if ((proc_type == SCHEME_GETTER) || (proc_type == SCHEME_GEN_GETTER)) {
-      p = scheme_make_folding_closed_prim((Scheme_Closed_Prim *)struct_getter,
+      p = scheme_make_folding_prim_closure(struct_getter,
-					  (void *)i,
+					   1, a,
-					  func_name,
+					   func_name,
-					  1 + need_pos, 1 + need_pos, 1);
+					   1 + need_pos, 1 + need_pos, 1);
       flags |= SCHEME_PRIM_IS_STRUCT_GETTER;
       /* Cache the accessor only if `struct_info' is used.
 	 This avoids keep lots of useless accessors.
 	 if (need_pos) struct_type->accessor = p; */
     } else {
-      p = scheme_make_folding_closed_prim((Scheme_Closed_Prim *)struct_setter,
+      p = scheme_make_folding_prim_closure(struct_setter,
-					  (void *)i,
+					   1, a,
-					  func_name,
+					   func_name,
-					  2 + need_pos, 2 + need_pos, 0);
+					   2 + need_pos, 2 + need_pos, 0);
       flags |= SCHEME_PRIM_IS_STRUCT_SETTER;
       /* See note above:
 	 if (need_pos) struct_type->mutator = p; */

src/mzscheme/src/thread.c

@@ -5714,7 +5714,7 @@ static Scheme_Object *extend_parameterization(int argc, Scheme_Object *argv[])
       a[1] = scheme_false;
       if (SCHEME_PRIMP(argv[i])) {
 	Scheme_Prim *proc;
-	proc = ((Scheme_Primitive_Proc *)argv[i])->prim_val;
+	proc = (Scheme_Prim *)((Scheme_Primitive_Proc *)argv[i])->prim_val;
 	key = proc(2, a); /* leads to scheme_param_config to set a[1] */
       } else {
 	/* sets a[1] */

src/mzscheme/utils/xcglue.h

@@ -158,7 +158,7 @@ mzchar objscheme_unbundle_char(Scheme_Object *, const char *);
 #define objscheme_unbundle_long objscheme_unbundle_integer
 #define objscheme_unbundle_int objscheme_unbundle_integer
 
-#define OBJSCHEME_PRIM_METHOD(m, cf) (SCHEME_PRIMP(m) && (((Scheme_Primitive_Proc *)m)->prim_val == cf))
+#define OBJSCHEME_PRIM_METHOD(m, cf) (SCHEME_PRIMP(m) && ((Scheme_Prim *)((Scheme_Primitive_Proc *)m)->prim_val == cf))
 
 #define COPY_JMPBUF(dest, src) memcpy(&dest, &src, sizeof(mz_jmp_buf));