350.2

svn: r3496

collects/compiler/private/xform.ss

@@ -672,6 +672,7 @@
           (printf "#define NULL_OUT_ARRAY(a) memset(a, 0, sizeof(a))~n")
           ;; Annotation that normally disappears:
           (printf "#define GC_CAN_IGNORE /**/~n")
+          (printf "#define __xform_nongcing__ /**/~n")
           ;; Another annotation to protect against GC conversion:
           (printf "#define HIDE_FROM_XFORM(x) x~n")
           (printf "#define HIDE_NOTHING_FROM_XFORM() /**/~n")
@@ -830,21 +831,24 @@
                       non-functions)
             ht))
         
-        (define non-gcing-functions
+        (define non-gcing-builtin-functions
           ;; The following don't need wrappers, but we need to check for
           ;;  nested function calls because it takes more than one argument:
           (append
            '(memcpy memmove
                     strcmp strcoll strcpy _mzstrcpy strcat memset
                     printf sprintf vsprintf vprintf
-                    strncmp scheme_strncmp
+                    strncmp
-                    read write
+                    read write)
-                    bigdig_length)
            (map
             string->symbol
             '("XTextExtents" "XTextExtents16" 
                              "XDrawImageString16" "XDrawImageString"
                              "XDrawString16" "XDrawString"))))
+	(define non-gcing-functions (make-hash-table))
+	(for-each (lambda (name)
+		    (hash-table-put! non-gcing-functions name #t))
+		  non-gcing-builtin-functions)
         
         (define non-returning-functions
           ;; The following functions never return, so the wrappers
@@ -991,7 +995,9 @@
             
             (set! pointer-types (list-ref l 4))
             (set! non-pointer-types (list-ref l 5))
-            (set! struct-defs (list-ref l 6))))
+            (set! struct-defs (list-ref l 6))
+
+	    (set! non-gcing-functions (hash-table-copy (list-ref l 7)))))
         
         ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         ;; Pretty-printing output
@@ -1335,6 +1341,8 @@
                    e))]
             [(proc-prototype? e)
              (let ([name (register-proto-information e)])
+               (when (eq? (tok-n (car e)) '__xform_nongcing__)
+		 (hash-table-put! non-gcing-functions name #t))
 	       (when show-info?
                  (printf "/* PROTO ~a */~n" name))
                (if (or precompiling-header?
@@ -1367,6 +1375,8 @@
                          e))))]
             [(function? e)
              (let ([name (register-proto-information e)])
+	       (when (eq? (tok-n (car e)) '__xform_nongcing__)
+		 (hash-table-put! non-gcing-functions name #t))
                (when show-info? (printf "/* FUNCTION ~a */~n" name))
                (if (or (positive? suspend-xform)
                        (not pgc?)
@@ -1587,7 +1597,9 @@
                (let ([name (tok-n (car e))]
                      [type (let loop ([t (reverse type)])
                              (if (pair? t)
-                                 (if (memq (tok-n (car t)) '(extern static inline virtual __stdcall __cdecl _inline __inline __inline__))
+                                 (if (memq (tok-n (car t)) '(extern static virtual __stdcall __cdecl 
+								    inline _inline __inline __inline__
+								    __xform_nongcing__))
                                      (loop (cdr t))
                                      (cons (car t) (loop (cdr t))))
                                  t))]
@@ -2088,6 +2100,7 @@
         ;; Temporary state used during a conversion:
         (define used-self? #f)
         (define important-conversion? #f)
+	(define saw-gcing-call #f)
         
         (define (new-vars->decls vars)
           (apply
@@ -2186,6 +2199,7 @@
                (seq-close body-v)
                (let-values ([(orig-body-e) (begin
                                              (set! important-conversion? #f)
+                                             (set! saw-gcing-call #f)
                                              body-e)]
                             [(body-e live-vars)
                              ;; convert-body does most of the conversion work, and also
@@ -2247,14 +2261,26 @@
                                             e
                                             (lambda (name class-name type args static?)
                                               type)))])
+		 (if (hash-table-get non-gcing-functions name (lambda () #f))
+		     (when saw-gcing-call
+		       (log-error "[GCING] ~a in ~a: Function ~a declared __xform_nongcing__, but includes a function call."
+				  (tok-line saw-gcing-call) (tok-file saw-gcing-call)
+				  name))
+		     (unless saw-gcing-call
+		       '
+		       (fprintf (current-error-port)
+				"[SUGGEST] Consider declaring ~a as __xform_nongcing__.\n"
+				name)))
                  (if (and (not important-conversion?)
                           (not (and function-name
                                     (eq? class-name function-name)))
+			  (or (not saw-gcing-call)
+			      (and
 			       (null? (live-var-info-new-vars live-vars))
 			       (zero? (live-var-info-maxpush live-vars))
 			       (or (<= (live-var-info-num-calls live-vars) 1)
 				   (= (live-var-info-num-calls live-vars)
-                                 (live-var-info-num-noreturn-calls live-vars))))
+				      (live-var-info-num-noreturn-calls live-vars))))))
                      ;; No conversion necessary. (Lack of `call' records means no GC-setup
                      ;; work when printing out the function.)
                      (list->seq
@@ -3154,7 +3180,7 @@
                                     [(sub-memcpy?)
                                      ;; memcpy, etc. call?
                                      (and (pair? (cdr e-))
-                                          (memq (tok-n (cadr e-)) non-gcing-functions))]
+                                          (hash-table-get non-gcing-functions (tok-n (cadr e-)) (lambda () #f)))]
                                     [(args live-vars)
                                      (convert-paren-interior args vars &-vars
                                                              c++-class
@@ -3229,12 +3255,14 @@
                                          (live-var-info-nonempty-calls? live-vars)))])
                           (loop rest-
                                 (let ([call (if (and (null? (cdr func))
-                                                     (memq (tok-n (car func)) non-gcing-functions))
+                                                     (hash-table-get non-gcing-functions (tok-n (car func)) (lambda () #f)))
                                                 ;; Call without pointer pushes
                                                 (make-parens
                                                  "(" #f #f ")"
                                                  (list->seq (append func (list args))))
                                                 ;; Call with pointer pushes
+						(begin
+						  (set! saw-gcing-call (car e-))
 						  (make-call
 						   "func call"
 						   #f #f
@@ -3242,7 +3270,7 @@
 						   args
 						   pushed-vars
 						   (live-var-info-tag orig-live-vars)
-                                                 this-nonempty?))])
+						   this-nonempty?)))])
                                   (cons (if (null? setups)
                                             call
                                             (make-callstage-parens
@@ -3723,7 +3751,8 @@
                     
                     (marshall pointer-types)
                     (marshall non-pointer-types)
-                    (marshall struct-defs))])
+                    (marshall struct-defs)
+		    non-gcing-functions)])
               (with-output-to-file (change-suffix file-out #".zo")
                 (lambda ()
                   (write (compile e)))

collects/help/servlets/release/license.ss

@@ -96,4 +96,4 @@
 		("GNU lightning"
 		 "Copyright (c) 1994, 1995, 1996, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.")
 		("GNU Classpath"
-		 "Gnu Public Licence with special exception")))))))
+		 "GNU Public License with special exception")))))))

collects/honu-module/dynamic.ss

@@ -3,23 +3,15 @@
   (require-for-syntax (lib "stx.ss" "syntax")
 		      "private/ops.ss"
 		      "private/util.ss"
-		      (lib "kerncase.ss" "syntax"))
+		      (lib "kerncase.ss" "syntax")
+		      "private/contexts.ss")
   
   (begin-for-syntax
 
    (define kernel-forms (kernel-form-identifier-list #'here))
-
+   (define expand-stop-forms (list* #'honu-typed
-   (define (top-block-context? ctx) (memq ctx '(top-block)))
+				    #'honu-unparsed-block
-   (define (return-block-context? ctx) (memq ctx '(return-block)))
+				    kernel-forms))
-   (define (block-context? ctx) (memq ctx '(top-block block return-block)))
-   (define (expression-context? ctx) (memq ctx '(expression)))
-   (define (type-context? ctx) (memq ctx '(type)))
-
-   (define block-context 'block)
-   (define return-block-context 'return-block)
-   (define top-block-context 'top-block)
-   (define expression-context 'expression)
-   (define type-context 'type)
 
    ;; --------------------------------------------------------
    ;; Transformer procedure property and basic struct
@@ -63,6 +55,11 @@
 		(and (positive? (string-length str))
 		     (memq (string-ref str 0) sym-chars)))))))
 
+   (define (honu-identifier? stx)
+     (and (identifier? stx)
+	  (not (ormap (lambda (i) (module-identifier=? stx i)) (list #'\; #'\,)))
+	  (not (operator? stx))))
+   
    (define (get-transformer stx)
      (or (and (stx-pair? stx)
 	      (identifier? (stx-car stx))
@@ -104,21 +101,30 @@
 	 [((#%braces . block) . rest) (cons #'block #'rest)]
 	 [_else #f])
        => (lambda (b+r)
-	    (k #`(honu-unparsed-block #f void-type #f #,(return-block-context? ctx)
+	    (k #`(honu-unparsed-block #f obj #f #,(and (stx-null? (cdr b+r))
+						       (return-block-context? ctx))
 				      #,@(car b+r))
 	       (cdr b+r)))]
-      [else (let-values ([(expr-stxs after-expr) (extract-until body (list #'\;))])
+      [else (let-values ([(expr-stxs after-expr terminator) (extract-until body (list #'\;))])
 	      (unless expr-stxs
 		(raise-syntax-error
 		 #f
 		 "expected a semicolon to terminate form"
 		 (stx-car body)))
+	      (when (null? expr-stxs)
+		(raise-syntax-error
+		 #f
+		 "missing expression before terminator"
+		 terminator))
 	      (let ([code ((if (return-block-context? ctx)
 			       parse-a-tail-expr
 			       parse-an-expr)
 			   expr-stxs)])
 		(k ((if (top-block-context? ctx) 
-			(lambda (x) `(printf "~s\n" ,x))
+			(lambda (x) 
+			  `(let ([v ,x])
+			     (unless (void? v)
+			       (printf "~s\n" v))))
 			values)
 		    code)
 		   (stx-cdr after-expr))))]))
@@ -136,12 +142,13 @@
    ;; Parsing expressions
 
    (define parse-expr
+     ;; The given syntax sequence must not be empty
      (let ()
        (define (parse-expr-seq stx)
 	 (define (start-expr stx) 
 	   (let ([trans (get-transformer stx)])
 	     (if trans
-		 (let-values ([(expr rest) (trans stx expression-context)])
+		 (let-values ([(expr rest) (trans stx the-expression-context)])
 		   (if (stx-null? rest)
 		       (list expr)
 		       (cons expr (start-operator rest))))
@@ -169,7 +176,7 @@
 			 #f
 			 "missing expression inside braces"
 			 (stx-car stx))
-			(list #'(honu-unparsed-block #f void-type #f #f . pexpr)))]
+			(list #'(honu-unparsed-block #f obj #f #f . pexpr)))]
 		   [(op . more)
 		    (and (identifier? #'op)
 			 (ormap (lambda (uop)
@@ -235,19 +242,19 @@
 		    [(prefix? op)
 		     (group (append (reverse (cdr before))
 				    (list (quasisyntax/loc (op-id op)
-					    (#,(op-id op) #,(car before))))
+					    (honu-app #,(op-id op) #,(car before))))
 				    (reverse since)))]
 		    [(postfix? op)
 		     (let ([after (reverse since)])
 		       (group (append (reverse before)
 				      (list (quasisyntax/loc (op-id op)
-					      (#,(op-id op) #,(car after))))
+					      (honu-app #,(op-id op) #,(car after))))
 				      (cdr after))))]
 		    [(infix? op)
 		     (let ([after (reverse since)])
 		       (group (append (reverse (cdr before))
 				      (list (quasisyntax/loc (op-id op)
-					      (#,(op-id op) #,(car before) #,(car after))))
+					      (honu-app #,(op-id op) #,(car before) #,(car after))))
 				      (cdr after))))]
 		    [else (error "not an op!: " op)])]
 		  [(not (op? (stx-car seq)))
@@ -265,7 +272,7 @@
        (define (parse-arg-list stxs)
 	 (if (stx-null? stxs)
 	     stxs
-	     (let-values ([(val-stxs after-expr) (extract-until stxs (list #'\,))])
+	     (let-values ([(val-stxs after-expr terminator) (extract-until stxs (list #'\,))])
 	       (when (and val-stxs
 			  (stx-null? (stx-cdr after-expr)))
 		 (raise-syntax-error
@@ -321,30 +328,30 @@
 		    [where-stx orig-args-stx])
 	   (let-values ([(type rest-stx) (if (syntax-case args-stx (\,)
 					       [(id \, . rest)
-						(identifier? #'id)
+						(honu-identifier? #'id)
 						#t]
 					       [(id)
-						(identifier? #'id)
+						(honu-identifier? #'id)
 						#t]
 					       [_else #f])
-					     (values (make-h-type #'val #'(begin) #'(lambda (x) (values #t x)))
+					     (values (make-h-type #'obj #'(begin) #'(lambda (x) (values #t x)))
 						     args-stx)
 					     (let ([trans (get-transformer args-stx)])
 					       (if trans
-						   (trans args-stx type-context)
+						   (trans args-stx the-type-context)
 						   (values #f #f))))])
 	     (unless (honu-type? type)
 	       (raise-syntax-error
 		'|procedure declaration|
-		(format "expected a type ~a" where)
+		(format "expected an identifier or type ~a, found something else" where)
 		where-stx))
 	     (syntax-case rest-stx ()
 	       [(id)
-		(identifier? #'id)
+		(honu-identifier? #'id)
 		(parse-one-argument proc-id type #'id
 				    (lambda () null))]
 	       [(id comma . rest)
-		(and (identifier? #'id)
+		(and (honu-identifier? #'id)
 		     (identifier? #'comma)
 		     (module-identifier=? #'comma #'\,))
 		(parse-one-argument proc-id type #'id
@@ -353,18 +360,18 @@
 					    "after comma"
 					    #'comma)))]
 	       [(id something . rest)
-		(identifier? #'id)
+		(honu-identifier? #'id)
 		(raise-syntax-error
 		 'procedure\ declaration
-		 "expected a comma after identifier name"
+		 "expected a comma after argument identifier, found something else"
 		 #'something)]
 	       [_else
 		(raise-syntax-error
 		 'procedure\ declaration
-		 "expected an argument identifier"
+		 "expected an argument identifier, found something else"
 		 (car rest-stx))])))))
 
-   (define (make-honu-type pred-id mk-pred-def only-mode)
+   (define (make-honu-type pred-id mk-pred-def)
      (make-honu-trans
       (lambda (orig-stx ctx)
 	(let* ([pred-id (or pred-id
@@ -373,17 +380,17 @@
 			     (mk-pred-def pred-id orig-stx)
 			     #'(begin))])
 	  (cond
-	   [(block-context? ctx)
+	   [(or (block-context? ctx)
+		(definition-context? ctx))
 	    (with-syntax ([pred-id pred-id]
 			  [type-name (stx-car orig-stx)])
 	      (let loop ([stx (stx-cdr orig-stx)]
 			 [after (stx-car orig-stx)]
-			 [after-what "type name"]
+			 [after-what "type name"])
-			 [parens-ok? #t])
 		(syntax-case stx ()
 		  [(id . rest)
 		   (begin
-		     (unless (identifier? #'id)
+		     (unless (honu-identifier? #'id)
 		       (raise-syntax-error 'declaration
 					   (format "expected a identifier after ~a" after-what)
 					   (stx-car orig-stx)
@@ -391,12 +398,12 @@
 		     (if (and (identifier? (stx-car #'rest))
 			      (module-identifier=? #'set! (stx-car #'rest)))
 			 ;; -- Non-procedure declaration
-			 (if (eq? 'function only-mode)
+			 (if (function-definition-context? ctx)
 			     (raise-syntax-error 
 			      'declaration
 			      "expected parentheses after name for function definition"
 			      (stx-car #'rest))
-			     (let-values ([(val-stxs after-expr) (extract-until (stx-cdr #'rest)
+			     (let-values ([(val-stxs after-expr terminator) (extract-until (stx-cdr #'rest)
 											   (list #'\; #'\,))])
 			       (unless val-stxs
 				 (raise-syntax-error 
@@ -408,22 +415,23 @@
 				  'declaration
 				  "missing expression initializing assignment"
 				  (stx-car #'rest)))
-			       (let ([def #`(define-typed id #f type-name pred-id 
+			       (let ([def #`(define-typed id 
-					      (check-expr #f 'id type-name pred-id 
+					      #,(constant-definition-context? ctx)
+					      #f type-name pred-id 
+					      (check-expr-type #f 'id type-name pred-id 
 							       (honu-unparsed-expr #,@val-stxs)))])
 				 (if (module-identifier=? #'\; (stx-car after-expr))
 				     (values #`(begin #,pred-def #,def) (stx-cdr after-expr))
 				     (let-values ([(defs remainder kind) (loop (stx-cdr after-expr) (stx-car after-expr) "comma" #f)])
 				       (values #`(begin #,pred-def #,def #,defs) remainder))))))
 			 ;; -- Procedure declaration
-			 (if (eq? 'var only-mode)
+			 (if (value-definition-context? ctx)
 			     (raise-syntax-error 
 			      'declaration
-			      "expected = after name for variable"
+			      (format "expected = after name in ~a context" (context->name ctx))
 			      (stx-car #'rest))
 			     (syntax-case #'rest (#%parens \;)
 			       [((#%parens . prest) (#%braces . body) . rest)
-				parens-ok?
 				(let ([args (parse-arguments #'prest #'id)])
 				  (with-syntax ([((arg arg-type arg-pred-def arg-pred-id) ...) args]
 						[(temp-id ...) (generate-temporaries (map car args))])
@@ -431,14 +439,14 @@
 						#,pred-def
 						arg-pred-def ...
 						(define-typed-procedure id 
+						  type-name
 						  ((arg arg-type arg-pred-id) ...)
 						  (lambda (temp-id ...)
-						    (define-typed arg id arg-type arg-pred-id temp-id) ...
+						    (define-typed arg #f id arg-type arg-pred-id temp-id) ...
 						    (honu-unparsed-block id type-name pred-id #t . body))))
 					    #'rest)))]
 			       ;; --- Error handling ---
 			       [((#%parens . prest) . bad-rest)
-				parens-ok?
 				(begin
 				  (parse-arguments #'prest #'id)
 				  (raise-syntax-error 
@@ -446,30 +454,26 @@
 				   "braces for function body after parenthesized arguments"
 				   (stx-car #'rest)
 				   #'id))]
-			       [_else
+			       [(id . _)
 				(raise-syntax-error 
 				 '|declaration|
-				 (if parens-ok?
+				 (cond
-				     "expected either = (for variable intialization) or parens (for function arguments)"
+				  [(constant-definition-context? ctx) "expected = (for constant initialization)"]
-				     "expected = (for variable initialization)")
+				  [(variable-definition-context? ctx) "expected = (for variable initialization)"]
+				  [(function-definition-context? ctx) "expected parens (for function arguments)"]
+				  [else
+				   "expected either = (for variable intialization) or parens (for function arguments)"])
 				 #'id)]))))]
 		  [_else
 		   (raise-syntax-error #f 
 				       (format "expected a identifier after ~a" after-what)
 				       after
 				       #'id)])))]
-	   [only-mode
-	    (raise-syntax-error #f 
-				(format "illegal in an ~a context"
-					(if (type-context? ctx) 
-					    "type"
-					    "expression"))
-				(stx-car orig-stx))]
 	   [(type-context? ctx) 
 	    (values (make-h-type (stx-car orig-stx) pred-def pred-id) (stx-cdr orig-stx))]
-	   [(expression-context? ctx)
+	   [else
 	    (raise-syntax-error #f 
-				"illegal in an expression context"
+				(format "illegal in ~a context" (context->name ctx))
 				(stx-car orig-stx))])))))
 
    (define (make-proc-predicate name form)
@@ -494,7 +498,7 @@
 			(raise-type-error '->
 					  "non-type within a procedure-type construction"
 					  (stx-car args-stx)))
-		      (let-values ([(type rest-stx) (trans args-stx type-context)])
+		      (let-values ([(type rest-stx) (trans args-stx the-type-context)])
 			(cons type (loop rest-stx))))))]
 	     [result-type 
 	      (let ([trans (get-transformer result-stx)])
@@ -502,7 +506,7 @@
 		  (raise-type-error '->
 				    "non-type in result position for procedure-type construction"
 				    (stx-car result-stx)))
-		(let-values ([(type rest-stx) (trans result-stx type-context)])
+		(let-values ([(type rest-stx) (trans result-stx the-type-context)])
 		  (unless (stx-null? rest-stx)
 		    (raise-type-error '->
 				      "extra tokens following result for procedure-type construction"
@@ -523,25 +527,49 @@
 		 (if (and (procedure? v)
 			  (procedure-arity-includes? v n))
 		     (values #t (lambda (arg ...)
-				  (check-expr
+				  (check-expr-type
 				   #f #t result-type result-pred-id
-				   (v (check-expr #f #f arg-type arg-pred-id arg) ...))))
+				   (v (check-expr-type #f #f arg-type arg-pred-id arg) ...))))
 		     (values #f #f))))))))
        
-   (define (compatible-type? val-expr val-type target-type)
+   (define (check-compatible-type val-expr val-type target-type fail-k)
      (and (identifier? target-type)
-	  (identifier? val-type)
+	  (or (module-identifier=? #'obj target-type)
+	      (and (identifier? val-type)
+		   (module-identifier=? val-type target-type))
+	      (let ([val-type
+		     (if (not val-type)
+			 (cond
+			  [(and (integer? (syntax-e val-expr))
+				(exact? (syntax-e val-expr))) #'int]
+			  [(real? (syntax-e val-expr)) #'real]
+			  [(number? (syntax-e val-expr)) #'num]
+			  [(string? (syntax-e val-expr)) #'string-type]
+			  [(boolean? (syntax-e val-expr)) #'bool]
+			  [(identifier? val-expr)
+			   (cond
+			    [(module-identifier=? #'false val-expr) #'bool]
+			    [(module-identifier=? #'true val-expr) #'bool]
+			    [else #'obj])]
+			  [else #'obj])
+			 val-type)])
 		(or (module-identifier=? val-type target-type)
-	      (module-identifier=? #'val target-type)
+		    (and (module-identifier=? #'num target-type)
-	      (and (number? (syntax-e val-expr))
+			 (or (module-identifier=? val-type #'int)
-		   (module-identifier=? #'num target-type))
+			     (module-identifier=? val-type #'real)))
-	      (and (integer? (syntax-e val-expr))
+		    (and (module-identifier=? #'real target-type)
-		   (exact? (syntax-e val-expr))
+			 (or (module-identifier=? val-type #'int)))
-		   (module-identifier=? #'int target-type))
+		    (if (module-identifier=? val-type #'obj)
-	      (and (real? (syntax-e val-expr))
+			#f
-		   (module-identifier=? #'real target-type))
+			(fail-k val-expr val-type target-type)))))))
-	      (and (string? (syntax-e val-expr))
+
-		   (module-identifier=? #'string-type target-type))))))
+   (define (type-mismatch val-expr val-type target-type)
+     (raise-syntax-error
+      '|type mismatch|
+      (format "actual type ~a does not match expected type ~a"
+	      (syntax-object->datum val-type)
+	      (syntax-object->datum target-type))
+      val-expr)))
   
   (define (check proc who type-name pred val)
     (let-values ([(tst new-val) (pred val)])
@@ -563,32 +591,46 @@
 	  (current-continuation-marks))))
       new-val))
 
-  (define-syntax (check-expr stx)
+  (define-syntax (check-expr-type stx)
     (syntax-case stx ()
       [(_ proc who type-name pred val)
        ;; Avoid the check if the static types are consistent
        (let ([v (local-expand
 		 #'val
 		 'expression
-		 (cons #'honu-typed
+		 expand-stop-forms)])
-		       kernel-forms))])
+	 (syntax-case v (honu-typed if let-values)
-	 (syntax-case v (honu-typed)
 	   [(honu-typed val val-type)
-	    (compatible-type? #'val #'val-type #'type-name)
+	    (check-compatible-type #'val #'val-type #'type-name type-mismatch)
 	    ;; No run-time check:
 	    #'val]
+	   [(if t then else)
+	    ;; propagate check to body:
+	    #'(if t 
+		  (check-expr-type proc who type-name pred then)
+		  (check-expr-type proc who type-name pred else))]
+	   [(let-values bindings body)
+	    #'(let-values bindings 
+		  (check-expr-type proc who type-name pred body))]
+	   [(honu-unparsed-block #f _ #f return-context? . body)
+	    #'(honu-unparsed-block who type-name pred return-context? . body)]
 	   [_else
 	    ;; Even without a type for v, we might see a literal,
 	    ;;  or maybe the declaration is simply val
-	    (if (compatible-type? v #'val #'type-name)
+	    (if (check-compatible-type v #f #'type-name type-mismatch)
 		;; No run-time check:
-		#'val
+		v
 		;; Run-time check:
-		#'(check proc who 'type-name pred val))]))]))
+		(with-syntax ([val v])
+		  #'(check proc who 'type-name pred val)))]))]))
+
+  (define-syntax honu-app
+    (syntax-rules ()
+      [(_ a b ...) (a b ...)]))
 
   (define-syntax (define-typed stx)
     (syntax-case stx ()
-      [(_ id proc-name type-name pred-id val)
+      [(_ id const? proc-name type-name pred-id val)
        (with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
 	 #'(begin
 	     (define gen-id val)
@@ -597,20 +639,18 @@
 		(lambda (stx)
 		  (syntax-case stx (set!)
 		    [(set! id rhs)
-		     #'(set! gen-id (check-expr set! id type-name pred-id rhs))]
+		     (if const?
+			 (raise-syntax-error #f "cannot assign to constant" #'id)
+			 #'(set! gen-id (check-expr-type 'set! id type-name pred-id rhs)))]
 		    [(id arg (... ...))
-		     #'(#%app (honu-typed gen-id type-name) arg (... ...))]
+		     #'(honu-app (honu-typed gen-id type-name) arg (... ...))]
 		    [id
 		     #'(honu-typed gen-id type-name)]))))))]))
 
-  (define-syntax (define-typed-procedure stx)
+  (define-for-syntax (make-typed-procedure gen-id result-spec arg-spec)
-    (syntax-case stx ()
+    (with-syntax ([((arg arg-type pred-id) ...) arg-spec]
-      [(_ id arg-spec val)
+		  [result-spec result-spec]
-       (with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
+		  [gen-id gen-id])
-	 #'(begin
-	     (define gen-id val)
-	     (define-syntax id
-	       (with-syntax ([((arg arg-type pred-id) (... ...)) (quote-syntax arg-spec)])
       (make-set!-transformer
        (lambda (stx)
 	 (syntax-case stx (set!)
@@ -619,9 +659,9 @@
 				"cannot assign to procedure name"
 				stx
 				#'id)]
-		      [(id actual-arg (... ...))
+	   [(id actual-arg ...)
-		       (let ([actual-args (syntax->list #'(actual-arg (... ...)))]
+	    (let ([actual-args (syntax->list #'(actual-arg ...))]
-			     [formal-args (syntax->list #'(arg (... ...)))])
+		  [formal-args (syntax->list #'(arg ...))])
 	      (unless (= (length actual-args)
 			 (length formal-args))
 		(raise-syntax-error
@@ -630,14 +670,27 @@
 			 (length formal-args)
 			 (length actual-args))
 		 stx))
-			 #'(#%app (honu-typed gen-id type-name) 
+	      #'(honu-typed (#%app (honu-typed gen-id type-name) 
-				  (check-expr 'id 'arg arg-type pred-id actual-arg) 
+				   (check-expr-type 'id 'arg arg-type pred-id actual-arg) 
-				  (... ...)))]
+				   ...)
+			    result-spec))]
 	   [id
-		       #'(honu-typed (let ([id (lambda (arg (... ...))
+	    #'(honu-need-type gen-id
-						 (id arg (... ...)))])
+			      (let ([id (lambda (arg ...)
+					  (id arg ...))])
 				id)
-				     type-name)])))))))]))
+			      type-name)])))))
+
+  (provide honu-typed check-expr-type) ; <-------- FIXME. These shouldn't be exported.
+
+  (define-syntax (define-typed-procedure stx)
+    (syntax-case stx ()
+      [(_ id result-spec arg-spec val)
+       (with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
+	 #'(begin
+	     (define gen-id val)
+	     (define-syntax id
+	       (make-typed-procedure (quote-syntax gen-id) (quote-syntax result-spec) (quote-syntax arg-spec)))))]))
 
   (define-syntax honu-typed
     (syntax-rules ()
@@ -659,7 +712,7 @@
 			   (let ([expr (local-expand
 					expr
 					(generate-expand-context)
-					kernel-forms)])
+					expand-stop-forms)])
 			     (syntax-case expr (begin)
 			       [(begin . rest)
 				(loop (syntax->list #'rest))]
@@ -675,7 +728,7 @@
 					 proc-id 
 					 (syntax-e proc-id))
 				    (reverse (cons
-					      #`(check-expr '#,proc-id #t
+					      #`(check-expr-type '#,proc-id #t
 								 #,result-type-name 
 								 #,result-pred-id 
 								 #,(car prev-exprs))
@@ -683,7 +736,7 @@
 				    (begin
 				      (unless (or (not proc-id)
 						  (not (syntax-e proc-id))
-						  (module-identifier=? #'type-name #'void-type))
+						  (module-identifier=? #'type-name #'obj))
 					(error "no expression for type check; should have been "
 					       "caught earlier"))
 				      (reverse prev-exprs)))
@@ -710,8 +763,8 @@
        #`(honu-block proc-id result-type-name result-pred-id #,@(parse-block 
 								 #'body
 								 (if (syntax-e #'return-context?)
-								     return-block-context
+								     the-return-block-context
-								     block-context)))]))
+								     the-block-context)))]))
 
   (define-syntax (honu-unparsed-expr stx)
     (syntax-case stx ()
@@ -723,7 +776,7 @@
 
   (define-syntax (#%parens stx)
     (syntax-case stx ()
-      [(_ rator (rand ...)) (syntax/loc #'rator (rator rand ...))]))
+      [(_ rator (rand ...)) (syntax/loc #'rator (honu-app rator rand ...))]))
 
   ;; --------------------------------------------------------
   ;; Defining a new transformer or new type
@@ -744,13 +797,13 @@
 	     (define pred-id (let ([pred pred-expr])
 				(lambda (v)
 				  (values (pred v) v))))
-	     (define-syntax id (make-honu-type #'pred-id #f #f))))]))
+	     (define-syntax id (make-honu-type #'pred-id #f))))]))
 
   (define-syntax (define-type-constructor stx)
     (syntax-case stx ()
       [(_ id generator-expr)
        (identifier? #'id)
-       #'(define-syntax id (make-honu-type #f generator-expr #f))]))
+       #'(define-syntax id (make-honu-type #f generator-expr))]))
 
   ;; ----------------------------------------
   ;;  Pre-defined types and forms
@@ -759,13 +812,44 @@
     (and (integer? v) (exact? v)))
 
   (define-type int exact-integer?)
+  (define-type bool boolean?)
   (define-type real real?)
   (define-type num number?)
   (define-type obj (lambda (x) #t))
   (define-type string-type string?)
 
-  (define-syntax function (make-honu-type #'(lambda (x) (values #t x)) #f 'function))
+  (define-for-syntax (make-definition-form what this-context this-context?)
-  (define-syntax var (make-honu-type #'(lambda (x) (values #t x)) #f 'var))
+    (make-honu-transformer
+     (lambda (orig-stx ctx)
+       (when (this-context? ctx)
+	 (raise-syntax-error #f 
+			     (format "redundant in ~a context" (context->name ctx))
+			     (stx-car orig-stx)))
+       (unless (block-context? ctx)
+	 (raise-syntax-error #f 
+			     (format "illegal in ~a context" (context->name ctx))
+			     (stx-car orig-stx)))
+       (let ([body (stx-cdr orig-stx)])
+	 (cond
+	  [(stx-null? body)
+	   (raise-syntax-error #f 
+			       (format "expected a ~a definition after keyword" what)
+			       (stx-car orig-stx))]
+	  [(get-transformer body)
+	   => (lambda (transformer)
+		(transformer body this-context))]
+	  [else
+	   (let ([id (stx-car orig-stx)])
+	     (unless (honu-identifier? id)
+	       (raise-syntax-error #f
+				   (format "expected an identifier for a ~a definition" what)
+				   (stx-car orig-stx)
+				   id))
+	     ((make-honu-type #'(lambda (x) (values #t x)) #f) orig-stx this-context))])))))
+
+  (define-syntax function (make-definition-form 'function the-function-definition-context function-definition-context?))
+  (define-syntax var (make-definition-form 'variable the-variable-definition-context variable-definition-context?))
+  (define-syntax const (make-definition-form 'variable the-constant-definition-context constant-definition-context?))
 
   (define-type-constructor -> make-proc-predicate)
 
@@ -781,7 +865,6 @@
 			   [(other rest) (loop #'rest null (stx-car body))])
 		(values (combine one other) rest))]
 	     [(\; . rest)
-	      (identifier? #'id)
 	      (values (parse-one (reverse accum) prev-comma (stx-car body)) #'rest)]
 	     [(x . rest)
 	      (loop #'rest (cons #'x accum) #f)]))])))
@@ -796,7 +879,7 @@
        (lambda (stxes prev-comma-stx term-stx)
 	 (syntax-case stxes ()
 	   [(id)
-	    (identifier? #'id)
+	    (honu-identifier? #'id)
 	    #`(provide id)]
 	   [else
 	    (raise-syntax-error
@@ -890,7 +973,7 @@
 		      (car stxes)
 		      (stx-car body))]
 		    [(fn)
-		     (identifier? #'fn)
+		     (honu-identifier? #'fn)
 		     #'fn]
 		    [else
 		     (raise-syntax-error
@@ -902,13 +985,13 @@
 		  (syntax-case stxes (rename #%parens \,)
 		    [(rename (#%parens spec0 spec ... \, local-id \, remote-id) . rest)
 		     (begin
-		       (unless (identifier? #'local-id)
+		       (unless (honu-identifier? #'local-id)
 			 (raise-syntax-error
 			  #f
 			  "expected an identifier"
 			  (stx-car stxes)
 			  #'local-id))
-		       (unless (identifier? #'remote-id)
+		       (unless (honu-identifier? #'remote-id)
 			 (raise-syntax-error
 			  #f
 			  "expected an identifier"
@@ -935,7 +1018,7 @@
     (lambda (stx ctx)
       (unless (return-block-context? ctx)
 	(raise-syntax-error #f "allowed only in a tail position" (stx-car stx)))
-      (let-values ([(val-stxs after-expr) (extract-until (stx-cdr stx)
+      (let-values ([(val-stxs after-expr terminator) (extract-until (stx-cdr stx)
 								    (list #'\;))])
 	(unless val-stxs
 	  (raise-syntax-error 
@@ -962,12 +1045,10 @@
     (lambda (stx ctx)
       (define (get-block-or-statement kw rest)
 	(syntax-case rest (#%braces)
-	  [((#%braces then ...) . rest)
+	  [((#%braces then ...) . rrest)
-	   (values #`(honu-unparsed-block #f void-type #f #,(return-block-context? ctx) then ...)
+	   (values (stx-cdr (stx-car rest)) #'rrest)]
-		   #'rest)]
 	  [else
-	   (let-values ([(val-stxs rest) (extract-until rest
+	   (let-values ([(val-stxs rest terminator) (extract-until rest (list #'\;) #t)])
-							(list #'\;))])
 	     (unless val-stxs
 	       (raise-syntax-error
 		#f
@@ -979,34 +1060,82 @@
 		"expected an expression before semicolon"
 		kw
 		(stx-car rest)))
-	     (if (return-block-context? ctx)
+	     (values val-stxs (stx-cdr rest)))]))
-		 (values (parse-tail-expr val-stxs) (stx-cdr rest))
+
-		 (values (parse-expr val-stxs) (stx-cdr rest))))]))
+      (define (wrap-block exprs rest)
+	#`(honu-unparsed-block #f obj #f #,(and (return-block-context? ctx)
+						(stx-null? rest))
+			       . #,exprs))
 
       (syntax-case stx (#%parens)
 	[(_ (#%parens test ...) . rest)
-	 (let ([test-expr (parse-expr (syntax->list #'(test ...)))])
+	 (let* ([tests #'(test ...)])
-	   (let-values ([(then-expr rest) (get-block-or-statement (stx-car stx) #'rest)])
+	   (when (stx-null? tests)
+	     (raise-syntax-error
+	      #f
+	      "missing test expression"
+	      (stx-car stx)
+	      (stx-car (stx-cdr stx))))
+	   (let ([test-expr (parse-expr (syntax->list tests))])
+	     (let-values ([(then-exprs rest) (get-block-or-statement (stx-car stx) #'rest)])
 	       (syntax-case rest (else)
 		 [(else . rest2)
-		(let-values ([(else-expr rest) (get-block-or-statement (stx-car rest) #'rest2)])
+		  (let-values ([(else-exprs rest) (get-block-or-statement (stx-car rest) #'rest2)])
-		  (values #`(if #,test-expr #,then-expr #,else-expr)
+		    (values #`(if #,test-expr 
+				  #,(wrap-block then-exprs rest)
+				  #,(wrap-block else-exprs rest))
 			    rest))]
 		 [_else
-		(values #`(if #,test-expr #,then-expr) rest)])))]
+		  (values #`(if #,test-expr #,(wrap-block then-exprs rest) (void)) rest)]))))]
 	[_else
 	 (raise-syntax-error
 	  #f
 	  "expected a parenthesized test after `if' keyword"
 	  (stx-car stx))])))
 
+  ;; ----------------------------------------
+  ;;  Class form
+
+  (define-honu-syntax honu-class
+    (lambda (stx ctx)
+      (syntax-case stx (#%braces)
+	[(form id . rest)
+	 (not (honu-identifier? #'id))
+	 (raise-syntax-error
+	  #f
+	  "expected an identifier for the class"
+	  #'form
+	  #'id)]
+	[(form id (#%braces content ...) . rest)
+	 (let ([id #'id])
+	   
+
+	   10)]
+	[(form)
+	 (raise-syntax-error
+	  #f
+	  "missing name for the class"
+	  #'form)]
+	[(form id next . _)
+	 (raise-syntax-error
+	  #f
+	  "expected braces after class name, found something else"
+	  #'form
+	  #'next)]
+	[(form id)
+	 (raise-syntax-error
+	  #f
+	  "missing braces after class name"
+	  #'form
+	  #'id)])))
+
   ;; ----------------------------------------
   ;; Main compiler loop
 
   (define-syntax (honu-unparsed-begin stx)
     (syntax-case stx ()
       [(_) #'(begin)]
-      [(_ . body) (let-values ([(code rest) (parse-block-one top-block-context
+      [(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context
 							     #'body 
 							     values
 							     (lambda ()
@@ -1024,13 +1153,14 @@
   (define true #t)
   (define false #f)
 
-  (provide int real obj 
+  (provide int real bool obj 
-	   function var
+	   function var const
 	   (rename string-type string) ->
 	   \;
            (rename set! =)
 	   (rename honu-return return)
 	   (rename honu-if if)
+	   (rename honu-class class)
 	   + - * / (rename modulo %)
 	   (rename string->number stringToNumber)
 	   (rename number->string numberToString)

collects/honu-module/private/contexts.ss

@@ -0,0 +1,60 @@
+(module contexts mzscheme
+
+  (define-struct block-context ())
+  (define-struct (top-block-context block-context) ())
+  (define-struct (return-block-context block-context) ())
+
+  (define-struct definition-context ())
+  (define-struct (function-definition-context definition-context) ())
+  (define-struct (value-definition-context definition-context) ())
+  (define-struct (constant-definition-context value-definition-context) ())
+  (define-struct (variable-definition-context value-definition-context) ())
+
+  (define-struct expression-context ())
+  (define-struct type-context ())
+
+  (define the-block-context (make-block-context))
+  (define the-top-block-context (make-top-block-context))
+  (define the-return-block-context (make-return-block-context))
+
+  (define the-function-definition-context (make-function-definition-context))
+  (define the-variable-definition-context (make-variable-definition-context))
+  (define the-constant-definition-context (make-constant-definition-context))
+
+  (define the-expression-context (make-expression-context))
+  (define the-type-context (make-type-context))
+
+   (define (context->name ctx)
+     (cond
+      [(type-context? ctx) "a type"]
+      [(block-context? ctx) "a block"]
+      [(variable-definition-context? ctx) "a variable-definition"]
+      [(constant-definition-context? ctx) "a constant-definition"]
+      [(function-definition-context? ctx) "a function-definition"]
+      [else "an expression"]))
+   
+  (provide block-context?
+	   top-block-context?
+	   return-block-context?
+
+	   definition-context?
+	   function-definition-context?
+	   value-definition-context?
+	   variable-definition-context?
+	   constant-definition-context?
+
+	   expression-context?
+	   type-context?
+
+	   the-block-context
+	   the-top-block-context
+	   the-return-block-context
+
+	   the-function-definition-context
+	   the-variable-definition-context
+	   the-constant-definition-context
+
+	   the-expression-context
+	   the-type-context
+
+	   context->name))

collects/honu-module/private/util.ss

@@ -4,16 +4,24 @@
 
   (require (lib "stx.ss" "syntax"))
 
-  (define (extract-until r ids)
+  (define extract-until
+    (case-lambda
+     [(r ids keep?)
       (let loop ([r r][val-stxs null])
 	(cond
 	 [(stx-null? r)
-	 (values #f #f)]
+	  (values #f #f #f)]
 	 [(and (identifier? (stx-car r))
 	       (ormap (lambda (id)
 			(module-identifier=? id (stx-car r)))
 		      ids))
-	 (values (reverse val-stxs) r)]
+	  (values (reverse (if keep?
+			       (cons (stx-car r) val-stxs) 
+			       val-stxs))
+		  r
+		  (stx-car r))]
 	 [else
-	 (loop (stx-cdr r) (cons (stx-car r) val-stxs))]))))
+	  (loop (stx-cdr r) (cons (stx-car r) val-stxs))]))]
+     [(r ids) (extract-until r ids #f)])))
+
      

collects/planet/resolver.ss

@@ -169,14 +169,16 @@ an appropriate subdirectory.
   
   (define install? (make-parameter #t)) ;; if #f, will not install packages and instead give an error
   
-  (define (resolver spec module-path stx)
+  (define resolver 
+    (case-lambda
+     [(name) (void)]
+     [(spec module-path stx load?)
       ;; ensure these directories exist
       (make-directory* (PLANET-DIR))
       (make-directory* (CACHE-DIR))
       (establish-diamond-property-monitor)
-    (cond
+      (planet-resolve spec module-path stx load?)]
-      [(or spec stx) (planet-resolve spec module-path stx)]
+     [(spec module-path stx) (resolver spec module-path stx #t)]))
-      [else module-path]))
   
   ; ==========================================================================================
   ; DIAMOND PROPERTY STUFF
@@ -270,10 +272,10 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
   ; planet-resolve : PLANET-REQUEST symbol syntax[PLANET-REQUEST] -> symbol
   ; resolves the given request. Returns a name corresponding to the module in the correct
   ; environment
-  (define (planet-resolve spec module-path stx)
+  (define (planet-resolve spec module-path stx load?)
     (let-values ([(path pkg) (get-planet-module-path/pkg spec module-path stx)])
       (add-pkg-to-diamond-registry! pkg)
-      (do-require path (pkg-path pkg) module-path stx)))
+      (do-require path (pkg-path pkg) module-path stx load?)))
   
   ;; get-planet-module-path/pkg :PLANET-REQUEST symbol syntax[PLANET-REQUEST] -> path PKG
   ;; returns the matching package and the file path to the specific request
@@ -559,12 +561,13 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
   
   ; do-require : path path symbol syntax -> symbol
   ; requires the given filename, which must be a module, in the given path.
-  (define (do-require file-path package-path module-path stx)
+  (define (do-require file-path package-path module-path stx load?)
     (parameterize ((current-load-relative-directory package-path))    
       ((current-module-name-resolver)
        file-path
        module-path
-       stx)))
+       stx
+       load?)))
   
   ; ============================================================
   ; UTILITY

collects/tests/mred/item.ss

@@ -1269,7 +1269,7 @@
   (define rb1 (make-object radio-box% "&Left" rb1-l hp callback))
   (define rb2-l (list "First" "Last"))
   (define rb2 (make-object radio-box% "&Center" rb2-l hp callback))
-  (define rb3-l (list "Top" "Middle" "Bottom"))
+  (define rb3-l (list "&Top" "&Middle" "&Bottom"))
   (define rb3 (make-object radio-box% "&Right" rb3-l hp callback))
 
   (define rbs (list rb1 rb2 rb3))
@@ -1285,8 +1285,8 @@
 	(with-handlers ([exn? void])
 	  (f rb p)
 	  (error "no exn raisd")))))
-  (define type-err (mk-err exn:application:type?))
+  (define type-err (mk-err exn:fail:contract?))
-  (define mismatch-err (mk-err exn:application:mismatch?))
+  (define mismatch-err (mk-err exn:fail:contract?))
 
   (define do-sel (lambda (sel n) (for-each (lambda (rb) (sel rb (n rb))) rbs)))
   (define sel-minus (lambda (sel) (do-sel (type-err sel) (lambda (rb) -1))))
@@ -1472,7 +1472,7 @@
 	  (make-object button%
 		       (string-append "Select Bad -1" mname) p2
 		       (lambda (b e)
-			 (with-handlers ([exn:application:type? void])
+			 (with-handlers ([exn:fail:contract? void])
 			   (method -1)
 			   (error "expected a type exception")))))
     (make-object button%
@@ -1490,7 +1490,7 @@
     (make-object button%
 		 (string-append "Select Bad X" mname) p2
 		 (lambda (b e)
-		   (with-handlers ([exn:application:mismatch? void]) 
+		   (with-handlers ([exn:fail:contract? void]) 
 		     (method (if numerical?
 				 (send c get-number)
 				 #f))
@@ -1537,8 +1537,8 @@
 					 (with-handlers ([exn? void])
 					   (send c get-string i)
 					   (error "out-of-bounds: no exn")))])
-			      (bad exn:application:type? -1)
+			      (bad exn:fail:contract? -1)
-			      (bad exn:application:mismatch? (send c get-number)))
+			      (bad exn:fail:contract? (send c get-number)))
 			    (unless (not (send c find-string "nada"))
 			      (error "find-string of nada wasn't #f"))
 			    (for-each

collects/tests/mzscheme/number.ss

@@ -684,6 +684,8 @@
 (test 0.25-0.0i / 1 4+0.0i)
 (test 0.25+0.0i / 1+0.0i 4+0.0i)
 (test 0 / 0 4+3i)
+(test 0.25+0.0i / 1e300+1e300i (* 4 1e300+1e300i))
+(test 0.25+0.0i / 1e-300+1e-300i (* 4 1e-300+1e-300i))
 
 (test 3 / 1 1/3)
 (test -3 / 1 -1/3)
@@ -1333,6 +1335,10 @@
 (test 3/4 magnitude -3/4)
 (test 10.0 magnitude 10.0+0.0i)
 (test 10.0 magnitude -10.0+0.0i)
+(test 10.0 magnitude 0+10.0i)
+(test 10 magnitude 0+10i)
+(test 141421.0 round (* 1e-295 (magnitude 1e300+1e300i)))
+(test 141421.0 round (* 1e+305 (magnitude 1e-300+1e-300i)))
 
 (test 0 angle 1)
 (test 0 angle 1.0)
@@ -1622,7 +1628,7 @@
 ; Should at least be close...
 (test 4.0 round (log (exp 4.0)))
 (test 125.0 round (* 1000 (asin (sin 0.125))))
-(test 125.0d0 round (* 1000 (asin (sin 0.125+0.0d0i))))
+(test 125.0d0 round (* 1000 (magnitude (asin (sin 0.125+0.0d0i)))))
 (test 125.0 round (* 1000 (asin (sin 1/8))))
 (test 125.0 round (* 1000 (acos (cos 0.125))))
 (test 125.0d0 round (* 1000 (acos (cos 0.125+0.0d0i))))

collects/tests/mzscheme/stx.ss

@@ -1069,6 +1069,57 @@
 (require @!$m)
 (test '(10 20 #t) '@!$get @!$get)
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Test lazy unmarshaling of renamings and module-name resolution
 
+(let ([load-ok? #t])
+  (parameterize ([current-namespace (make-namespace)]
+		 [current-module-name-resolver
+		  (case-lambda 
+		   [(a) (void)]
+		   [(name _ __) 'huh?]
+		   [(name _ __ load?)
+		    (unless load-ok?
+		      (test #f 'load-ok load?))
+		    'a])])
+    (let ([a-code '(module a mzscheme
+		     (provide x y)
+		     (define x 1)
+		     (define y #'x))])
+      (eval a-code)
+      (let ([b-code (let ([p (open-output-bytes)])
+		      (write (compile
+			      '(module b mzscheme
+				 (require "a")
+				 (provide f)
+				 (define (f) #'x)))
+			     p)
+		      (lambda ()
+			(parameterize ([read-accept-compiled #t])
+			  (read (open-input-bytes (get-output-bytes p))))))]
+	    [x-id (parameterize ([current-namespace (make-namespace)])
+		    (eval a-code)
+		    (eval '(require a))
+		    (eval '#'x))])
+	(eval (b-code))
+	(eval '(require b))
+	(set! load-ok? #f)
+	(test #f eval '(module-identifier=? (f) #'x))
+	(test #t eval `(module-identifier=? (f) (quote-syntax ,x-id)))
+	(eval '(require a))
+	(test #t eval '(module-identifier=? (f) #'x))
+	(test #t eval `(module-identifier=? (f) (quote-syntax ,x-id)))
+	(parameterize ([current-namespace (make-namespace)])
+	  (eval '(module a mzscheme
+		   (provide y)
+		   (define y 3)))
+	  (set! load-ok? #t)
+	  (eval (b-code))
+	  (eval '(require b))
+	  (set! load-ok? #f)
+	  (test #t eval '(module-identifier=? (f) #'x))
+	  (test #f eval `(module-identifier=? (f) (quote-syntax ,x-id))))))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

collects/tests/mzscheme/syntax.ss

@@ -229,6 +229,9 @@
 (syntax-test #'(set! x . 1))
 (syntax-test #'(set! x 1 . 2))
 
+(define (set!-not-ever-defined) (set! not-ever-defined (add1 not-ever-defined)))
+(err/rt-test (set!-not-ever-defined) exn:fail:contract:variable?)
+
 (set!-values (x) 9)
 (test 9 'set!-values x)
 (test (void) 'set!-values (set!-values () (values)))

collects/tests/mzscheme/thread.ss

@@ -1184,6 +1184,41 @@
 			     (current-preserved-thread-cell-values post)
 			     (test 3 thread-cell-ref c3)))))))
 
+
+;; ----------------------------------------
+;; Check that nested continuations sharing saved runstacks
+;;  work properly:
+
+(test '(5050 5050)
+      'shared-saved-runstacks
+      (parameterize ([current-thread-initial-stack-size 3])
+	(let ([ch (make-channel)]
+	      [r-ch (make-channel)])
+	  (let ([t (thread
+		    (lambda ()
+		      (define (mk-list put)
+			(let loop ([n 100])
+			  (if (zero? n)
+			      (let/cc k
+				(put k)
+				null)
+			      (cons n (loop (sub1 n))))))
+		      (define (sum l)
+			(let loop ([l l])
+			  (if (null? l)
+			      0
+			      (+ (car l) (loop (cdr l))))))
+		      (let ([c1 #f])
+			(let ([l (mk-list (lambda (k)
+					    (sum (mk-list (lambda (k) (channel-put ch k))))))])
+			  (channel-put r-ch (sum l))))))])
+	    (let ([k (channel-get ch)])
+	      (list
+	       (sync r-ch)
+	       (begin
+		 (thread (lambda () (k null)))
+		 (sync r-ch))))))))
+
 ; --------------------
 
 (report-errs)

doc/release-notes/mzscheme/HISTORY

@@ -1,3 +1,16 @@
+Version 350.2
+Changed the module name resolver protocol so that the resolver is
+ required to accept 1, 3, and 4 arguments; the new 4-argument mode
+ supports resolving a module path without loading the module
+Changed namespace-attach-module and namespace-unprotect-module
+ to accept quoted module paths, instead of only symbolic names
+Fixed avoidable overflow and undeflow in magnitude and / for
+ inexact complex numbers
+
+Version 350.1
+Added define-member-name, member-name-key, and generate-member-key
+ to class.ss
+
 Version 350, June 2006
 JIT compiler:
  Added just-in-time native-code compiler with a new eval-jit-enabled

src/mzscheme/include/mzscheme.exp

@@ -254,7 +254,7 @@ scheme_utf8_decode_all
 scheme_utf8_decode_prefix
 scheme_utf8_decode_to_buffer
 scheme_utf8_decode_to_buffer_len
-scheme_utf8_decode_count
+MZ_EXTERN
 scheme_utf8_encode
 scheme_utf8_encode_all
 scheme_utf8_encode_to_buffer
@@ -426,7 +426,6 @@ scheme_primitive_module
 scheme_finish_primitive_module
 scheme_protect_primitive_provide
 scheme_make_modidx
-scheme_declare_module
 scheme_apply_for_syntax_in_env
 scheme_dynamic_require
 scheme_intern_symbol

src/mzscheme/include/mzscheme3m.exp

@@ -261,7 +261,7 @@ scheme_utf8_decode_all
 scheme_utf8_decode_prefix
 scheme_utf8_decode_to_buffer
 scheme_utf8_decode_to_buffer_len
-scheme_utf8_decode_count
+MZ_EXTERN
 scheme_utf8_encode
 scheme_utf8_encode_all
 scheme_utf8_encode_to_buffer
@@ -433,7 +433,6 @@ scheme_primitive_module
 scheme_finish_primitive_module
 scheme_protect_primitive_provide
 scheme_make_modidx
-scheme_declare_module
 scheme_apply_for_syntax_in_env
 scheme_dynamic_require
 scheme_intern_symbol

src/mzscheme/include/mzwin.def

@@ -246,7 +246,6 @@ EXPORTS
  scheme_utf8_decode_prefix
  scheme_utf8_decode_to_buffer
  scheme_utf8_decode_to_buffer_len
- scheme_utf8_decode_count
  scheme_utf8_encode
  scheme_utf8_encode_all
  scheme_utf8_encode_to_buffer
@@ -418,7 +417,6 @@ EXPORTS
  scheme_finish_primitive_module
  scheme_protect_primitive_provide
  scheme_make_modidx
- scheme_declare_module
  scheme_apply_for_syntax_in_env
  scheme_dynamic_require
  scheme_intern_symbol

src/mzscheme/include/scheme.h

@@ -110,6 +110,12 @@ typedef long FILE;
 # define MZ_SIGSET(s, f) sigset(s, f)
 #endif
 
+#ifdef MZ_XFORM
+# define XFORM_NONGCING __xform_nongcing__
+#else
+# define XFORM_NONGCING /* empty */
+#endif
+
 #ifdef MZ_XFORM
 START_XFORM_SUSPEND;
 #endif

src/mzscheme/src/bignum.c

@@ -590,7 +590,7 @@ static bigdig* allocate_bigdig_array(int length)
 }
 
 /* We don't want to count leading digits of 0 in the bignum's length */
-static int bigdig_length(bigdig* array, int alloced)
+XFORM_NONGCING static int bigdig_length(bigdig* array, int alloced)
 {
   alloced--;
   while (alloced >= 0 && array[alloced] == 0) {

src/mzscheme/src/complex.c

@@ -209,35 +209,76 @@ Scheme_Object *scheme_complex_multiply(const Scheme_Object *a, const Scheme_Obje
   
 }
 
-Scheme_Object *scheme_complex_divide(const Scheme_Object *n, const Scheme_Object *d)
+Scheme_Object *scheme_complex_divide(const Scheme_Object *_n, const Scheme_Object *_d)
 { 
-  Scheme_Complex *cn = (Scheme_Complex *)n;
+  Scheme_Complex *cn = (Scheme_Complex *)_n;
-  Scheme_Complex *cd = (Scheme_Complex *)d;
+  Scheme_Complex *cd = (Scheme_Complex *)_d;
-  Scheme_Object *a_sq_p_b_sq, *r, *i;
+  Scheme_Object *den, *r, *i, *a, *b, *c, *d, *cm, *dm, *aa[1];
   
   if ((cn->r == zero) && (cn->i == zero))
     return zero;
 
+  a = cn->r;
+  b = cn->i;
+  c = cd->r;
+  d = cd->i;
+
   /* Check for exact-zero simplifications in d: */
-  if (cd->r == zero) {
+  if (c == zero) {
-    i = scheme_bin_minus(zero, scheme_bin_div(cn->r, cd->i));
+    i = scheme_bin_minus(zero, scheme_bin_div(a, d));
-    r = scheme_bin_div(cn->i, cd->i);
+    r = scheme_bin_div(b, d);
     return scheme_make_complex(r, i);
-  } else if (cd->i == zero) {
+  } else if (d == zero) {
-    r = scheme_bin_div(cn->r, cd->r);
+    r = scheme_bin_div(a, c);
-    i = scheme_bin_div(cn->i, cd->r);
+    i = scheme_bin_div(b, c);
     return scheme_make_complex(r, i);
   }
 
-  a_sq_p_b_sq = scheme_bin_plus(scheme_bin_mult(cd->r, cd->r), 
+  aa[0] = d;
-				scheme_bin_mult(cd->i, cd->i));
+  if (SCHEME_TRUEP(scheme_zero_p(1, aa))) {
+    /* This is like dividing by a real number, except that
+       the inexact 0 imaginary part can interact with +inf.0 and +nan.0 */
+    r = scheme_bin_plus(scheme_bin_div(a, c),
+			/* Either 0.0 or +nan.0: */
+			scheme_bin_mult(d, b));
+    i = scheme_bin_minus(scheme_bin_div(b, c),
+			 /* Either 0.0 or +nan.0: */
+			 scheme_bin_mult(d, a));
     
-  r = scheme_bin_div(scheme_bin_plus(scheme_bin_mult(cd->r, cn->r),
+    return scheme_make_complex(r, i);
-				     scheme_bin_mult(cd->i, cn->i)),
+  }
-		     a_sq_p_b_sq);
+  aa[0] = c;
-  i = scheme_bin_div(scheme_bin_minus(scheme_bin_mult(cd->r, cn->i),
+  if (SCHEME_TRUEP(scheme_zero_p(1, aa))) {
-				      scheme_bin_mult(cd->i, cn->r)),
+    r = scheme_bin_plus(scheme_bin_div(b, d),
-		     a_sq_p_b_sq);
+			/* Either 0.0 or +nan.0: */
+			scheme_bin_mult(c, a));
+    i = scheme_bin_minus(scheme_bin_mult(c, b),  /* either 0.0 or +nan.0 */
+			 scheme_bin_div(a, d));
+
+    return scheme_make_complex(r, i);
+  }
+
+  aa[0] = c;
+  cm = scheme_abs(1, aa);
+  aa[0] = d;
+  dm = scheme_abs(1, aa);
+
+  if (scheme_bin_lt(cm, dm)) {
+    cm = a;
+    a = b;
+    b = cm;
+    cm = c;
+    c = d;
+    d = cm;
+  }
+
+  r = scheme_bin_div(c, d);
+  den = scheme_bin_plus(d, scheme_bin_mult(c, r));
+  
+  i = scheme_bin_div(scheme_bin_minus(a, scheme_bin_mult(b, r)),
+		     den);
+  r = scheme_bin_div(scheme_bin_plus(b, scheme_bin_mult(a, r)),
+		     den);
   
   return scheme_make_complex(r, i);
 }

src/mzscheme/src/env.c

@@ -644,7 +644,7 @@ Scheme_Env *scheme_make_empty_env(void)
 static Scheme_Env *make_env(Scheme_Env *base, int semi, int toplevel_size)
 {
   Scheme_Bucket_Table *toplevel, *syntax;
-  Scheme_Hash_Table *module_registry;
+  Scheme_Hash_Table *module_registry, *export_registry;
   Scheme_Object *modchain;
   Scheme_Env *env;
 
@@ -655,14 +655,17 @@ static Scheme_Env *make_env(Scheme_Env *base, int semi, int toplevel_size)
     syntax = NULL;
     modchain = NULL;
     module_registry = NULL;
+    export_registry = NULL;
   } else {
     syntax = scheme_make_bucket_table(7, SCHEME_hash_ptr);
     if (base) {
       modchain = base->modchain;
       module_registry = base->module_registry;
+      export_registry = base->export_registry;
     } else {
       if (semi < 0) {
 	module_registry = NULL;
+	export_registry = NULL;
 	modchain = NULL;
       } else {
 	Scheme_Hash_Table *modules;
@@ -673,6 +676,8 @@ static Scheme_Env *make_env(Scheme_Env *base, int semi, int toplevel_size)
 
 	module_registry = scheme_make_hash_table(SCHEME_hash_ptr);
 	module_registry->iso.so.type = scheme_module_registry_type;
+	
+	export_registry = scheme_make_hash_table(SCHEME_hash_ptr);
       }
     }
   }
@@ -686,6 +691,7 @@ static Scheme_Env *make_env(Scheme_Env *base, int semi, int toplevel_size)
     env->syntax = syntax;
     env->modchain = modchain;
     env->module_registry = module_registry;
+    env->export_registry = export_registry;
   }
 
   return env;
@@ -725,6 +731,7 @@ void scheme_prepare_exp_env(Scheme_Env *env)
 
     eenv->module = env->module;
     eenv->module_registry = env->module_registry;
+    eenv->export_registry = env->export_registry;
     eenv->insp = env->insp;
 
     modchain = SCHEME_VEC_ELS(env->modchain)[1];
@@ -759,6 +766,7 @@ void scheme_prepare_template_env(Scheme_Env *env)
 
     eenv->module = env->module;
     eenv->module_registry = env->module_registry;
+    eenv->export_registry = env->export_registry;
     eenv->insp = env->insp;
 
     modchain = SCHEME_VEC_ELS(env->modchain)[2];
@@ -789,6 +797,7 @@ Scheme_Env *scheme_clone_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Obj
 
   menv2->module = menv->module;
   menv2->module_registry = ns->module_registry;
+  menv2->export_registry = ns->export_registry;
   menv2->insp = menv->insp;
 
   menv2->syntax = menv->syntax;
@@ -2322,7 +2331,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
 
   if (modidx) {
     /* If it's an access path, resolve it: */
-    modname = scheme_module_resolve(modidx);
+    modname = scheme_module_resolve(modidx, 1);
 
     if (env->genv->module && SAME_OBJ(modname, env->genv->module->modname)) {
       modidx = NULL;

src/mzscheme/src/eval.c

@@ -1332,7 +1332,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
   Scheme_Env *menv;
 
   /* If it's a name id, resolve the name. */
-  modname = scheme_module_resolve(modidx);
+  modname = scheme_module_resolve(modidx, 1);
 
   if (env->module && SAME_OBJ(env->module->modname, modname)
       && (env->mod_phase == mod_phase))
@@ -3041,8 +3041,9 @@ static void *compile_k(void)
     form = add_renames_unless_module(form, genv);
     if (genv->module) {
       form = scheme_stx_phase_shift(form, 0, 
-				    genv->module->src_modidx, 
+				    genv->module->me->src_modidx, 
-				    genv->module->self_modidx);
+				    genv->module->self_modidx,
+				    genv->export_registry);
     }
   }
 
@@ -3877,7 +3878,7 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co
       if (modidx) {
 	/* If it's an access path, resolve it: */
 	if (env->genv->module
-	    && SAME_OBJ(scheme_module_resolve(modidx), env->genv->module->modname))
+	    && SAME_OBJ(scheme_module_resolve(modidx, 1), env->genv->module->modname))
 	  bad = 0;
 	else
 	  bad = 1;
@@ -6041,7 +6042,7 @@ Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env *
     result = scheme_make_vector(len - 1, NULL);
 
     for (i = 0; i < len - 1; i++) {
-      s = scheme_stx_phase_shift(SCHEME_VEC_ELS(expr)[i], shift, orig, modidx);
+      s = scheme_stx_phase_shift(SCHEME_VEC_ELS(expr)[i], shift, orig, modidx, env->export_registry);
       SCHEME_VEC_ELS(result)[i] = s;
     }
     
@@ -6765,7 +6766,8 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
 
     if (rp->num_stxes) {
       i = rp->num_toplevels;
-      v = scheme_stx_phase_shift_as_rename(now_phase - src_phase, src_modidx, now_modidx);
+      v = scheme_stx_phase_shift_as_rename(now_phase - src_phase, src_modidx, now_modidx, 
+					   genv ? genv->export_registry : NULL);
       if (v) {
 	/* Put lazy-shift info in a[i]: */
 	v = scheme_make_raw_pair(v, (Scheme_Object *)rp->stxes);

src/mzscheme/src/fun.c

@@ -3107,7 +3107,7 @@ static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
 					     Scheme_Object **runstack_start,
 					     Scheme_Cont *share_from)
 {
-  Scheme_Saved_Stack *saved, *isaved, *csaved, *share_saved, *ss;
+  Scheme_Saved_Stack *saved, *isaved, *csaved, *share_saved, *share_csaved, *ss;
   Scheme_Object **start;
   long size;
 
@@ -3136,12 +3136,14 @@ static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
   /* Copy saved runstacks: */
   isaved = saved;
   share_saved = NULL;
+  share_csaved = NULL;
   if (share_from) {
     /* We can share all saved runstacks */
-    share_saved = share_from->ss.runstack_saved;
+    share_csaved = share_from->ss.runstack_saved;
+    share_saved = share_from->runstack_copied->prev;
   }
   for (csaved = p->runstack_saved; csaved; csaved = csaved->prev) {
-    if (share_saved && (csaved->runstack_start == share_saved->runstack_start)) {
+    if (share_csaved && (csaved->runstack_start == share_csaved->runstack_start)) {
       /* Share */
       isaved->prev = share_saved;
       break;

src/mzscheme/src/mzmark.c

@@ -1838,6 +1838,7 @@ static int namespace_val_MARK(void *p) {
 
   gcMARK(e->module);
   gcMARK(e->module_registry);
+  gcMARK(e->export_registry);
   gcMARK(e->insp);
 
   gcMARK(e->rename);
@@ -1871,6 +1872,7 @@ static int namespace_val_FIXUP(void *p) {
 
   gcFIXUP(e->module);
   gcFIXUP(e->module_registry);
+  gcFIXUP(e->export_registry);
   gcFIXUP(e->insp);
 
   gcFIXUP(e->rename);
@@ -2104,15 +2106,10 @@ static int module_val_MARK(void *p) {
   gcMARK(m->body);
   gcMARK(m->et_body);
 
-  gcMARK(m->provides);
+  gcMARK(m->me);
-  gcMARK(m->provide_srcs);
+
-  gcMARK(m->provide_src_names);
   gcMARK(m->provide_protects);
-
-  gcMARK(m->kernel_exclusion);
-
   gcMARK(m->indirect_provides);
-  gcMARK(m->src_modidx);
   gcMARK(m->self_modidx);
 
   gcMARK(m->accessible);
@@ -2144,15 +2141,10 @@ static int module_val_FIXUP(void *p) {
   gcFIXUP(m->body);
   gcFIXUP(m->et_body);
 
-  gcFIXUP(m->provides);
+  gcFIXUP(m->me);
-  gcFIXUP(m->provide_srcs);
+
-  gcFIXUP(m->provide_src_names);
   gcFIXUP(m->provide_protects);
-
-  gcFIXUP(m->kernel_exclusion);
-
   gcFIXUP(m->indirect_provides);
-  gcFIXUP(m->src_modidx);
   gcFIXUP(m->self_modidx);
 
   gcFIXUP(m->accessible);
@@ -2177,6 +2169,43 @@ static int module_val_FIXUP(void *p) {
 #define module_val_IS_CONST_SIZE 1
 
 
+static int module_exports_val_SIZE(void *p) {
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports));
+}
+
+static int module_exports_val_MARK(void *p) {
+  Scheme_Module_Exports *m = (Scheme_Module_Exports *)p;
+
+  gcMARK(m->provides);
+  gcMARK(m->provide_srcs);
+  gcMARK(m->provide_src_names);
+
+  gcMARK(m->kernel_exclusion);
+
+  gcMARK(m->src_modidx);
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports));
+}
+
+static int module_exports_val_FIXUP(void *p) {
+  Scheme_Module_Exports *m = (Scheme_Module_Exports *)p;
+
+  gcFIXUP(m->provides);
+  gcFIXUP(m->provide_srcs);
+  gcFIXUP(m->provide_src_names);
+
+  gcFIXUP(m->kernel_exclusion);
+
+  gcFIXUP(m->src_modidx);
+  return
+  gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports));
+}
+
+#define module_exports_val_IS_ATOMIC 0
+#define module_exports_val_IS_CONST_SIZE 1
+
+
 static int modidx_val_SIZE(void *p) {
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Modidx));

src/mzscheme/src/mzmarksrc.c

@@ -715,6 +715,7 @@ namespace_val {
 
   gcMARK(e->module);
   gcMARK(e->module_registry);
+  gcMARK(e->export_registry);
   gcMARK(e->insp);
 
   gcMARK(e->rename);
@@ -823,15 +824,10 @@ module_val {
   gcMARK(m->body);
   gcMARK(m->et_body);
 
-  gcMARK(m->provides);
+  gcMARK(m->me);
-  gcMARK(m->provide_srcs);
+
-  gcMARK(m->provide_src_names);
   gcMARK(m->provide_protects);
-
-  gcMARK(m->kernel_exclusion);
-
   gcMARK(m->indirect_provides);
-  gcMARK(m->src_modidx);
   gcMARK(m->self_modidx);
 
   gcMARK(m->accessible);
@@ -852,6 +848,21 @@ module_val {
   gcBYTES_TO_WORDS(sizeof(Scheme_Module));
 }
 
+module_exports_val {
+ mark:
+  Scheme_Module_Exports *m = (Scheme_Module_Exports *)p;
+
+  gcMARK(m->provides);
+  gcMARK(m->provide_srcs);
+  gcMARK(m->provide_src_names);
+
+  gcMARK(m->kernel_exclusion);
+
+  gcMARK(m->src_modidx);
+ size:
+  gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports));
+}
+
 modidx_val {
  mark:
   Scheme_Modidx *modidx = (Scheme_Modidx *)p;

src/mzscheme/src/number.c

@@ -2123,12 +2123,31 @@ static Scheme_Object *magnitude(int argc, Scheme_Object *argv[])
   if (SCHEME_COMPLEXP(o)) {
     Scheme_Object *r = _scheme_complex_real_part(o);
     Scheme_Object *i = _scheme_complex_imaginary_part(o);
-    Scheme_Object *m2;
+    Scheme_Object *a[1], *q;
+    a[0] = r;
+    r = scheme_abs(1, a);
+    a[0] = i;
+    i = scheme_abs(1, a);
     
-    m2 = scheme_bin_plus(scheme_bin_mult(r, r),
+    if (SAME_OBJ(r, scheme_make_integer(0)))
-			 scheme_bin_mult(i, i));
+      return i;
 
-    return scheme_sqrt(1, &m2);
+    if (scheme_bin_lt(i, r)) {
+      Scheme_Object *tmp;
+      tmp = i;
+      i = r;
+      r = tmp;
+    }
+    a[0] = r;
+    if (SCHEME_TRUEP(scheme_zero_p(1, a))) {
+      a[0] = i;
+      return scheme_exact_to_inexact(1, a);
+    }
+    q = scheme_bin_div(r, i);
+    q = scheme_bin_plus(scheme_make_integer(1),
+			scheme_bin_mult(q, q));
+    a[0] = q;
+    return scheme_bin_mult(i, scheme_sqrt(1, a));
   } else
     return scheme_abs(1, argv);
 }

src/mzscheme/src/port.c

@@ -1180,7 +1180,7 @@ static void register_port_wait()
 		  evt_output_port_p, 1);
 }
 
-static int pipe_char_count(Scheme_Object *p)
+XFORM_NONGCING static int pipe_char_count(Scheme_Object *p)
 {
   if (p) {
     Scheme_Pipe *pipe;
@@ -1202,7 +1202,7 @@ static void post_progress(Scheme_Input_Port *ip)
   ip->progress_evt = NULL;
 }
 
-static void inc_pos(Scheme_Port *ip, int a)
+XFORM_NONGCING static void inc_pos(Scheme_Port *ip, int a)
 {
   ip->column += a;
   ip->readpos += a;
@@ -1232,7 +1232,7 @@ static Scheme_Object *quick_plus(Scheme_Object *s, long v)
 
 #define state_len(state) ((state >> 3) & 0x7)
 
-static void do_count_lines(Scheme_Port *ip, const char *buffer, long offset, long got)
+XFORM_NONGCING static void do_count_lines(Scheme_Port *ip, const char *buffer, long offset, long got)
 {
   long i;
   int c, degot = 0;

src/mzscheme/src/schemef.h

@@ -524,7 +524,7 @@ MZ_EXTERN mzchar *scheme_utf8_decode_to_buffer(const unsigned char *s, int len,
 					       mzchar *buf, int blen);
 MZ_EXTERN mzchar *scheme_utf8_decode_to_buffer_len(const unsigned char *s, int len, 
 						   mzchar *buf, int blen, long *rlen);
-MZ_EXTERN int scheme_utf8_decode_count(const unsigned char *s, int start, int end, 
+XFORM_NONGCING MZ_EXTERN int scheme_utf8_decode_count(const unsigned char *s, int start, int end, 
 						      int *_state, int might_continue, int permissive);
 
 MZ_EXTERN int scheme_utf8_encode(const unsigned int *us, int start, int end, 
@@ -852,9 +852,6 @@ MZ_EXTERN Scheme_Object *scheme_make_modidx(Scheme_Object *path,
 				  Scheme_Object *base,
 				  Scheme_Object *resolved);
 
-MZ_EXTERN Scheme_Object *scheme_declare_module(Scheme_Object *shape, Scheme_Invoke_Proc ivk,
-				     Scheme_Invoke_Proc sivk, void *data, Scheme_Env *env);
-
 MZ_EXTERN Scheme_Object *scheme_apply_for_syntax_in_env(Scheme_Object *proc, Scheme_Env *env);
 
 MZ_EXTERN Scheme_Object *scheme_dynamic_require(int argc, Scheme_Object *argv[]);

src/mzscheme/src/schemex.h

@@ -429,7 +429,7 @@ mzchar *(*scheme_utf8_decode_to_buffer)(const unsigned char *s, int len,
 					       mzchar *buf, int blen);
 mzchar *(*scheme_utf8_decode_to_buffer_len)(const unsigned char *s, int len, 
 						   mzchar *buf, int blen, long *rlen);
-int (*scheme_utf8_decode_count)(const unsigned char *s, int start, int end, 
+XFORM_NONGCING MZ_EXTERN;
 						      int *_state, int might_continue, int permissive);
 int (*scheme_utf8_encode)(const unsigned int *us, int start, int end, 
 				 unsigned char *s, int dstart,
@@ -703,8 +703,6 @@ void (*scheme_protect_primitive_provide)(Scheme_Env *env, Scheme_Object *name);
 Scheme_Object *(*scheme_make_modidx)(Scheme_Object *path,
 				  Scheme_Object *base,
 				  Scheme_Object *resolved);
-Scheme_Object *(*scheme_declare_module)(Scheme_Object *shape, Scheme_Invoke_Proc ivk,
-				     Scheme_Invoke_Proc sivk, void *data, Scheme_Env *env);
 Scheme_Object *(*scheme_apply_for_syntax_in_env)(Scheme_Object *proc, Scheme_Env *env);
 Scheme_Object *(*scheme_dynamic_require)(int argc, Scheme_Object *argv[]);
 /*========================================================================*/

src/mzscheme/src/schemex.inc

@@ -285,7 +285,7 @@
   scheme_extension_table->scheme_utf8_decode_prefix = scheme_utf8_decode_prefix;
   scheme_extension_table->scheme_utf8_decode_to_buffer = scheme_utf8_decode_to_buffer;
   scheme_extension_table->scheme_utf8_decode_to_buffer_len = scheme_utf8_decode_to_buffer_len;
-  scheme_extension_table->scheme_utf8_decode_count = scheme_utf8_decode_count;
+  scheme_extension_table->MZ_EXTERN = MZ_EXTERN;
   scheme_extension_table->scheme_utf8_encode = scheme_utf8_encode;
   scheme_extension_table->scheme_utf8_encode_all = scheme_utf8_encode_all;
   scheme_extension_table->scheme_utf8_encode_to_buffer = scheme_utf8_encode_to_buffer;
@@ -475,7 +475,6 @@
   scheme_extension_table->scheme_finish_primitive_module = scheme_finish_primitive_module;
   scheme_extension_table->scheme_protect_primitive_provide = scheme_protect_primitive_provide;
   scheme_extension_table->scheme_make_modidx = scheme_make_modidx;
-  scheme_extension_table->scheme_declare_module = scheme_declare_module;
   scheme_extension_table->scheme_apply_for_syntax_in_env = scheme_apply_for_syntax_in_env;
   scheme_extension_table->scheme_dynamic_require = scheme_dynamic_require;
   scheme_extension_table->scheme_intern_symbol = scheme_intern_symbol;

src/mzscheme/src/schemexm.h

@@ -285,7 +285,7 @@
 #define scheme_utf8_decode_prefix (scheme_extension_table->scheme_utf8_decode_prefix)
 #define scheme_utf8_decode_to_buffer (scheme_extension_table->scheme_utf8_decode_to_buffer)
 #define scheme_utf8_decode_to_buffer_len (scheme_extension_table->scheme_utf8_decode_to_buffer_len)
-#define scheme_utf8_decode_count (scheme_extension_table->scheme_utf8_decode_count)
+#define MZ_EXTERN (scheme_extension_table->MZ_EXTERN)
 #define scheme_utf8_encode (scheme_extension_table->scheme_utf8_encode)
 #define scheme_utf8_encode_all (scheme_extension_table->scheme_utf8_encode_all)
 #define scheme_utf8_encode_to_buffer (scheme_extension_table->scheme_utf8_encode_to_buffer)
@@ -475,7 +475,6 @@
 #define scheme_finish_primitive_module (scheme_extension_table->scheme_finish_primitive_module)
 #define scheme_protect_primitive_provide (scheme_extension_table->scheme_protect_primitive_provide)
 #define scheme_make_modidx (scheme_extension_table->scheme_make_modidx)
-#define scheme_declare_module (scheme_extension_table->scheme_declare_module)
 #define scheme_apply_for_syntax_in_env (scheme_extension_table->scheme_apply_for_syntax_in_env)
 #define scheme_dynamic_require (scheme_extension_table->scheme_dynamic_require)
 #define scheme_intern_symbol (scheme_extension_table->scheme_intern_symbol)

src/mzscheme/src/schpriv.h

@@ -593,7 +593,8 @@ void scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *modname,
 void scheme_extend_module_rename_with_kernel(Scheme_Object *rn, Scheme_Object *nominal_src);
 void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info);
 void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
-				       Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to);
+				       Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to,
+				       Scheme_Hash_Table *export_registry);
 void scheme_remove_module_rename(Scheme_Object *mrn,
 				 Scheme_Object *localname);
 void scheme_append_module_rename(Scheme_Object *src, Scheme_Object *dest);
@@ -626,9 +627,11 @@ Scheme_Object *scheme_stx_property(Scheme_Object *_stx,
 				   Scheme_Object *val);
 
 Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, long shift,
-				      Scheme_Object *old_midx, Scheme_Object *new_midx);
+				      Scheme_Object *old_midx, Scheme_Object *new_midx,
+				      Scheme_Hash_Table *export_registry);
 Scheme_Object *scheme_stx_phase_shift_as_rename(long shift,
-						Scheme_Object *old_midx, Scheme_Object *new_midx);
+						Scheme_Object *old_midx, Scheme_Object *new_midx,
+						Scheme_Hash_Table *export_registry);
 
 int scheme_stx_list_length(Scheme_Object *list);
 int scheme_stx_proper_list_length(Scheme_Object *list);
@@ -1420,7 +1423,7 @@ Scheme_Object *scheme_named_map_1(char *,
 				  Scheme_Object *(*fun)(Scheme_Object*, Scheme_Object *form),
 				  Scheme_Object *lst, Scheme_Object *form);
 
-int scheme_strncmp(const char *a, const char *b, int len);
+XFORM_NONGCING int scheme_strncmp(const char *a, const char *b, int len);
 
 #define _scheme_make_char(ch) scheme_make_character(ch)
 
@@ -2001,6 +2004,7 @@ struct Scheme_Env {
 
   Scheme_Hash_Table *module_registry; /* symbol -> module ; loaded modules,
 					 shared with modules in same space */
+  Scheme_Hash_Table *export_registry; /* symbol -> module-exports */
   Scheme_Object *insp; /* instantiation-time inspector, for granting
 			  protected access and certificates */
 
@@ -2049,9 +2053,9 @@ typedef struct Scheme_Module
 
   Scheme_Object *modname;
 
-  Scheme_Object *et_requires; /* list of module access paths */
+  Scheme_Object *et_requires;  /* list of symbol-or-module-path-index */
-  Scheme_Object *requires;    /* list of module access paths */
+  Scheme_Object *requires;     /* list of symbol-or-module-path-index */
-  Scheme_Object *tt_requires; /* list of module access paths */
+  Scheme_Object *tt_requires;  /* list of symbol-or-module-path-index */
 
   Scheme_Invoke_Proc prim_body;
   Scheme_Invoke_Proc prim_et_body;
@@ -2061,20 +2065,12 @@ typedef struct Scheme_Module
 
   char functional, et_functional, tt_functional, no_cert;
   
-  Scheme_Object **provides;          /* symbols (extenal names) */
+  struct Scheme_Module_Exports *me;
-  Scheme_Object **provide_srcs;      /* module access paths, #f for self */
+
-  Scheme_Object **provide_src_names; /* symbols (original internal names) */
   char *provide_protects;            /* 1 => protected, 0 => not */
-  int num_provides;
-  int num_var_provides;              /* non-syntax listed first in provides */
-
-  int reprovide_kernel;              /* if true, extend provides with kernel's */
-  Scheme_Object *kernel_exclusion;  /* we allow one exn, but it must be shadowed */
-
   Scheme_Object **indirect_provides; /* symbols (internal names) */
   int num_indirect_provides;
 
-  Scheme_Object *src_modidx;  /* the one used in marshalled syntax */
   Scheme_Object *self_modidx;
 
   Scheme_Hash_Table *accessible;
@@ -2094,6 +2090,26 @@ typedef struct Scheme_Module
   Scheme_Object *rn_stx, *et_rn_stx, *tt_rn_stx;
 } Scheme_Module;
 
+typedef struct Scheme_Module_Exports
+{
+  /* Scheme_Module_Exports is separate from Scheme_Module
+     so that we can create a global table mapping export
+     keys to exports. This mapping is used to lazily 
+     unmarshal syntax-object context. */
+  MZTAG_IF_REQUIRED
+
+  Scheme_Object **provides;          /* symbols (extenal names) */
+  Scheme_Object **provide_srcs;      /* module access paths, #f for self */
+  Scheme_Object **provide_src_names; /* symbols (original internal names) */
+  int num_provides;
+  int num_var_provides;              /* non-syntax listed first in provides */
+
+  int reprovide_kernel;              /* if true, extend provides with kernel's */
+  Scheme_Object *kernel_exclusion;  /* we allow one exn, but it must be shadowed */
+
+  Scheme_Object *src_modidx;  /* the one used in marshalled syntax */
+} Scheme_Module_Exports;
+
 typedef struct Scheme_Modidx {
   Scheme_Object so; /* scheme_module_index_type */
 
@@ -2125,7 +2141,7 @@ Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env);
 Scheme_Env *scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, int new_exp_module_tree);
 int scheme_is_module_env(Scheme_Comp_Env *env);
 
-Scheme_Object *scheme_module_resolve(Scheme_Object *modidx);
+Scheme_Object *scheme_module_resolve(Scheme_Object *modidx, int load_it);
 Scheme_Env *scheme_module_access(Scheme_Object *modname, Scheme_Env *env, int rev_mod_phase);
 void scheme_module_force_lazy(Scheme_Env *env, int previous);
 

src/mzscheme/src/schvers.h

@@ -9,6 +9,6 @@
 
 
 #define MZSCHEME_VERSION_MAJOR 350
-#define MZSCHEME_VERSION_MINOR 1
+#define MZSCHEME_VERSION_MINOR 2
 
-#define MZSCHEME_VERSION "350.1" _MZ_SPECIAL_TAG
+#define MZSCHEME_VERSION "350.2" _MZ_SPECIAL_TAG

src/mzscheme/src/startup.inc

@@ -2867,14 +2867,29 @@
 "(define(make-standard-module-name-resolver orig-namespace)"
 "(define planet-resolver #f)"
 "(define standard-module-name-resolver"
-"(lambda(s relto stx)"
+"(case-lambda "
+"((s) "
+"(when planet-resolver"
+"(planet-resolver s))"
+"(let((ht(hash-table-get"
+" -module-hash-table-table"
+"(namespace-module-registry(current-namespace))"
+"(lambda()"
+"(let((ht(make-hash-table)))"
+"(hash-table-put! -module-hash-table-table"
+"(namespace-module-registry(current-namespace))"
+" ht)"
+" ht)))))"
+"(hash-table-put! ht s 'attach)))"
+"((s relto stx)(standard-module-name-resolver s relto stx #t))"
+"((s relto stx load?)"
 "(cond"
 "((and(pair? s)(eq?(car s) 'planet))"
 "(unless planet-resolver"
 "(parameterize((current-namespace orig-namespace))"
 " (set! planet-resolver (dynamic-require '(lib \"resolver.ss\" \"planet\") 'planet-module-name-resolver))))"
-"(planet-resolver s relto stx))"
+"(planet-resolver s relto stx load?))"
-"(s"
+"(else"
 "(let((get-dir(lambda()"
 "(or(and relto"
 "(if(eq? relto -prev-relto)"
@@ -2993,6 +3008,7 @@
 "(namespace-module-registry(current-namespace))"
 " ht)"
 " ht)))))"
+"(when load?"
 "(let((got(hash-table-get ht modname(lambda() #f))))"
 "(when got"
 "(unless(or(symbol? got)(equal? suffix got))"
@@ -3023,7 +3039,7 @@
 "((current-load/use-compiled) "
 " filename "
 "(string->symbol(bytes->string/latin-1(path->bytes no-sfx)))))))"
-"(hash-table-put! ht modname suffix)))"
+"(hash-table-put! ht modname suffix))))"
 "(when(and(not(vector? s-parsed))"
 "(or(string? s)"
 "(and(pair? s)"
@@ -3039,20 +3055,7 @@
 " abase"
 " modname"
 " suffix)))"
-" modname)))))))"
+" modname)))))))))))"
-"(else"
-"(when planet-resolver"
-"(planet-resolver s relto stx))"
-"(let((ht(hash-table-get"
-" -module-hash-table-table"
-"(namespace-module-registry(current-namespace))"
-"(lambda()"
-"(let((ht(make-hash-table)))"
-"(hash-table-put! -module-hash-table-table"
-"(namespace-module-registry(current-namespace))"
-" ht)"
-" ht)))))"
-"(hash-table-put! ht relto 'attach))))))"
 " standard-module-name-resolver)"
 "(define find-library-collection-paths"
 "(case-lambda"

src/mzscheme/src/startup.ss

@@ -3303,7 +3303,24 @@
   (define (make-standard-module-name-resolver orig-namespace)
     (define planet-resolver #f)
     (define standard-module-name-resolver
-      (lambda (s relto stx)
+      (case-lambda 
+       [(s) 
+	;; Just register s as loaded
+	(when planet-resolver
+	  ;; Let planet resolver register, too:
+	  (planet-resolver s))
+	(let ([ht (hash-table-get
+		   -module-hash-table-table
+		   (namespace-module-registry (current-namespace))
+		   (lambda ()
+		     (let ([ht (make-hash-table)])
+		       (hash-table-put! -module-hash-table-table
+					(namespace-module-registry (current-namespace))
+					ht)
+		       ht)))])
+	  (hash-table-put! ht s 'attach))]
+       [(s relto stx) (standard-module-name-resolver s relto stx #t)]
+       [(s relto stx load?)
 	;; If stx is not #f, raise syntax error for ill-formed paths
 	;; If s is #f, call to resolver is a notification from namespace-attach-module
 	(cond
@@ -3311,8 +3328,8 @@
 	  (unless planet-resolver
 	    (parameterize ([current-namespace orig-namespace])
 	      (set! planet-resolver (dynamic-require '(lib "resolver.ss" "planet") 'planet-module-name-resolver))))
-	  (planet-resolver s relto stx)]
+	  (planet-resolver s relto stx load?)]
-	 [s
+	 [else
 	  (let ([get-dir (lambda ()
 			   (or (and relto
 				    (if (eq? relto -prev-relto)
@@ -3435,6 +3452,7 @@
 						    ht)
 				   ht)))])
 		      ;; Loaded already?
+		      (when load?
 			(let ([got (hash-table-get ht modname (lambda () #f))])
 			  (when got
 			    ;; Check the suffix, which gets lost when creating a key:
@@ -3467,7 +3485,7 @@
 				  ((current-load/use-compiled) 
 				   filename 
 				   (string->symbol (bytes->string/latin-1 (path->bytes no-sfx)))))))
-			  (hash-table-put! ht modname suffix)))
+			    (hash-table-put! ht modname suffix))))
 		      ;; If a `lib' path, cache pathname manipulations
 		      (when (and (not (vector? s-parsed))
 				 (or (string? s)
@@ -3485,22 +3503,7 @@
 						 modname
 						 suffix)))
 		      ;; Result is the module name:
-		      modname))))))]
+		      modname))))))])]))
-	 [else
-	  ;; Just register relto as loaded
-	  (when planet-resolver
-	    ;; Let planet resolver register, too:
-	    (planet-resolver s relto stx))
-	  (let ([ht (hash-table-get
-		     -module-hash-table-table
-		     (namespace-module-registry (current-namespace))
-		     (lambda ()
-		       (let ([ht (make-hash-table)])
-			 (hash-table-put! -module-hash-table-table
-					  (namespace-module-registry (current-namespace))
-					  ht)
-			 ht)))])
-	    (hash-table-put! ht relto 'attach))])))
     standard-module-name-resolver)
     
   (define find-library-collection-paths

src/mzscheme/src/string.c

@@ -268,12 +268,12 @@ static int mz_char_strcmp(const char *who, const mzchar *str1, int l1, const mzc
 static int mz_char_strcmp_ci(const char *who, const mzchar *str1, int l1, const mzchar *str2, int l2, int locale, int size_shortcut);
 static int mz_strcmp(const char *who, unsigned char *str1, int l1, unsigned char *str2, int l2);
 
-static int utf8_decode_x(const unsigned char *s, int start, int end,
+XFORM_NONGCING static int utf8_decode_x(const unsigned char *s, int start, int end,
 					unsigned int *us, int dstart, int dend,
 					long *ipos, long *jpos,
 					char compact, char utf16,
 					int *state, int might_continue, int permissive);
-static int utf8_encode_x(const unsigned int *us, int start, int end,
+XFORM_NONGCING static int utf8_encode_x(const unsigned int *us, int start, int end,
 					unsigned char *s, int dstart, int dend,
 					long *_ipos, long *_opos, char utf16);
 

src/mzscheme/src/stxobj.c

@@ -213,8 +213,10 @@ static Module_Renames *krn;
          simple lexical renames (not ribs) and marks, only, and it's
          inserted into a chain heuristically
 
-   - A wrap-elem (box (vector <num> <midx> <midx>)) is a phase shift
+   - A wrap-elem (box (vector <num> <midx> <midx> <export-registry>))
-         by <num>, remapping the first <midx> to the second <midx>
+         is a phase shift by <num>, remapping the first <midx> to the 
+         second <midx>; the <export-registry> part is for finding
+         modules to unmarshal import renamings
 
    - A wrap-elem '* is a mark barrier, which is applied to the
          result of an expansion so that top-level marks do not
@@ -1327,14 +1329,16 @@ Scheme_Hash_Table *scheme_module_rename_marked_names(Scheme_Object *rn)
 }
 
 static void unmarshal_rename(Module_Renames *mrn,
-			     Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to)
+			     Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to,
+			     Scheme_Hash_Table *export_registry)
 {
   Scheme_Object *l;
 
   mrn->needs_unmarshal = 0;
   for (l = mrn->unmarshal_info; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
     scheme_do_module_rename_unmarshal((Scheme_Object *)mrn, SCHEME_CAR(l),
-				      modidx_shift_from, modidx_shift_to);
+				      modidx_shift_from, modidx_shift_to,
+				      export_registry);
   }
 }
 
@@ -1402,22 +1406,25 @@ Scheme_Object *scheme_add_mark_barrier(Scheme_Object *o)
   return scheme_add_rename(o, barrier_symbol);
 }
 
-Scheme_Object *scheme_stx_phase_shift_as_rename(long shift, Scheme_Object *old_midx, Scheme_Object *new_midx)
+Scheme_Object *scheme_stx_phase_shift_as_rename(long shift, Scheme_Object *old_midx, Scheme_Object *new_midx,
+						Scheme_Hash_Table *export_registry)
 {
-  if (shift || new_midx) {
+  if (shift || new_midx || export_registry) {
     Scheme_Object *vec;
     
     if (last_phase_shift
 	&& ((vec = SCHEME_BOX_VAL(last_phase_shift)))
 	&& (SCHEME_VEC_ELS(vec)[0] == scheme_make_integer(shift))
 	&& (SCHEME_VEC_ELS(vec)[1] == (new_midx ? old_midx : scheme_false))
-	&& (SCHEME_VEC_ELS(vec)[2] == (new_midx ? new_midx : scheme_false))) {
+	&& (SCHEME_VEC_ELS(vec)[2] == (new_midx ? new_midx : scheme_false))
+	&& (SCHEME_VEC_ELS(vec)[3] == (export_registry ? (Scheme_Object *)export_registry : scheme_false))) {
       /* use the old one */
     } else {
-      vec = scheme_make_vector(3, NULL);
+      vec = scheme_make_vector(4, NULL);
       SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(shift);
       SCHEME_VEC_ELS(vec)[1] = (new_midx ? old_midx : scheme_false);
       SCHEME_VEC_ELS(vec)[2] = (new_midx ? new_midx : scheme_false);
+      SCHEME_VEC_ELS(vec)[3] = (export_registry ? (Scheme_Object *)export_registry : scheme_false);
 
       last_phase_shift = scheme_box(vec);
     }
@@ -1428,14 +1435,15 @@ Scheme_Object *scheme_stx_phase_shift_as_rename(long shift, Scheme_Object *old_m
 }
 
 Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, long shift,
-				      Scheme_Object *old_midx, Scheme_Object *new_midx)
+				      Scheme_Object *old_midx, Scheme_Object *new_midx,
+				      Scheme_Hash_Table *export_registry)
 /* Shifts the phase on a syntax object in a module. A 0 shift might be
    used just to re-direct relative module paths. new_midx might be
-   NULL to shift without redirection. */
+   NULL to shift without redirection. And so on. */
 {
   Scheme_Object *ps;
 
-  ps = scheme_stx_phase_shift_as_rename(shift, old_midx, new_midx);
+  ps = scheme_stx_phase_shift_as_rename(shift, old_midx, new_midx, export_registry);
   if (ps)
     return scheme_add_rename(stx, ps);  
   else
@@ -1781,8 +1789,8 @@ int scheme_stx_certified(Scheme_Object *stx, Scheme_Object *extra_certs,
 	  else
 	    cert_modidx = certs->modidx;
 	  
-	  a = scheme_module_resolve(home_modidx);
+	  a = scheme_module_resolve(home_modidx, 0);
-	  b = scheme_module_resolve(cert_modidx);
+	  b = scheme_module_resolve(cert_modidx, 0);
 	} else
 	  a = b = NULL;
 	
@@ -2057,7 +2065,7 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
     else
       cert = INACTIVE_CERTS(stx);
     
-    cert = cons_cert(mark, menv->link_midx ? menv->link_midx : menv->module->src_modidx, 
+    cert = cons_cert(mark, menv->link_midx ? menv->link_midx : menv->module->me->src_modidx, 
 		     menv->module->insp, key, cert);
 
     if (active) {
@@ -2665,6 +2673,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
   Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL;
   long orig_phase = phase;
   Scheme_Object *bdg = NULL;
+  Scheme_Hash_Table *export_registry = NULL;
 
   if (_wraps) {
     WRAP_POS_COPY(wraps, *_wraps);
@@ -2718,7 +2727,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
 	  Scheme_Object *rename, *nominal = NULL, *glob_id;
 
 	  if (mrn->needs_unmarshal)
-	    unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to);
+	    unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to, export_registry);
 	  
 	  if (mrn->marked_names) {
 	    /* Resolve based on rest of wraps: */
@@ -2830,6 +2839,13 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
 	
 	modidx_shift_from = src;
       }
+
+      {
+	Scheme_Object *er;
+	er = SCHEME_VEC_ELS(vec)[3];
+	if (SCHEME_TRUEP(er))
+	  export_registry = (Scheme_Hash_Table *)er;
+      }
     } else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps))
 		       && !no_lexical)) {
       /* Lexical rename: */
@@ -3079,8 +3095,8 @@ int scheme_stx_free_eq(Scheme_Object *a, Scheme_Object *b, long phase)
   a = resolve_env(NULL, a, phase, 1, NULL, NULL);
   b = resolve_env(NULL, b, phase, 1, NULL, NULL);
 
-  a = scheme_module_resolve(a);
+  a = scheme_module_resolve(a, 0);
-  b = scheme_module_resolve(b);
+  b = scheme_module_resolve(b, 0);
 
   /* Same binding environment? */
   return SAME_OBJ(a, b);
@@ -3112,8 +3128,8 @@ int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase)
   a = resolve_env(NULL, a, phase, 1, NULL, NULL);
   b = resolve_env(NULL, b, phase, 1, NULL, NULL);
 
-  a = scheme_module_resolve(a);
+  a = scheme_module_resolve(a, 0);
-  b = scheme_module_resolve(b);
+  b = scheme_module_resolve(b, 0);
 
   /* Same binding environment? */
   return SAME_OBJ(a, b);
@@ -3254,7 +3270,7 @@ Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve)
   }
 
   if (SCHEME_TRUEP(srcmod) && resolve)
-    srcmod = scheme_module_resolve(srcmod);
+    srcmod = scheme_module_resolve(srcmod, 0);
 
   return srcmod;
 }
@@ -3993,6 +4009,18 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
       }
       /* If l is the end, don't need the phase shift */
       if (!WRAP_POS_END_P(l)) {
+	/* Need the phase shift, but drop the export table, if any: */
+	Scheme_Object *aa;
+	aa = SCHEME_BOX_VAL(a);
+	if (SCHEME_TRUEP(SCHEME_VEC_ELS(aa)[3])) {
+	  a = scheme_make_vector(4, NULL);
+	  SCHEME_VEC_ELS(a)[0] = SCHEME_VEC_ELS(aa)[0];
+	  SCHEME_VEC_ELS(a)[1] = SCHEME_VEC_ELS(aa)[1];
+	  SCHEME_VEC_ELS(a)[2] = SCHEME_VEC_ELS(aa)[2];
+	  SCHEME_VEC_ELS(a)[3] = scheme_false;
+	  a = scheme_box(a);
+	}
+
 	stack = CONS(a, stack);
 	stack_size++;
       }
@@ -5604,7 +5632,7 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
 	/* Imported */
 	int pos;
 	
-	m = scheme_module_resolve(m);
+	m = scheme_module_resolve(m, 0);
 	pos = scheme_module_export_position(m, scheme_get_env(NULL), a);
 	if (pos < 0)
 	  return scheme_false;

src/mzscheme/src/stypes.h

@@ -215,6 +215,7 @@ enum {
   scheme_rt_native_code,                /* 194 */
   scheme_rt_native_code_plus_case,      /* 195 */
   scheme_rt_jitter_data,                /* 196 */
+  scheme_rt_module_exports,             /* 197 */
 #endif
 
   _scheme_last_type_

src/mzscheme/src/type.c

@@ -519,6 +519,7 @@ void scheme_register_traversers(void)
   GC_REG_TRAV(scheme_stx_type, stx_val);
   GC_REG_TRAV(scheme_stx_offset_type, stx_off_val);
   GC_REG_TRAV(scheme_module_type, module_val);
+  GC_REG_TRAV(scheme_rt_module_exports, module_exports_val);
   GC_REG_TRAV(scheme_module_index_type, modidx_val);
 
   GC_REG_TRAV(scheme_security_guard_type, guard_val);