3m and mzc

svn: r1353

collects/compiler/mzc.h

@@ -67,14 +67,28 @@ static void closure_alloc_inc()
 # define CLOSURE_ALLOC_PP /**/
 #endif
 
+#ifdef MZ_PRECISE_GC
+# 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_ENV_POINTER(t, ct, void_param) (&(((const ct *)void_param)->data))
+#else
+# define MZC_INSTALL_DATA_PTR(rec) &rec->data
+# 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(&rec->prim, cfunc, &rec->data, name, amin, amax, flags))
+  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure_post(&rec->prim, cfunc, MZC_INSTALL_DATA_PTR(rec), \
+								    name, amin, amax, flags, \
+                                                                    sizeof(rec->data)>>2))
 
 #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))
 
 #define _scheme_make_c_case_proc_closure(cfunc, rec, name, ccnt, cses, flags) \
-  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure(&rec->prim, cfunc, &rec->data, name, ccnt, cses, flags))
+  (CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure_post(&rec->prim, cfunc, MZC_INSTALL_DATA_PTR(rec), \
+									 name, ccnt, cses, flags, \
+                                                                         sizeof(rec->data)>>2))
 
 #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))
@@ -301,3 +315,42 @@ static Scheme_Object *DEBUG_CHECK(Scheme_Object *v)
   return v;
 }
 #endif
+
+#ifdef MZ_PRECISE_GC
+START_XFORM_SUSPEND;
+static MZC_INLINE Scheme_Object *
+_mzc_direct_apply_primitive_multi(Scheme_Object *prim, int argc, Scheme_Object **argv)
+{
+  return _scheme_direct_apply_primitive_multi(prim, argc, argv);
+}
+static MZC_INLINE Scheme_Object *
+_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)
+{
+  return _scheme_direct_apply_closed_primitive_multi(prim, argc, argv);
+}
+static MZC_INLINE Scheme_Object *
+_mzc_direct_apply_closed_primitive(Scheme_Object *prim, int argc, Scheme_Object **argv)
+{
+  return _scheme_direct_apply_closed_primitive(prim, argc, argv);
+}
+END_XFORM_SUSPEND;
+#else
+# define _mzc_direct_apply_primitive_multi(prim, argc, argv) \
+         _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) \
+         _scheme_direct_apply_closed_primitive_multi(prim, argc, argv)
+# define _mzc_direct_apply_closed_primitive(prim, argc, argv) \
+         _scheme_direct_apply_closed_primitive(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_closed_prim_multi(r,n,rs) _scheme_apply_known_closed_prim_multi(r,n,rs)

collects/compiler/option-unit.ss

@@ -29,6 +29,7 @@
       (define debug (make-parameter #f))
       (define test (make-parameter #f))
       (define clean-intermediate-files (make-parameter #t))
+      (define 3m (make-parameter #f))
 
       (define max-exprs-per-top-level-set (make-parameter 25))
       

collects/compiler/private/driver.ss

@@ -71,11 +71,13 @@
 	   (lib "toplevel.ss" "syntax")
 	   (lib "compile-sig.ss" "dynext")
 	   (lib "link-sig.ss" "dynext")
-	   (lib "file-sig.ss" "dynext"))
+	   (lib "file-sig.ss" "dynext")
+	   (lib "plthome.ss" "setup"))
 
   (require "../sig.ss"
 	   "sig.ss"
-	   "../to-core.ss")
+	   "../to-core.ss"
+	   "../xform.ss")
 
   (provide driver@)
 
@@ -118,7 +120,7 @@
       ;; FILE PROCESSING FUNCTIONS
       ;;
       
-      ;; takes an input-name from the compile command and returns 4 values
+      ;; takes an input-name from the compile command and returns many values:
       ;; 1) an input path
       ;; 2) a C output path
       ;; 3) a constant pool output path
@@ -126,30 +128,41 @@
       ;; 5) a dll output path
       ;; 6) a scheme_setup suffix
       (define s:process-filenames
-	(lambda (input-name dest-dir from-c? tmp-c? tmp-o?)
+	(lambda (input-name dest-dir from-c? 3m? tmp-c? tmp-c3m? tmp-o?)
 	  (let-values ([(basedir file dir?) (split-path input-name)])
 	    (let* ([dest-dir (if (eq? dest-dir 'auto)
-				 (let ([d (build-path (if (eq? basedir 'relative)
+				 (let* ([d0 (build-path (if (eq? basedir 'relative)
-							  'same
+							    'same
-							  basedir)
+							    basedir)
-						      "compiled"
+							"compiled"
-						      "native"
+							"native"
-						      (system-library-subpath))])
+							(system-library-subpath #f))]
+					[d (if 3m?
+					       (build-path d0 "3m")
+					       d0)])
 				   (unless (directory-exists? d)
 				     (make-directory* d))
 				   d)
 				 dest-dir)]
 		   [path-prefix (lambda (a b)
 				  (bytes->path (bytes-append a (path->bytes b))))]
+		   [path-suffix (lambda (b a)
+				  (bytes->path (bytes-append (path->bytes b) a)))]
 		   [sbase (extract-base-filename/ss file (if from-c? #f 'mzc))]
 		   [cbase (extract-base-filename/c file (if from-c? 'mzc #f))]
 		   [base (or sbase cbase)]
 		   [c-dir (if tmp-c?
 			      (find-system-path 'temp-dir)
 			      dest-dir)]
+		   [c3m-dir (if tmp-c3m?
+				(find-system-path 'temp-dir)
+				dest-dir)]
 		   [c-prefix (if tmp-c?
 				 (lambda (s) (path-prefix #"mzcTMP" s))
 				 values)]
+		   [c3m-prefix (if tmp-c3m?
+				   (lambda (s) (path-prefix #"mzcTMP" s))
+				   values)]
 		   [o-dir (if tmp-o?
 			      (find-system-path 'temp-dir)
 			      dest-dir)]
@@ -164,6 +177,8 @@
 		      (if cbase 
 			  input-name 
 			  (build-path c-dir (c-prefix (append-c-suffix base))))
+		      (and 3m?
+			   (build-path c3m-dir (c-prefix (append-c-suffix (path-suffix base #"3m")))))
 		      (build-path o-dir (o-prefix (append-constant-pool-suffix base)))
 		      (build-path o-dir (o-prefix (append-object-suffix base)))
 		      (build-path dest-dir (append-extension-suffix base))
@@ -569,12 +584,14 @@
 	  (const:init-tables!)
 	  (compiler:init-closure-lists!)
 	  ; process the input string - try to open the input file
-	  (let-values ([(input-path c-output-path 
+	  (let-values ([(input-path c-output-path c3m-output-path
 				    constant-pool-output-path obj-output-path dll-output-path 
 				    setup-suffix)
-			(s:process-filenames input-name dest-directory from-c? 
+			(s:process-filenames input-name dest-directory from-c?
+					     (compiler:option:3m)
 					     (and (compiler:option:clean-intermediate-files)
 						  (not c-only?))
+					     (compiler:option:clean-intermediate-files)
 					     (and (compiler:option:clean-intermediate-files)
 						  (not multi-o?)))])
 	    (unless (or (not input-path) (file-exists? input-path))
@@ -588,6 +605,7 @@
 			(when (file-exists? path) (delete-file path)))
 		      (list (if input-path c-output-path obj-output-path) 
 			    (if input-path constant-pool-output-path obj-output-path) 
+			    (or c3m-output-path obj-output-path)
 			    obj-output-path dll-output-path))
 	
 	    (when (compiler:option:debug)
@@ -692,7 +710,8 @@
 									    #`'#,zodiac:global-assign-id
 									    #`'#,zodiac:safe-vector-ref-id
 									    #`'#,zodiac:global-prepare-id
-									    simple-constant?)])
+									    simple-constant?
+									    '(mzc-cffi))])
 					     (list (zodiac:syntax->zodiac src) 
 						   bytecode magic-sym)))
 					 (block-source s:file-block))])
@@ -1036,10 +1055,10 @@
 		       (parameterize ([read-case-sensitive #t]) ;; so symbols containing uppercase print like we want
 			 (let ([c-port #f])
 			   (dynamic-wind 
-					;pre
+			       ;;pre
 			       (lambda () (set! c-port (open-output-file c-output-path)))
 			       
-					;value
+			       ;;value
 			       (lambda ()
 				 (fprintf c-port "#define MZC_SRC_FILE ~s~n" input-name)
 				 (when (compiler:option:unsafe) (fprintf c-port "#define MZC_UNSAFE 1~n"))
@@ -1310,6 +1329,37 @@
 		    (vm->c:emit-symbol-list! port "" #f)
 		    (fprintf port "  )~n )~n")))))))
 
+	;;-----------------------------------------------------------------------
+	;; 3m xform
+	;;
+	
+        (when c3m-output-path
+	  (when (compiler:option:verbose)
+	    (printf " [xforming C to \"~a\"]~n" 
+		    c3m-output-path))
+
+	  (let ([clean-up-src-c
+		 (lambda ()
+		   (when (and (compiler:option:clean-intermediate-files)
+			      (not from-c?)
+			      (file-exists? c-output-path))
+		     (delete-file c-output-path)))])
+	    (with-handlers ([void
+			     (lambda (exn)
+			       (when (compiler:option:clean-intermediate-files)
+				 (when (file-exists? c3m-output-path)
+				   (delete-file c3m-output-path)))
+			       (clean-up-src-c)
+			       (raise exn))])
+	      
+	      (xform (not (compiler:option:verbose)) 
+		     (path->string c-output-path)
+		     c3m-output-path
+		     (list (build-path plthome "include")
+			   (collection-path "compiler")))
+
+	      (clean-up-src-c))))
+
 	;;--------------------------------------------------------------------
 	;; COMPILATION TO NATIVE CODE
 	;;
@@ -1319,7 +1369,7 @@
 	    
 	    (begin
 	      (unless input-path
-		(printf "\"~a\": ~n" c-output-path))
+		(printf "\"~a\": ~n" (or c3m-output-path c-output-path)))
 	      
 	      (when (compiler:option:verbose) (printf " [compiling native code to \"~a\"]~n"
 						      obj-output-path))
@@ -1329,6 +1379,7 @@
 		     (lambda ()
 		       (with-handlers
 			   ([void (lambda (exn)
+				    (exit)
 				    (compiler:fatal-error
 				     #f
 				     (string-append
@@ -1337,14 +1388,16 @@
 				      (exn-message exn)))
 				    (compiler:report-messages! #t))])
 			 (compile-extension (not (compiler:option:verbose)) 
-					    c-output-path obj-output-path
+					    (or c3m-output-path c-output-path) obj-output-path
 					    (list (collection-path "compiler")))))])
 		(verbose-time compile-thunk))
 	      
 	      ;; clean-up
 	      (when (and (compiler:option:clean-intermediate-files)
 			 input-path)
-		(delete-file c-output-path))
+		(if c3m-output-path
+		    (delete-file c3m-output-path)
+		    (delete-file c-output-path)))
 	      
 	      (if multi-o?
 		  (printf " [output to \"~a\"]~n" obj-output-path)

collects/compiler/private/rep.ss

@@ -47,7 +47,9 @@
       ;;  'scheme-per-load-static
       ;;  'label
       ;;  'prim
+      ;;  'prim-empty
       ;;  'prim-case
+      ;;  'prim-case-empty
       ;;  'begin0-saver
       ;;  'wcm-saver
       (define-struct rep:pointer (to))
@@ -199,8 +201,12 @@
 				      (make-rep:struct-field 'prim
 							     'prim
 							     (if (= 1 (length (procedure-code-case-codes code)))
-								 (make-rep:atomic 'prim)
+								 (if struct
-								 (make-rep:atomic 'prim-case))))]
+								     (make-rep:atomic 'prim)
+								     (make-rep:atomic 'prim-empty))
+								 (if struct
+								     (make-rep:atomic 'prim-case)
+								     (make-rep:atomic 'prim-case-empty)))))]
 				    [else
 				     (compiler:internal-error
 				      #f

collects/compiler/private/vm2c.ss

@@ -183,23 +183,28 @@
 
       (define (vm->c:emit-symbol-definitions! port)
 	(unless (zero? (const:get-symbol-counter))
-	  (fprintf port "  int i;~n")
+	  (fprintf port "  int i;\n  Scheme_Object *s;\n")
-	  (fprintf port "  for (i = ~a; i--; )~n    SYMBOLS[i] = scheme_intern_exact_symbol(SYMBOL_STRS[i], SYMBOL_LENS[i]);~n"
+	  (fprintf port "  for (i = ~a; i--; ) {\n"
 		   (const:get-symbol-counter))
+	  (fprintf port "    s = scheme_intern_exact_symbol(SYMBOL_STRS[i], SYMBOL_LENS[i]);\n")
+	  (fprintf port "    SYMBOLS[i] = s; \n   }\n")
 	  ;; Some symbols might be uninterned...
 	  (hash-table-for-each
 	   (const:get-symbol-table)
 	   (lambda (sym b)
 	     (unless (interned? sym)
 	       (let ([pos (zodiac:varref-var b)])
-		 (fprintf port "  SYMBOLS[~a] = scheme_make_exact_symbol(SYMBOL_STRS[~a], SYMBOL_LENS[~a]); /* uninterned */~n"
+		 (fprintf port "  s = scheme_make_exact_symbol(SYMBOL_STRS[~a], SYMBOL_LENS[~a]); /* uninterned */~n"
-			  pos pos pos)))))))
+			  pos pos)
+		 (fprintf port "  SYMBOLS[~a] = s;\n" pos)))))))
 
       (define (vm->c:emit-inexact-definitions! port)
 	(unless (zero? (const:get-inexact-counter))
-	  (fprintf port "  int i;~n")
+	  (fprintf port "  int i;\n  Scheme_Object *n;\n")
-	  (fprintf port "  for (i = ~a; i--; )~n    INEXACTS[i] = scheme_make_double(INEXACT_NUMBERS[i]);~n"
+	  (fprintf port "  for (i = ~a; i--; ) {\n"
-		   (const:get-inexact-counter))))
+		   (const:get-inexact-counter))
+	  (fprintf port "    n = scheme_make_double(INEXACT_NUMBERS[i]);\n")
+	  (fprintf port "    INEXACTS[i] = n; \n   }\n")))
 
       (define vm->c:emit-prim-ref-declarations!
 	(lambda (port)
@@ -255,6 +260,7 @@
 
       (define (emit-static-variable-fields! port l)
 	(unless (null? l)
+	  (fprintf port "#ifndef MZ_PRECISE_GC~n")
 	  (fprintf port "  /* Write fields as an array to help C compilers */~n")
 	  (fprintf port "  /* that don't like really big records. */~n")
 	  (fprintf port "  Scheme_Object * _consts_[~a];~n" (length l))
@@ -262,7 +268,13 @@
 	    (unless (null? l)
 	      (fprintf port "# define ~a _consts_[~a]~n"
 		       (vm->c:convert-symbol (car l)) n)
-	      (svloop (cdr l) (add1 n))))))
+	      (svloop (cdr l) (add1 n))))
+	  (fprintf port "#else~n")
+	  (for-each (lambda (c)
+		      (fprintf port "  Scheme_Object * ~a;~n"
+			       (vm->c:convert-symbol c)))
+		    l)
+	  (fprintf port "#endif~n")))
 
       ;; when statics have binding information, this will look more like 
       ;; emit-local-variable-declarations!
@@ -430,18 +442,18 @@
 			      (procedure-vehicle-max-args vehicle)
 			      0)])
 	    (when (> max-arity 0)
-					; emit declaration of argument stack 
+	      ;; emit declaration of argument stack 
 	      (fprintf port "~aScheme_Object * arg[~a];~n" 
 		       vm->c:indent-spaces 
 		       max-arity))
 	    (when (> max-args 0)
-					; emit declaration of global variables for argument passing
+	      ;; emit declaration of global variables for argument passing
 	      (let loop ([n 0])
 		(unless (= n max-args)
 		  (fprintf port "~aregister long reg~a;~n" vm->c:indent-spaces n)
 		  (loop (+ n 1)))))
 	    (when (> max-arity 0)
-					; tail-buffer-setup
+	      ;; tail-buffer-setup
 	      (fprintf port "~aScheme_Object ** tail_buf;~n"
 		       vm->c:indent-spaces)))
 
@@ -452,10 +464,10 @@
 		 (vm->c:emit-local-variable-declarations! locals vm->c:indent-spaces port)))
 	     (vehicle-lambdas vehicle)))
 	  
-					; emit jump to function...
+	  ;; emit jump to function...
 	  (when (> (vehicle-total-labels vehicle) 1)
-					; emit switch dispatcher
+	    ;; emit switch dispatcher
-	    (fprintf port "~aswitch(*(unsigned int*)void_param)~n~a{ " 
+	    (fprintf port "~aswitch(MZC_PARAM_TO_SWITCH(void_param))~n~a{ " 
 		     vm->c:indent-spaces
 		     vm->c:indent-spaces )
 	    (let loop ([n 0])
@@ -482,8 +494,10 @@
 				[(scheme-bucket) "Scheme_Bucket *"]
 				[(scheme-per-load-static) "struct Scheme_Per_Load_Statics *"]
 				[(label) "int"]
-				[(prim) "Scheme_Closed_Primitive_Proc"]
+				[(prim) "Scheme_Closed_Primitive_Post_Proc"]
-				[(prim-case) "Scheme_Closed_Case_Primitive_Proc"]
+				[(prim-empty) "Scheme_Closed_Primitive_Proc"]
+				[(prim-case) "Scheme_Closed_Case_Primitive_Post_Proc"]
+				[(prim-case-empty) "Scheme_Closed_Case_Primitive_Proc"]
 				[(begin0-saver) "_Scheme_Begin0_Rec"]
 				[(wcm-saver) "_Scheme_WCM_Rec"]
 				[else (compiler:internal-error 
@@ -505,8 +519,19 @@
 	(lambda (rep)
 	  (let ([s (if (rep:struct? rep)
 		       (string-append "struct " (vm->c:convert-symbol (rep:struct-name rep)))
-		       (vm->c:convert-type-definition rep))])
+		       (vm->c:convert-type-definition rep))]
-	  (format "(~a *)scheme_malloc(sizeof(~a))" s s))))
+		[tagged (if (let tagged? ([rep rep])
+			      (or (and (rep:atomic? rep) 
+				       (memq (rep:atomic-type rep)
+					     '(prim prim-empty prim-case prim-case-empty)))
+				  (and (rep:struct? rep)
+				       (pair? (rep:struct-fields rep))
+				       (tagged? (car (rep:struct-fields rep))))
+				  (and (rep:struct-field? rep)
+				       (tagged? (rep:struct-field-rep rep)))))
+			    "_tagged"
+			    "")])
+	  (format "(~a *)scheme_malloc~a(sizeof(~a))" s tagged s))))
 
       (define vm->c:emit-local-variable-declarations!
 	(lambda (locals indent port)
@@ -617,7 +642,7 @@
 			     (get-dest n)
 			     (get-cast n #f)))
 		  (fprintf port 
-			   "~a~a~a = ~ascheme_build_list(argc-~a, argv+~a);~n"
+			   "~a~a~a = ~ascheme_build_list_offset(argc, argv, ~a);~n"
 			   indent
 			   (if (dest-boxed? n)
 			       "*(Scheme_Object * *)" 
@@ -626,7 +651,6 @@
 			   (if (dest-boxed? n)
 			       ""
 			       (get-cast n #t))
-			   n
 			   n)
 
 		  (loop (cdr args) (sub1 n) #f)]))))))
@@ -820,10 +844,13 @@
 	    
 	    (let ([r (closure-code-rep code)])
 	      (when r
-					; (fprintf port "~aconst ~a * env;~n" indent (vm->c:convert-type-definition r))
+		;; (fprintf port "~aconst ~a * env;~n" indent (vm->c:convert-type-definition r))
-		(fprintf port "#~adefine env ((const ~a *)void_param)~n" indent (vm->c:convert-type-definition r))))
+		(fprintf port "#~adefine env MZC_ENV_POINTER(~a, ~a, void_param)~n" 
+			 indent 
+			 (vm->c:convert-type-definition r)
+			 (vm->c:convert-type-definition (closure-code-alloc-rep code)))))
 	    
-					; Registers into local vars
+	    ;; Registers into local vars
 	    (let* ([args (zodiac:arglist-vars (list-ref (zodiac:case-lambda-form-args L) which))])
 	      (vm->c:extract-arguments-into-variables!
 	       args
@@ -1105,7 +1132,7 @@
 			(process-set! (car vars) val #t)
 			
 			(begin
-			  (emit "{ Scheme_Object * res = ")
+			  (emit "{ Scheme_Object * res; res = ")
 			  (process val indent-level #f #t)
 			  (emit "; ")
 			  (unless return-arity-ok?
@@ -1366,7 +1393,7 @@
 		(emit-expr "")
 		(when (vm:apply-simple-tail-prim? ast)
 		  (emit "return "))
-		(emit "_scheme_~a("
+		(emit "_mzc_~a("
 		      (let ([v (global-defined-value* (vm:apply-prim ast))])
 			(cond
 			 [(and (primitive-closure? v) 

collects/compiler/sig.ss

@@ -22,6 +22,9 @@
    
       clean-intermediate-files ; #t => keep intermediate .c/.o files
                                ; default = #f
+
+      3m ; #t => build for 3m
+         ; default = #f
    
       compile-subcollections   ; #t => use 'compile-subcollections
                                ;  from infor for collection compiling

collects/compiler/start.ss

@@ -56,8 +56,6 @@
   (define plt-setup-collections (make-parameter null))
   (define plt-include-compiled (make-parameter #f))
 
-  (define use-3m (make-parameter #f))
-
   (define (extract-suffix appender)
     (bytes->string/latin-1
      (subbytes
@@ -144,7 +142,7 @@
 	 ,(lambda (f) (module-mode #t))
 	 ("Skip eval of top-level syntax, etc. for -e/-c/-o/-z")]
 	[("--3m")
-	 ,(lambda (f) (use-3m #t))
+	 ,(lambda (f) (compiler:option:3m #t))
 	 ("Compile/link for 3m, with -e/-c/-o/etc.")]
 	[("--embedded")
 	 ,(lambda (f) (compiler:option:compile-for-embedded #t))
@@ -167,7 +165,7 @@
 	    (auto-dest-dir #t))
 	 (,(format "Output -z to \"compiled\", -e to ~s"
 		   (path->string
-		    (build-path "compiled" "native" (system-library-subpath)))))]]
+		    (build-path "compiled" "native" (system-library-subpath #f)))))]]
 
        [help-labels
 	"------------------- compiler/linker configuration flags ---------------------"]
@@ -385,7 +383,7 @@
 		   (void)))))))
      (list "file/directory/collection" "file/directory/sub-collection")))
 
-  (printf "MzScheme compiler (mzc) version ~a, Copyright (c) 2005 PLT Scheme, Inc.~n"
+  (printf "mzc version ~a, Copyright (c) 2004-2005 PLT Scheme Inc.~n"
 	  (version))
 
   (define-values (mode source-files prefix)
@@ -399,7 +397,7 @@
     (when (compiler:option:compile-for-embedded)
       (error 'mzc "cannot ~a an extension for an embedded MzScheme" action)))
   
-  (when (use-3m)
+  (when (compiler:option:3m)
     (link-variant '3m)
     (compile-variant '3m))
   

collects/compiler/to-core.ss

@@ -11,14 +11,15 @@
   ;;  `require-for-syntax', it's a timing issue. For `module', it's
   ;;  because the transformation can only handle a single `module'
   ;;  declaration.
-  (define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx simple-constant?)
+  (define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx 
+			     simple-constant? stop-properties)
     (syntax-case stx (module begin)
       [(module m lang (plain-module-begin decl ...))
        (let-values ([(expr new-decls magic-sym) 
                      (lift-sequence (flatten-decls (syntax->list #'(decl ...)))
                                     lookup-stx set-stx safe-vector-ref-stx extract-stx
                                     #t
-				    simple-constant?)])
+				    simple-constant? stop-properties)])
          (values (expand-syntax expr)
                  #`(module m lang (#%plain-module-begin #,@new-decls))
 		 magic-sym))]
@@ -27,13 +28,13 @@
                      (lift-sequence (flatten-decls (syntax->list #'(decl ...)))
                                     lookup-stx set-stx safe-vector-ref-stx extract-stx
                                     #f
-				    simple-constant?)])
+				    simple-constant? stop-properties)])
          (values (expand-syntax expr)
                  #`(begin #,@new-decls)
 		 magic-sym))]
       [else
        (top-level-to-core #`(begin #,stx) lookup-stx set-stx safe-vector-ref-stx extract-stx
-			  simple-constant?)]))
+			  simple-constant? stop-properties)]))
   
   (define (flatten-decls l)
     (apply append
@@ -117,7 +118,7 @@
 		  (module-identifier=? #'case-lambda (stx-car rhs))))))
 
   (define (lift-sequence decls lookup-stx set-stx safe-vector-ref-stx extract-stx 
-			 in-module? simple-constant?)
+			 in-module? simple-constant? stop-properties)
     (let ([ct-vars (make-vars)]
           [rt-vars (make-vars)]
           [compile-time (datum->syntax-object #f (gensym 'compile-time))]
@@ -133,7 +134,7 @@
                                                    lookup-stx set-stx safe-vector-ref-stx
                                                    compile-time ct-vars
                                                    in-module?
-						   simple-constant?)])
+						   simple-constant? stop-properties)])
                                (if (and (not in-module?)
                                         (module-identifier=? #'def #'define-syntaxes))
                                    ;; Don't try to name macro procedures, because it
@@ -158,7 +159,7 @@
 						 lookup-stx set-stx safe-vector-ref-stx
 						 run-time rt-vars
 						 in-module?
-						 simple-constant?)])
+						 simple-constant? stop-properties)])
 			 (if (need-thunk? #'rhs)
 			     #`(lambda () #,converted)
 			     #`(let-values ([ids #,converted])
@@ -169,7 +170,7 @@
 				      lookup-stx set-stx safe-vector-ref-stx
 				      run-time rt-vars
 				      in-module?
-				      simple-constant?))]))
+				      simple-constant? stop-properties))]))
 		  (filter is-run-time? decls))]
             [ct-rhs #`((let ([magic (car (cons '#,magic-sym 2))])
                          (if (symbol? magic) 
@@ -325,79 +326,108 @@
   (define (add-identifier stx li trans? lookup-stx id)
     #`(#,lookup-stx #,id #,(add-identifier/pos stx li trans?)))
 
-  (define (convert stx trans? lookup-stx set-stx safe-vector-ref-stx id li in-module? simple-constant?)
+  (define-syntax quasisyntax/loc+props
+    (syntax-rules ()
+      [(_ stx e) (let ([old-s stx]
+		       [new-s (quasisyntax e)])
+		   (syntax-recertify
+		    (datum->syntax-object new-s
+					  (syntax-e new-s)
+					  old-s
+					  old-s)
+		    new-s
+		    code-insp
+		    #f))]))
+  (define code-insp (current-code-inspector))
+
+  (define (convert stx trans? lookup-stx set-stx safe-vector-ref-stx id li in-module? 
+		   simple-constant? stop-properties)
     (define ((loop certs) stx)
       (let ([loop (loop (apply-certs stx certs))])
-        (kernel-syntax-case stx trans?
+	(if (ormap (lambda (prop)
-          [_
+		     (syntax-property stx prop))
-           (identifier? stx)
+		   stop-properties)
-           (or (simple-identifier stx trans?)
+	    stx
-               (add-identifier (apply-certs certs stx) li trans? lookup-stx id))]
+	    (kernel-syntax-case stx trans?
-          [(provide . _)
+	      [_
-           stx]
+	       (identifier? stx)
-          [(lambda formals e ...)
+	       (or (simple-identifier stx trans?)
-           (quasisyntax/loc stx
+		   (add-identifier (apply-certs certs stx) li trans? lookup-stx id))]
-             (lambda formals #,@(map loop (syntax->list #'(e ...)))))]
+	      [(provide . _)
-          [(case-lambda [formals e ...] ...)
+	       stx]
-           (with-syntax ([((e ...) ...)
+	      [(lambda formals e ...)
-                          (map (lambda (l)
+	       (quasisyntax/loc+props 
-                                 (map loop (syntax->list l)))
+		stx
-                               (syntax->list #'((e ...) ...)))])
+		(lambda formals #,@(map loop (syntax->list #'(e ...)))))]
-             (quasisyntax/loc stx
+	      [(case-lambda [formals e ...] ...)
-               (case-lambda [formals e ...] ...)))]
+	       (with-syntax ([((e ...) ...)
-          [(let-values ([(id ...) rhs] ...) e ...)
+			      (map (lambda (l)
-           (with-syntax ([(rhs ...)
+				     (map loop (syntax->list l)))
-                          (map loop (syntax->list #'(rhs ...)))])
+				   (syntax->list #'((e ...) ...)))])
-             (quasisyntax/loc stx
+		 (quasisyntax/loc+props 
-               (let-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))]
+		  stx
-          [(letrec-values ([(id ...) rhs] ...) e ...)
+		  (case-lambda [formals e ...] ...)))]
-           (with-syntax ([(rhs ...)
+	      [(let-values ([(id ...) rhs] ...) e ...)
-                          (map loop (syntax->list #'(rhs ...)))])
+	       (with-syntax ([(rhs ...)
-             (quasisyntax/loc stx
+			      (map loop (syntax->list #'(rhs ...)))])
-               (letrec-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))]
+		 (quasisyntax/loc+props 
-          [(quote e)
+		  stx
-           (if (simple-constant? #'e)
+		  (let-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))]
-               #'(quote e)
+	      [(letrec-values ([(id ...) rhs] ...) e ...)
-               (add-literal stx li safe-vector-ref-stx id))]
+	       (with-syntax ([(rhs ...)
-          [(quote-syntax e)
+			      (map loop (syntax->list #'(rhs ...)))])
-           (add-literal stx li safe-vector-ref-stx id)]
+		 (quasisyntax/loc+props 
-          [(#%top . tid)
+		  stx
-           (let ([target (let ([b ((if trans?
+		  (letrec-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))]
-                                       identifier-transformer-binding
+	      [(quote e)
-                                       identifier-binding)
+	       (if (simple-constant? #'e)
-                                   #'tid)])
+		   #'(quote e)
-                           (if (or (eq? b 'lexical) 
+		   (add-literal stx li safe-vector-ref-stx id))]
-                                   (and (not in-module?)
+	      [(quote-syntax e)
-                                        b))
+	       (add-literal stx li safe-vector-ref-stx id)]
-                               #`(#%top . tid)
+	      [(#%top . tid)
-                               #'tid))])
+	       (let ([target (let ([b ((if trans?
-             (add-identifier (apply-certs certs target) li trans? lookup-stx id))]
+					   identifier-transformer-binding
-          [(#%datum . e)
+					   identifier-binding)
-           (if (simple-constant? #'e)
+				       #'tid)])
-               #'(#%datum . e)
+			       (if (or (eq? b 'lexical) 
-               (add-literal stx li safe-vector-ref-stx id))]
+				       (and (not in-module?)
-          [(set! x e)
+					    b))
-           (if (local-identifier? #'x trans?)
+				   #`(#%top . tid)
-               (quasisyntax/loc stx (set! x #,(loop #'e)))
+				   #'tid))])
-               (quasisyntax/loc stx
+		 (add-identifier (apply-certs certs target) li trans? lookup-stx id))]
-                 (#,set-stx #,id #,(add-identifier/pos (apply-certs certs #'x) li trans?) #,(loop #'e))))]
+	      [(#%datum . e)
-          [(#%variable-reference e)
+	       (if (simple-constant? #'e)
-           (add-literal stx li)]
+		   #'(#%datum . e)
-          [(if e ...)
+		   (add-literal stx li safe-vector-ref-stx id))]
-           (quasisyntax/loc stx
+	      [(set! x e)
-             (if #,@(map loop (syntax->list #'(e ...)))))]
+	       (if (local-identifier? #'x trans?)
-          [(begin e ...)
+		   (quasisyntax/loc+props stx (set! x #,(loop #'e)))
-           (quasisyntax/loc stx
+		   (quasisyntax/loc+props 
-             (begin #,@(map loop (syntax->list #'(e ...)))))]
+		    stx
-          [(begin0 e ...)
+		    (#,set-stx #,id #,(add-identifier/pos (apply-certs certs #'x) li trans?) #,(loop #'e))))]
-           (quasisyntax/loc stx
+	      [(#%variable-reference e)
-             (begin0 #,@(map loop (syntax->list #'(e ...)))))]
+	       (add-literal stx li)]
-          [(with-continuation-mark e ...)
+	      [(if e ...)
-           (quasisyntax/loc stx
+	       (quasisyntax/loc+props 
-             (with-continuation-mark #,@(map loop (syntax->list #'(e ...)))))]
+		stx
-          [(#%app e ...)
+		(if #,@(map loop (syntax->list #'(e ...)))))]
-           (quasisyntax/loc stx
+	      [(begin e ...)
-             (#%app #,@(map loop (syntax->list #'(e ...)))))])))
+	       (quasisyntax/loc+props 
+		stx
+		(begin #,@(map loop (syntax->list #'(e ...)))))]
+	      [(begin0 e ...)
+	       (quasisyntax/loc+props 
+		stx
+		(begin0 #,@(map loop (syntax->list #'(e ...)))))]
+	      [(with-continuation-mark e ...)
+	       (quasisyntax/loc+props 
+		stx
+		(with-continuation-mark #,@(map loop (syntax->list #'(e ...)))))]
+	      [(#%app e ...)
+	       (quasisyntax/loc+props 
+		stx
+		(#%app #,@(map loop (syntax->list #'(e ...)))))]))))
     ((loop #'certs) stx))
   
   (define (apply-certs from to)

src/mzscheme/include/mzscheme.exp

@@ -454,6 +454,7 @@ scheme_equal
 scheme_equal_hash_key
 scheme_equal_hash_key2
 scheme_build_list
+scheme_build_list_offset
 scheme_make_list_immutable
 scheme_list_length
 scheme_proper_list_length

src/mzscheme/include/mzscheme3m.exp

@@ -462,6 +462,7 @@ scheme_hash_key
 scheme_equal_hash_key
 scheme_equal_hash_key2
 scheme_build_list
+scheme_build_list_offset
 scheme_make_list_immutable
 scheme_list_length
 scheme_proper_list_length

src/mzscheme/include/mzwin.def

@@ -446,6 +446,7 @@ EXPORTS
  scheme_equal_hash_key
  scheme_equal_hash_key2
  scheme_build_list
+ scheme_build_list_offset
  scheme_make_list_immutable
  scheme_list_length
  scheme_proper_list_length

src/mzscheme/include/scheme.h

@@ -573,6 +573,7 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
 #define SCHEME_PRIM_IS_GENERIC 512
 #define SCHEME_PRIM_IS_USER_PARAMETER 1024
 #define SCHEME_PRIM_IS_METHOD 2048
+#define SCHEME_PRIM_IS_POST_DATA 4096
 
 typedef struct Scheme_Object *
 (Scheme_Prim)(int argc, struct Scheme_Object *argv[]);
@@ -608,13 +609,58 @@ typedef struct {
 
 typedef struct {
   Scheme_Closed_Primitive_Proc p;
-  mzshort minr, maxr;
+  mzshort *cases;
-} Scheme_Closed_Prim_W_Result_Arity;
+} Scheme_Closed_Case_Primitive_Proc;
 
 typedef struct {
   Scheme_Closed_Primitive_Proc p;
-  mzshort *cases;
+  mzshort minr, maxr;
-} Scheme_Closed_Case_Primitive_Proc;
+} Scheme_Closed_Prim_W_Result_Arity;
+
+/* ------------------------------------------------- */
+/*                 mzc closure glue
+    The following structures 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 {
+  union {
+    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, \
@@ -626,6 +672,16 @@ typedef struct {
    (rec)->pp.flags = flgs, \
    rec)
 
+#ifdef MZ_PRECISE_GC
+# define _scheme_fill_prim_closure_post(rec, cfunc, dt, nm, amin, amax, flgs, ln) \
+  ((rec)->len = ln,							\
+   _scheme_fill_prim_closure(&(rec)->u.p, cfunc, dt, nm, amin, amax,	\
+			     flgs | SCHEME_PRIM_IS_POST_DATA))
+#else
+# define _scheme_fill_prim_closure_post(rec, cfunc, dt, nm, amin, amax, flgs, ln) \
+  _scheme_fill_prim_closure(&(rec)->u.p, cfunc, dt, nm, amin, amax, flgs)
+#endif
+
 #define _scheme_fill_prim_case_closure(rec, cfunc, dt, nm, ccount, cses, flgs) \
   ((rec)->p.pp.so.type = scheme_closed_prim_type, \
    (rec)->p.prim_val = cfunc, \
@@ -637,6 +693,18 @@ typedef struct {
    (rec)->cases = cses, \
    rec)
 
+#ifdef MZ_PRECISE_GC
+# define _scheme_fill_prim_case_closure_post(rec, cfunc, dt, nm, ccount, cses, flgs, ln) \
+  ((rec)->len = ln,							\
+   _scheme_fill_prim_case_closure(&(rec)->u.p, cfunc, dt, nm, ccount, cses, \
+				  flgs | SCHEME_PRIM_IS_POST_DATA))
+#else
+# define _scheme_fill_prim_case_closure_post(rec, cfunc, dt, nm, ccount, cses, flgs, ln) \
+  _scheme_fill_prim_case_closure(&(rec)->u.p, cfunc, dt, nm, ccount, cses, flgs)
+#endif
+
+/* ------------------------------------------------- */
+
 #define SCHEME_PROCP(obj)  (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) >= scheme_prim_type) && (_SCHEME_TYPE(obj) <= scheme_proc_struct_type)))
 #define SCHEME_SYNTAXP(obj)  SAME_TYPE(SCHEME_TYPE(obj), scheme_syntax_compiler_type)
 #define SCHEME_PRIMP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_prim_type)

src/mzscheme/macglue.inc

@@ -1,117 +0,0 @@
-#ifndef NO_USER_BREAK_HANDLER
-# ifdef MAC_MZ_GUI_ENABLED
-
-extern void (*GC_out_of_memory)(void);
-
-static void MacOutOfMemory(void)
-{
-  Alert(101, NULL);
-  ExitToShell();
-}
-
-static int WeAreFront()
-{
-  static int inited;
-  static ProcessSerialNumber us;
-  ProcessSerialNumber front;
-  Boolean r;
-  
-  if (!inited) {
-    GetCurrentProcess(&us);
-    inited = 1;
-  }
-  GetFrontProcess(&front);
-  SameProcess(&us, &front, &r);
-  
-  return r;
-}
-
-static int is_break_event(EventRecord *e)
-{
-   if ((e->what == keyDown)
-       && ((((e->message & charCodeMask) == '.') 
-            && (e->modifiers & cmdKey))
-           || (((e->message & charCodeMask) == 3)
-	           && (e->modifiers & controlKey))))
-	 return 1;
-  else
-    return 0;
-}
-
-static int check_break_flag()
-{
-# ifdef MACINTOSH_GIVE_TIME
-  static long last_time;
-  static int front = 1;
-
-  if (TickCount() > last_time + (front ? 30 : 0)) {
-      EventRecord e;
-      front = WeAreFront();
-      while (WaitNextEvent(everyEvent, &e, front ? 0 : 30, NULL)) {
-        if (is_break_event(&e)) {
-	       return 1;
-	     }
-#  ifdef MACINTOSH_SIOUX
-        SIOUXHandleOneEvent(&e);
-#  endif
-       }
-      last_time = TickCount();
-    }
-# endif
-    return 0;
-}
-
-static void handle_one(EventRecord *e)
-{
-  if (is_break_event(e))
-    scheme_break_thread(NULL);
-  
-#  ifdef MACINTOSH_SIOUX
-  SIOUXHandleOneEvent(e);
-#  endif
-}
-
-static void MacSleep(float secs, void *fds)
-{
-   EventRecord e;
-   if (WaitNextEvent(everyEvent, &e, secs * 60, NULL)) {
-     if (is_break_event(&e))
-       scheme_break_thread(NULL);
-     
-     handle_one(&e);
-   }
-}
-
-# endif
-
-#endif
-
-#ifdef MAC_MZ_GUI_ENABLED
-
-void Drop_Runtime(char **argv, int argc)
-{
-  int i;
-	
-  for (i = 0; i < argc; i++) {
-    printf("(load \"%s\") ", argv[i]);
-  }
-  if (argc) printf("\n");
-}
-
-void Drop_Quit()
-{
-  ExitToShell();
-}
-
-#endif
-
-#ifndef DONT_PARSE_COMMAND_LINE
-
-# ifdef MACINTOSH_SIOUX
-static void SetSIOUX(void)
-{
-  SIOUXSettings.initializeTB = 0;
-}
-# endif
-
-#endif /* DONT_PARSE_COMMAND_LINE */

src/mzscheme/main.c

@@ -150,12 +150,6 @@ extern Scheme_Object *scheme_initialize(Scheme_Env *env);
 
 #include "cmdline.inc"
 
-/*========================================================================*/
-/*                            MacOS glue                                  */
-/*========================================================================*/
-
-#include "macglue.inc"
-
 /*========================================================================*/
 /*                             OSKit glue                                 */
 /*========================================================================*/

src/mzscheme/src/list.c

@@ -565,6 +565,18 @@ Scheme_Object *scheme_build_list(int size, Scheme_Object **argv)
   return pair;
 }
 
+Scheme_Object *scheme_build_list_offset(int size, Scheme_Object **argv, int delta)
+{
+  Scheme_Object *pair = scheme_null;
+  int i;
+
+  for (i = size; i-- > delta; ) {
+    pair = scheme_make_pair(argv[i], pair);
+  }
+
+  return pair;
+}
+
 Scheme_Object *scheme_alloc_list(int size)
 {
   Scheme_Object *pair = scheme_null;

src/mzscheme/src/mzmark.c

@@ -680,8 +680,14 @@ 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)
-      ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
+      ? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
-      : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
+	 ? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_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)))));
 }
 
 int closed_prim_proc_MARK(void *p) {
@@ -689,13 +695,39 @@ 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);
+  }
   
   return
   ((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
    ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
    : ((c->mina == -2)
-      ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
+      ? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
-      : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
+	 ? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_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)))));
 }
 
 int closed_prim_proc_FIXUP(void *p) {
@@ -703,13 +735,39 @@ 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);
+  }
   
   return
   ((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
    ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
    : ((c->mina == -2)
-      ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
+      ? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
-      : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
+	 ? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_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

@@ -253,13 +253,39 @@ 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);
+  }
   
  size:
   ((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
    ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
    : ((c->mina == -2)
-      ? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
+      ? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
-      : gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
+	 ? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_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/schemef.h

@@ -914,6 +914,7 @@ MZ_EXTERN long scheme_equal_hash_key(Scheme_Object *o);
 MZ_EXTERN long scheme_equal_hash_key2(Scheme_Object *o);
 
 MZ_EXTERN Scheme_Object *scheme_build_list(int argc, Scheme_Object **argv);
+MZ_EXTERN Scheme_Object *scheme_build_list_offset(int argc, Scheme_Object **argv, int delta);
 MZ_EXTERN void scheme_make_list_immutable(Scheme_Object *l);
 
 MZ_EXTERN int scheme_list_length(Scheme_Object *list);

src/mzscheme/src/schemex.h

@@ -752,6 +752,7 @@ long (*scheme_hash_key)(Scheme_Object *o);
 long (*scheme_equal_hash_key)(Scheme_Object *o);
 long (*scheme_equal_hash_key2)(Scheme_Object *o);
 Scheme_Object *(*scheme_build_list)(int argc, Scheme_Object **argv);
+Scheme_Object *(*scheme_build_list_offset)(int argc, Scheme_Object **argv, int delta);
 void (*scheme_make_list_immutable)(Scheme_Object *l);
 int (*scheme_list_length)(Scheme_Object *list);
 int (*scheme_proper_list_length)(Scheme_Object *list);

src/mzscheme/src/schemex.inc

@@ -506,6 +506,7 @@
   scheme_extension_table->scheme_equal_hash_key = scheme_equal_hash_key;
   scheme_extension_table->scheme_equal_hash_key2 = scheme_equal_hash_key2;
   scheme_extension_table->scheme_build_list = scheme_build_list;
+  scheme_extension_table->scheme_build_list_offset = scheme_build_list_offset;
   scheme_extension_table->scheme_make_list_immutable = scheme_make_list_immutable;
   scheme_extension_table->scheme_list_length = scheme_list_length;
   scheme_extension_table->scheme_proper_list_length = scheme_proper_list_length;

src/mzscheme/src/schemexm.h

@@ -506,6 +506,7 @@
 #define scheme_equal_hash_key (scheme_extension_table->scheme_equal_hash_key)
 #define scheme_equal_hash_key2 (scheme_extension_table->scheme_equal_hash_key2)
 #define scheme_build_list (scheme_extension_table->scheme_build_list)
+#define scheme_build_list_offset (scheme_extension_table->scheme_build_list_offset)
 #define scheme_make_list_immutable (scheme_extension_table->scheme_make_list_immutable)
 #define scheme_list_length (scheme_extension_table->scheme_list_length)
 #define scheme_proper_list_length (scheme_extension_table->scheme_proper_list_length)