Catch up to now.

svn: r12742

collects/compiler/cffi.scrbl

@@ -272,7 +272,6 @@ Expands to a use of @scheme[c-declare] with the content of
 @scheme[path-spec]. The @scheme[path-spec] has the same form as for
 @schememodname[mzlib/include]'s @scheme[include].}
 
-
 @(bibliography
   (bib-entry
    #:key "Feeley98"

collects/compiler/zo-parse.ss

@@ -197,7 +197,9 @@
     [`(,name ,self-modidx ,lang-info ,functional? ,et-functional?
              ,rename ,max-let-depth ,dummy
              ,prefix ,kernel-exclusion ,reprovide-kernel?
-             ,indirect-provides ,num-indirect-provides ,protects
+             ,indirect-provides ,num-indirect-provides 
+             ,indirect-et-provides ,num-indirect-et-provides 
+             ,protects ,et-protects
              ,provide-phase-count . ,rest)
      (let ([phase-data (take rest (* 8 provide-phase-count))])
        (match (list-tail rest (* 8 provide-phase-count))

collects/macro-debugger/model/reductions.ss

@@ -272,7 +272,7 @@
           [#:pass1]
           [Expr ?form first]
           [#:do (when (pair? (available-lift-stxs))
-                  (error 'lift-deriv "available lifts left over"))]
+                  (lift-error 'lift-deriv "available lifts left over"))]
           [#:let begin-stx (stx-car lifted-stx)]
           [#:with-visible-form
            ;; If no lifts visible, then don't show begin-wrapping
@@ -299,7 +299,7 @@
           [#:pass1]
           [Expr ?form first]
           [#:do (when (pair? (available-lift-stxs))
-                  (error 'lift/let-deriv "available lifts left over"))]
+                  (lift-error 'lift/let-deriv "available lifts left over"))]
           [#:let visible-lifts (visible-lift-stxs)]
           [#:with-visible-form
            [#:left-foot]
@@ -388,7 +388,7 @@
          [#:pass1]
          [Expr ?form inner]
          [#:do (when (pair? (available-lift-stxs))
-                 (error 'local-expand/capture-lifts "available lifts left over"))]
+                 (lift-error 'local-expand/capture-lifts "available lifts left over"))]
          [#:let visible-lifts (visible-lift-stxs)]
          [#:with-visible-form
           [#:left-foot]
@@ -402,7 +402,7 @@
     [(struct local-lift (expr id))
      ;; FIXME: add action
      (R [#:do (unless (pair? (available-lift-stxs))
-                (error 'local-lift "out of lifts!"))
+                (lift-error 'local-lift "out of lifts!"))
               (when (pair? (available-lift-stxs))
                 (let ([lift-d (car (available-lift-stxs))]
                       [lift-stx (car (available-lift-stxs))])
@@ -576,7 +576,7 @@
           [#:pass1]
           [Expr ?firstL head]
           [#:do (when (pair? (available-lift-stxs))
-                  (error 'mod:lift "available lifts left over"))]
+                  (lift-error 'mod:lift "available lifts left over"))]
           [#:let visible-lifts (visible-lift-stxs)]
           [#:pattern ?forms]
           [#:pass2]
@@ -602,3 +602,10 @@
      (R [#:pattern (?firstC . ?rest)]
         [Expr ?firstC head]
         [ModulePass ?rest rest])]))
+
+
+;; lift-error
+(define (lift-error sym . args)
+  (apply fprintf (current-error-port) args)
+  (when #t
+    (apply error sym args)))

collects/repos-time-stamp/stamp.ss

@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "3dec2008")
+#lang scheme/base (provide stamp) (define stamp "8dec2008")

collects/scheme/private/class-internal.ss

@@ -1654,8 +1654,7 @@
 			      ;; Need to attach srcloc to this definition:
 			      (syntax/loc stx
 				(define-syntaxes (id ...)
-				  (values (make-private-name (quote-syntax id) 
+				  (values (make-private-name (quote-syntax id) (quote-syntax gen-id))
-							     ((syntax-local-certifier) (quote-syntax gen-id)))
 					  ...)))])
 		 (syntax/loc stx
 		   (begin

collects/scheme/private/define-struct.ss

@@ -424,47 +424,46 @@
                             (let ([protect (lambda (sel)
                                              (and sel
                                                   (if (syntax-e sel)
-                                                      #`(c (quote-syntax #,sel))
+                                                      #`(quote-syntax #,sel)
                                                       sel)))]
 				  [mk-info (if super-info-checked?
 					       #'make-checked-struct-info
 					       #'make-struct-info)])
                               (quasisyntax/loc stx
                                 (define-syntaxes (#,id)
-                                  (let ([c (syntax-local-certifier)])
+                                  (#,mk-info
-                                    (#,mk-info
+                                   (lambda ()
-                                     (lambda ()
+                                     (list
-                                       (list
+                                      (quote-syntax #,struct:)
-                                        (c (quote-syntax #,struct:))
+                                      (quote-syntax #,make-)
-                                        (c (quote-syntax #,make-))
+                                      (quote-syntax #,?)
-                                        (c (quote-syntax #,?))
+                                      (list
-                                        (list
+                                       #,@(map protect (reverse sels))
-                                         #,@(map protect (reverse sels))
+                                       #,@(if super-info
-                                         #,@(if super-info
+                                              (map protect (list-ref super-info 3))
-                                                (map protect (list-ref super-info 3))
-                                                (if super-expr
-                                                    '(#f)
-                                                    null)))
-                                        (list
-                                         #,@(reverse
-                                             (let loop ([fields fields][sets sets])
-                                               (cond
-                                                [(null? fields) null]
-                                                [(not (or mutable? (field-mutable? (car fields))))
-                                                 (cons #f (loop (cdr fields) sets))]
-                                                [else
-                                                 (cons (protect (car sets))
-                                                       (loop (cdr fields) (cdr sets)))])))
-                                         #,@(if super-info
-                                                (map protect (list-ref super-info 4))
-                                                (if super-expr
-                                                    '(#f)
-                                                    null)))
-                                        #,(if super-id
-                                              (protect super-id)
                                               (if super-expr
-                                                  #f
+                                                  '(#f)
-                                                  #t))))))))))])
+                                                  null)))
+                                      (list
+                                       #,@(reverse
+                                           (let loop ([fields fields][sets sets])
+                                             (cond
+                                              [(null? fields) null]
+                                              [(not (or mutable? (field-mutable? (car fields))))
+                                               (cons #f (loop (cdr fields) sets))]
+                                              [else
+                                               (cons (protect (car sets))
+                                                     (loop (cdr fields) (cdr sets)))])))
+                                       #,@(if super-info
+                                              (map protect (list-ref super-info 4))
+                                              (if super-expr
+                                                  '(#f)
+                                                  null)))
+                                      #,(if super-id
+                                            (protect super-id)
+                                            (if super-expr
+                                                #f
+                                                #t)))))))))])
                      (let ([result
                             (cond
                              [(and (not omit-define-values?) (not omit-define-syntaxes?))

collects/scheme/private/for.ss

@@ -100,8 +100,7 @@
       ;; down to all the relevant identifiers and expressions:
       (define (recert s) (syntax-recertify s src-stx (current-inspector) cert-key))
       (define (cert s) (certifier (recert s) cert-key introducer))
-      (define (map-cert s) (map (lambda (s) (certifier (recert s) cert-key #;introducer))
+      (define (map-cert s) (map cert (syntax->list s)))
-                                (syntax->list s)))
 
       (syntax-case clause (:do-in)
         [[(id ...) (:do-in ([(outer-id ...) outer-expr] ...)

collects/scheme/private/more-scheme.ss

@@ -168,18 +168,23 @@
      (check-for-break)))
 
   (define (select-handler/no-breaks e bpz l)
-    (cond
+    (with-continuation-mark 
-     [(null? l)
+        break-enabled-key
-      (raise e)]
+        ;; make a fresh thread cell so that the shared one isn't mutated
-     [((caar l) e)
+        (make-thread-cell #f)
-      (begin0
+      (let loop ([l l])
-       ((cdar l) e)
+        (cond
-       (with-continuation-mark 
+         [(null? l)
-	   break-enabled-key
+          (raise e)]
-	   bpz
+         [((caar l) e)
-	 (check-for-break)))]
+          (begin0
-     [else
+           ((cdar l) e)
-      (select-handler/no-breaks e bpz (cdr l))]))
+           (with-continuation-mark 
+               break-enabled-key
+               bpz
+             (check-for-break)))]
+         [else
+          (loop (cdr l))]))))
 
   (define (select-handler/breaks-as-is e bpz l)
     (cond

collects/scribblings/guide/certificates.scrbl

@@ -170,7 +170,7 @@ be transferred from one syntax object to another. Such transfers are
 allowed because a macro transformer with access to the syntax object
 could already wrap it with an arbitrary context before activating the
 certificates. In practice, transferring inactive certificates is
-useful mainly to macros that implement to new template forms, such as
+useful mainly to macros that implement new template forms, such as
 @scheme[syntax/loc].
 
 @;------------------------------------------------------------------------

collects/scribblings/reference/exns.scrbl

@@ -15,7 +15,7 @@ handler} for a primitive error is always an instance of the
 @scheme[message] field that is a string, the primitive error message.
 The default exception handler recognizes exception values with the
 @scheme[exn?] predicate and passes the error message to the current
-error display handler (see @scheme[error-display-handler]).
+@tech{error display handler} (see @scheme[error-display-handler]).
 
 Primitive procedures that accept a procedure argument with a
 particular required arity (e.g., @scheme[call-with-input-file],
@@ -80,7 +80,7 @@ In all cases, the constructed message string is passed to
 
 Like @scheme[error], but constructs an exception with
 @scheme[make-exn:fail:user] instead of @scheme[make-exn:fail]. The
-default error display handler does not show a ``stack trace'' for
+default @tech{error display handler} does not show a ``stack trace'' for
 @scheme[exn:fail:user] exceptions (see @secref["contmarks"]), so
 @scheme[raise-user-error] should be used for errors that are intended
 for end users.}
@@ -221,16 +221,16 @@ it returns, an exception is raised (to be handled by an exception
 handler that reports both the original and newly raised exception).
 
 The default uncaught-exception handler prints an error message using
-the current error display handler (see @scheme[error-display-handler])
+the current @tech{error display handler} (see @scheme[error-display-handler])
 and then escapes by calling the current error escape handler (see
 @scheme[error-escape-handler]). The call to each handler is
 @scheme[parameterize]d to set @scheme[error-display-handler] to the
-default error display handler, and it is @scheme[parameterize-break]ed
+default @tech{error display handler}, and it is @scheme[parameterize-break]ed
 to disable breaks. The call to the error escape handler is further
 parameterized to set @scheme[error-escape-handler] to the default
 error escape handler.
 
-When the current error display handler is the default handler, then the
+When the current @tech{error display handler} is the default handler, then the
 error-display call is parameterized to install an emergency error
 display handler that attempts to print directly to a console and never
 fails.}
@@ -322,7 +322,7 @@ argument if it is an @scheme[exn] value but not an
 the second argument to highlight source locations.}
 
 To report a run-time error, use @scheme[raise] or procedures like
-@scheme[error], instead of calling the error display procedure
+@scheme[error], instead of calling the error display handler
 directly.}
 
 @defparam[error-print-width width (and exact-integer? (>=/c 3))]{
@@ -333,7 +333,7 @@ message.}
 
 @defparam[error-print-context-length cnt exact-nonnegative-integer?]{
 
-A parameter whose value is used by the default error display handler
+A parameter whose value is used by the default @tech{error display handler}
 as the maximum number of lines of context (or ``stack trace'') to
 print; a single ``...'' line is printed if more lines are available
 after the first @scheme[cnt] lines. A @scheme[0] value for
@@ -504,13 +504,14 @@ interrupted computation.}
 
 @defthing[prop:exn:srclocs struct-type-property?]{
 
-A property that identifiers structure types that provide a list of
+A property that identifies structure types that provide a list of
 @scheme[srcloc] values. The property is normally attached to structure
 types used to represent exception information.
 
 The property value must be a procedure that accepts a single
 value---the structure type instance from which to extract source
-locations---and returns a list of @scheme[srcloc]s.}
+locations---and returns a list of @scheme[srcloc]s. Some @tech{error
+display handlers} use only the first returned location.}
 
 
 @defproc[(exn:srclocs? [v any/c]) boolean?]{
@@ -520,7 +521,7 @@ property, @scheme[#f] otherwise.}
 
 
 @defproc[(exn:srclocs-accessor [v exn:srclocs?])
-         (exn:srclocs?. -> . (listof srcloc))]{
+         (exn:srclocs? . -> . (listof srcloc))]{
 
 Returns the @scheme[srcloc]-getting procedure associated with @scheme[v].}
 

collects/scribblings/reference/package.scrbl

@@ -18,6 +18,9 @@
                         (code:line #:all-defined-except (id ...))])]
 )]{
 
+@margin-note{The @scheme[define-package] form is based on the @schemeidfont{module}
+             form of Chez Scheme @cite["Waddell99"].}
+
 The @scheme[define-package] form is similar to @scheme[module], except
 that it can appear in any definition context. The @scheme[form]s
 within a @scheme[define-package] form can be definitions or

collects/scribblings/reference/reference.scrbl

@@ -146,6 +146,12 @@ languages.}
              #:url "http://srfi.schemers.org/srfi-42/"
              #:date "2003")
 
+  (bib-entry #:key "Waddell99"
+             #:author "Oscar Waddell and R. Kent Dybvig"
+             #:title "Extending the Scope of Syntactic Abstraction"
+             #:location "Principles of Programming Languages"
+             #:date "1999")
+
   )
 
 @;------------------------------------------------------------------------

collects/scribblings/reference/stx-certs.scrbl

@@ -3,6 +3,8 @@
 
 @title[#:tag "stxcerts"]{Syntax Certificates}
 
+@guideintro["stx-certs"]{syntax certificates}
+
 A @deftech{syntax certificate} combines a @tech{syntax mark} (see
 @secref["transformer-model"]), a @tech{module path index} or symbol
 module name (see @secref["modpathidx"]), an @tech{inspector} (see
@@ -112,8 +114,12 @@ expansion context:
 
  @item{When the expander encounters a @scheme[quote-syntax] form, it
    attaches all accumulated @tech{active certificates} from the
-   expressions's context to the quoted syntax objects. The
+   expressions's context to the quoted syntax objects. A certificate
-   certificates are attached as @tech{inactive certificates}.}
+   for the enclosing module (if any) is also included. The
+   certificates are attached as @tech{inactive certificates} to the
+   immediate syntax object (i.e., not to any nested syntax
+   objects). In addition, any inactive certificates within the quoted
+   syntax object are lifted to the immediate syntax object.}
 
 }
 

collects/tests/mzscheme/optimize.ss

@@ -253,6 +253,10 @@
     (bin -12 '* -3 4)
     (bin -12 '* 3 -4)
     (bin 12 '* -3 -4)
+    (bin (expt 2 70) '* 2 (expt 2 69))
+    (bin (expt 2 30) '* 2 (expt 2 29))
+    (bin (expt 2 31) '* 2 (expt 2 30))
+    (bin (- (expt 2 30)) '* 2 (- (expt 2 29)))
 
     (bin 0 '/ 0 4)
     (bin 1/4 '/ 1 4)

collects/tests/mzscheme/thread.ss

@@ -1275,4 +1275,13 @@
 
 ; --------------------
 
+;; Make sure shared thread cell is not exposed:
+(test #f 'no-breaks (with-handlers ([void (lambda (x) (break-enabled))]) (/ 0)))
+(test #t 'no-breaks (with-handlers ([void (lambda (x) (break-enabled #t) (break-enabled))]) (/ 0)))
+(test #f 'no-breaks (with-handlers ([void (lambda (x) (break-enabled))]) (/ 0)))
+(test #t 'no-breaks (with-handlers ([(lambda (x) (break-enabled #t)) (lambda (x) (break-enabled))]) (/ 0)))
+(test #f 'no-breaks (with-handlers ([void (lambda (x) (break-enabled))]) (/ 0)))
+
+; --------------------
+
 (report-errs)

collects/tests/mzscheme/will.ss

@@ -125,6 +125,14 @@
   (custodian-shutdown-all c1)
   (test '(#f #f) map custodian-box-value (list b1 b2)))
 
+(let ()
+  (let ([c (make-custodian)])
+    (let ([l (for/list ([i (in-range 32)])
+               (make-custodian-box c 7))])
+      (test #t andmap (lambda (b) (number? (custodian-box-value b))) l)
+      (custodian-shutdown-all c)
+      (test #f ormap (lambda (b) (number? (custodian-box-value b))) l))))
+
 ;; ----------------------------------------
 
 (report-errs)

collects/tests/typed-scheme/succeed/require-substruct.ss

@@ -0,0 +1,17 @@
+#lang scheme/load
+
+(module m scheme
+  (define-struct X (x) #:transparent)
+  (define-struct (Y X) (y) #:transparent)
+  (provide (all-defined-out)))
+
+(module n typed-scheme
+  (require-typed-struct X ([x : Number]) 'm)
+  (require-typed-struct (Y X) ([y : Number]) 'm)
+  (make-X 43)
+  (define: x : Any 3)
+  (if (Y? x)
+      (X-x x)
+      4))
+
+(require 'n)

collects/tests/typed-scheme/succeed/time.ss

@@ -0,0 +1,17 @@
+#lang typed-scheme
+
+
+
+ (: foo : Number Number -> Number)
+ (define (foo x y)
+   (* x y))
+
+ (: bar : Number -> Number)
+ (define (bar c)
+   (: loop : Number Number -> Number)
+   (define (loop n acc)
+     (if (< 0 n)
+         (loop (- n 1) (+ (foo c n) acc))
+         acc))
+   (loop 10000000 0))
+ (time (bar 0))

collects/typed-scheme/private/base-env.ss

@@ -245,8 +245,10 @@
 
 [apply        (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
 [kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
-[time-apply (-poly (a b) (((list) a . ->* . b) (-lst a)
+[time-apply (-polydots (b a) (((list) (a a) . ->... . b)
-                          . -> . (-values (list b N N N))))]
+                              (-lst a)
+                              . -> . 
+                              (-values (list (-pair b (-val '())) N N N))))]
 
 [call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
 [call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
@@ -289,6 +291,57 @@
          [(-Pattern -InpBts N ?N      ) (optlist -Bytes)]
          [(-Pattern -InpBts N ?N ?outp) (optlist -Bytes)]))]
 
+[regexp-match*
+ (let ([?N      (-opt N)]
+       [-StrRx  (*Un -String -Regexp -PRegexp)]
+       [-BtsRx  (*Un -Bytes  -Byte-Regexp -Byte-PRegexp)]
+       [-InpBts (*Un -Input-Port -Bytes)])
+   (cl->*
+    (-StrRx   -String [N ?N] . ->opt . (-lst -String))
+    (-BtsRx   -String [N ?N] . ->opt . (-lst -Bytes))
+    (-Pattern -InpBts [N ?N] . ->opt . (-lst -Bytes))))]
+[regexp-try-match
+ (let ([?outp   (-opt -Output-Port)]
+       [?N      (-opt N)]
+       [optlist (lambda (t) (-opt (-lst (-opt t))))])
+   (->opt -Pattern -Input-Port [N ?N ?outp] (optlist -Bytes)))]
+
+[regexp-match-exact?
+ (-Pattern (Un -String -Bytes -Input-Port) . -> . B)]
+
+
+[regexp-match-positions
+ (let ([?outp   (-opt -Output-Port)]
+       [?N      (-opt N)]
+       [optlist (lambda (t) (-opt (-lst (-opt t))))]
+       [-StrRx  (*Un -String -Regexp -PRegexp)]
+       [-BtsRx  (*Un -Bytes  -Byte-Regexp -Byte-PRegexp)]
+       [-InpBts (*Un -Input-Port -Bytes)])
+   (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (optlist (-pair -Nat -Nat))))]
+[regexp-match-positions*
+ (let ([?outp   (-opt -Output-Port)]
+       [?N      (-opt N)]
+       [optlist (lambda (t) (-opt (-lst (-opt t))))]
+       [-StrRx  (*Un -String -Regexp -PRegexp)]
+       [-BtsRx  (*Un -Bytes  -Byte-Regexp -Byte-PRegexp)]
+       [-InpBts (*Un -Input-Port -Bytes)])
+   (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (-lst (-pair -Nat -Nat))))]
+#;
+[regexp-match-peek-positions*]
+#;
+[regexp-split]
+
+[regexp-quote (cl->*
+               (->opt -String [Univ] -String)
+               (->opt -Bytes [Univ] -Bytes))]
+[regexp-replace-quote
+ (cl->*
+  [-> -String -String]
+  [-> -Bytes -Bytes])]
+
+
+
+
 [number->string (N . -> . -String)]
 
 [current-milliseconds (-> -Integer)]
@@ -500,3 +553,12 @@
 [boolean=? (B B . -> . B)]
 [symbol=? (Sym Sym . -> . B)]
 [false? (make-pred-ty (-val #f))]
+
+;; with-stx.ss
+[generate-temporaries ((Un (-Syntax Univ) (-lst Univ)) . -> . (-lst (-Syntax Sym)))]
+[check-duplicate-identifier ((-lst (-Syntax Sym)) . -> . (-opt (-Syntax Sym)))]
+
+;; string.ss
+[real->decimal-string (N [-Nat] . ->opt .  -String)]
+
+[current-continuation-marks (-> -Cont-Mark-Set)]

collects/typed-scheme/private/base-special-env.ss

@@ -29,8 +29,8 @@
         [year : N] [weekday : N] [year-day : N] [dst? : B] [time-zone-offset : N])
        ())
   (d-s exn ([message : -String] [continuation-marks : Univ]) ())
-  (d-s (exn:fail exn) () (-String Univ))
+  (d-s (exn:fail exn) () (-String -Cont-Mark-Set))
-  (d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String Univ))
+  (d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String -Cont-Mark-Set))
   )
 
 (provide (for-syntax initial-env/special-case initialize-others initialize-type-env)

collects/typed-scheme/private/env-lang.ss

@@ -1,10 +1,12 @@
 #lang scheme/base
 
-(require "../utils/utils.ss")
+(require (rename-in "../utils/utils.ss" [infer r:infer]))
 
 (require (for-syntax (private type-effect-convenience)
                      (env init-envs)
                      scheme/base
+                     (r:infer infer)
+                     (only-in (r:infer infer-dummy) infer-param)
                      (except-in (rep effect-rep type-rep) make-arr)
                      "type-effect-convenience.ss"
                      (only-in "type-effect-convenience.ss" [make-arr* make-arr])
@@ -20,7 +22,8 @@
           (begin
             (require . args)
             (define-for-syntax e
-              (make-env [id ty] ...))
+              (parameterize ([infer-param infer])
+                (make-env [id ty] ...)))
             (begin-for-syntax
               (initialize-type-env e)))))]
     [(mb . rest)

collects/typed-scheme/private/parse-type.ss

@@ -27,6 +27,9 @@
   (parameterize ([current-orig-stx stx])
     (syntax-case* stx ()
       symbolic-identifier=?  
+      [t
+       (Type? (syntax-e #'t))
+       (syntax-e #'t)]
       [(fst . rst)
        (not (syntax->list #'rst))
        (-pair (parse-type #'fst) (parse-type #'rst))]

collects/typed-scheme/private/prims.ss

@@ -57,6 +57,15 @@ This file defines two sorts of primitives. All of them are provided into any mod
   (syntax-case* stx (rename) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
     [(_ lib [nm ty] ...)
      #'(begin (require/typed nm ty lib) ...)]
+    [(_ nm ty lib #:struct-maker parent)
+     (with-syntax ([(cnt*) (generate-temporaries #'(nm))])
+       (quasisyntax/loc stx (begin 
+                              #,(syntax-property (syntax-property #'(define cnt* #f)
+                                                                  'typechecker:contract-def/maker #'ty)
+                                                 'typechecker:ignore #t)
+                              #,(internal #'(require/typed-internal nm ty #:struct-maker parent))
+                              #,(syntax-property #'(require/contract nm cnt* lib)
+                                                 'typechecker:ignore #t))))]
     [(_ nm ty lib)
      (identifier? #'nm)
      (with-syntax ([(cnt*) (generate-temporaries #'(nm))])
@@ -346,9 +355,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(_ nm ([fld : ty] ...) lib)
      (identifier? #'nm)
      (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
-                    [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
+                    [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))])
-                    [oty #'(Opaque pred)])
+                   #`(begin
-                   #'(begin
                        (require (only-in lib struct-info))
                        (define-syntax nm (make-struct-info 
                                           (lambda ()
@@ -358,9 +366,33 @@ This file defines two sorts of primitives. All of them are provided into any mod
                                                   (list #'sel ...)
                                                   (list mut ...)
                                                   #f))))
-                       (require/opaque-type nm pred lib #:name-exists)
+                       #,(internal #'(define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
-                       (require/typed maker (ty ... -> oty) lib)
+                       #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
-                       (require/typed sel (oty -> ty) lib) ...))]))
+                       #,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
+                       (require/typed maker nm lib #:struct-maker #f)
+                       (require/typed lib 
+                         [sel (nm -> ty)]) ...))]
+    [(_ (nm parent) ([fld : ty] ...) lib)
+     (and (identifier? #'nm) (identifier? #'parent))
+     (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
+                    [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
+                    #;[(parent-tys ...) (Struct-flds (parse-type #'parent))])
+                   #`(begin
+                       (require (only-in lib struct-info))
+                       (define-syntax nm (make-struct-info 
+                                          (lambda ()
+                                            (list #'struct-info
+                                                  #'maker
+                                                  #'pred
+                                                  (list #'sel ...)
+                                                  (list mut ...)
+                                                  #f))))
+                       #,(internal #'(define-typed-struct-internal (nm parent) ([fld : ty] ...) #:type-only))
+                       #,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
+                       #,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
+                       (require/typed maker nm lib #:struct-maker parent)
+                       (require/typed lib                          
+                         [sel (nm -> ty)]) ...))]))
 
 (define-syntax (do: stx)
   (syntax-case stx (:)

collects/typed-scheme/private/require-contract.ss

@@ -6,13 +6,19 @@
 (define-syntax (define-ignored stx)
   (syntax-case stx ()
     [(_ name expr)
-     (syntax-case (local-expand/capture-lifts #'expr 'expression 
+     (syntax-case (local-expand/capture-lifts #'expr
+                                              'expression 
                                               (list #'define-values))
        (begin define-values)
        [(begin (define-values (n) e) e*)
-        #'(begin (define-values (n) e)
+        #`(begin (define-values (n) e)
-                 (define name e*))]
+                 (define name #,(syntax-property #'e*
-       [e #'(define name e)])]))
+                                                 'inferred-name
+                                                 (syntax-e #'name))))]
+       [(begin (begin e))
+        #`(define name #,(syntax-property #'e
+                                          'inferred-name
+                                          (syntax-e #'name)))])]))
 
 (define-syntax (require/contract stx)
   (syntax-case stx ()

collects/typed-scheme/private/type-contract.ss

@@ -23,15 +23,21 @@
  (for-template scheme/base scheme/contract (only-in scheme/class object% is-a?/c subclass?/c)))
 
 (define (define/fixup-contract? stx)
-  (syntax-property stx 'typechecker:contract-def))
+  (or (syntax-property stx 'typechecker:contract-def)
+      (syntax-property stx 'typechecker:contract-def/maker)))
 
 (define (generate-contract-def stx)
-  (define prop (syntax-property stx 'typechecker:contract-def))
+  (define prop (or (syntax-property stx 'typechecker:contract-def)
+                   (syntax-property stx 'typechecker:contract-def/maker)))
+  (define maker? (syntax-property stx 'typechecker:contract-def/maker))
   (define typ (parse-type prop))
   (syntax-case stx (define-values)
     [(_ (n) __)
-     (with-syntax ([cnt (type->contract typ (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))])
+     (let ([typ (if maker?
-       (syntax/loc stx (define-values (n) cnt)))]
+                    ((Struct-flds (lookup-type-name (Name-id typ))) #f . t:->* . typ)
+                    typ)])
+       (with-syntax ([cnt (type->contract typ (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))])
+         (syntax/loc stx (define-values (n) cnt))))]
     [_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))]))
 
 (define (change-contract-fixups forms)

collects/typed-scheme/private/type-effect-convenience.ss

@@ -3,6 +3,7 @@
 
 (require (rep type-rep effect-rep)
          (utils tc-utils)
+         scheme/list
          scheme/match
          "type-comparison.ss"
          "type-effect-printer.ss"
@@ -84,7 +85,7 @@
   (define (funty-arities f)
     (match f
       [(Function: as) as]))
-  (make-Function (map car (map funty-arities args))))
+  (make-Function (apply append (map funty-arities args))))
 
 (define-syntax (->key stx)
   (syntax-parse stx
@@ -143,6 +144,8 @@
 (define Univ (make-Univ))
 (define Err (make-Error))
 
+(define -Nat -Integer)
+
 (define-syntax -v 
   (syntax-rules ()
     [(_ x) (make-F 'x)]))
@@ -213,6 +216,14 @@
 
 (define (-Tuple l)
   (foldr -pair (-val '()) l))
+
+(define (untuple t)
+  (match t
+    [(Value: '()) null]
+    [(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))]
+                       [else #f])]
+    [_ #f]))
+
 (define -box make-Box)
 (define -vec make-Vector)
 
@@ -277,3 +288,9 @@
 
 
 
+(define (opt-fn args opt-args result)
+  (apply cl->* (for/list ([i (in-range (add1 (length opt-args)))])                         
+                 (make-Function (list (make-arr* (append args (take opt-args i)) result))))))
+
+(define-syntax-rule (->opt args ... [opt ...] res)
+  (opt-fn (list args ...) (list opt ...) res))

collects/typed-scheme/typecheck/tc-app-unit.ss

@@ -14,6 +14,7 @@
          (prefix-in c: scheme/contract)
          (for-syntax scheme/base)
          (for-template 
+          (only-in '#%kernel [apply k:apply])
           "internal-forms.ss" scheme/base 
           (only-in scheme/private/class-internal make-object do-make-object)))
 (require (r:infer constraint-structs))
@@ -620,7 +621,7 @@
 
 (define (tc/app/internal form expected)
   (kernel-syntax-case* form #f 
-    (values apply not list list* call-with-values do-make-object make-object cons
+    (values apply k:apply not list list* call-with-values do-make-object make-object cons
             andmap ormap) ;; the special-cased functions
     ;; special case for delay
     [(#%plain-app 
@@ -680,6 +681,14 @@
        ;; if arg was a predicate application, we swap the effects
        [(tc-result: t thn-eff els-eff)
         (ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])]
+    [(#%plain-app k:apply . args)
+     (tc/app/internal #'(#%plain-app apply . args) expected)]
+    ;; special-er case for (apply values (list x y z))
+    [(#%plain-app apply values e)
+     (cond [(with-handlers ([exn:fail? (lambda _ #f)])
+               (untuple (tc-expr/t #'e)))
+            => (lambda (t) (ret (-values t)))]
+           [else (tc/apply #'values #'(e))])]
     ;; special case for `apply'
     [(#%plain-app apply f . args) (tc/apply #'f #'args)]
     ;; special case for keywords

collects/typed-scheme/typecheck/tc-structs.ss

@@ -91,7 +91,8 @@
                          #:proc-ty [proc-ty #f]
                          #:maker [maker* #f]
                          #:constructor-return [cret #f]
-                         #:poly? [poly? #f])
+                         #:poly? [poly? #f]
+                         #:type-only [type-only #f])
   ;; create the approriate names that define-struct will bind
   (define-values (maker pred getters setters) (struct-names nm flds setters?))
   (let* ([name (syntax-e nm)]
@@ -99,17 +100,19 @@
          [sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier))]
          [external-fld-types/no-parent types]
          [external-fld-types fld-types])
-    (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? 
+    (if type-only
-                           #:wrapper wrapper
+        (register-type-name nm (wrapper sty))
-                           #:type-wrapper type-wrapper
+        (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? 
-                           #:maker (or maker* maker)
+                               #:wrapper wrapper
-                           #:constructor-return cret)))
+                               #:type-wrapper type-wrapper
+                               #:maker (or maker* maker)
+                               #:constructor-return cret))))
 
 ;; generate names, and register the approriate types give field types and structure type
 ;; optionally wrap things
 ;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier
 (define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
-                               #:wrapper [wrapper (lambda (x) x)]
+                               #:wrapper [wrapper values]
                                #:type-wrapper [type-wrapper values]
                                #:maker [maker* #f]
                                #:constructor-return [cret #f])
@@ -168,7 +171,9 @@
 
 ;; typecheck a non-polymophic struct and register the approriate types
 ;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
-(define (tc/struct nm/par flds tys [proc-ty #f] #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f])
+(define (tc/struct nm/par flds tys [proc-ty #f] 
+                   #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
+                   #:type-only [type-only #f])
   ;; get the parent info and create some types and type variables
   (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
   ;; parse the field types, and determine if the type is recursive
@@ -184,7 +189,8 @@
                    #:proc-ty proc-ty-parsed
                    #:maker maker
 		   #:constructor-return (and cret (parse-type cret))
-                   #:mutable mutable))
+                   #:mutable mutable
+                   #:type-only type-only))
 
 ;; register a struct type
 ;; convenience function for built-in structs

collects/typed-scheme/typecheck/tc-toplevel.ss

@@ -7,6 +7,7 @@
          scheme/match
          "signatures.ss"
          "tc-structs.ss"
+         (rep type-rep)
          (private type-utils type-effect-convenience parse-type type-annotation mutated-vars type-contract)
 	 (env type-env init-envs type-name-env type-alias-env)
 	 (utils tc-utils)
@@ -44,6 +45,13 @@
          (register-type #'nm t)
          (list (make-def-binding #'nm t)))]
       
+      [(define-values () (begin (quote-syntax (require/typed-internal nm ty #:struct-maker parent)) (#%plain-app values)))
+       (let* ([t (parse-type #'ty)]
+              [flds (Struct-flds (lookup-type-name (Name-id t)))]
+              [mk-ty (flds #f . ->* . t)])
+         (register-type #'nm mk-ty)
+         (list (make-def-binding #'nm mk-ty)))]
+      
       ;; define-typed-struct
       [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values)))
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]
@@ -52,6 +60,9 @@
       [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:maker m #:constructor-return t)) 
                                 (#%plain-app values)))
        (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:constructor-return #'t)]
+      [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
+                                (#%plain-app values)))
+       (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)]
       ;; define-typed-struct w/ polymorphism
       [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...))) (#%plain-app values)))
        (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]    

src/mzscheme/gc2/newgc.c

@@ -1244,35 +1244,37 @@ typedef struct MarkSegment {
   struct MarkSegment *prev;
   struct MarkSegment *next;
   void **top;
-  void **end;
-  void *stop_here; /* this is only used for its address */
 } MarkSegment;
 
+#define MARK_STACK_START(ms) ((void **)(void *)&ms[1])
+#define MARK_STACK_END(ms) ((void **)((char *)ms + STACK_PART_SIZE))
+
 static THREAD_LOCAL MarkSegment *mark_stack = NULL;
 
 inline static MarkSegment* mark_stack_create_frame() {
   MarkSegment *mark_frame = (MarkSegment*)ofm_malloc(STACK_PART_SIZE);
   mark_frame->next = NULL;
-  mark_frame->top  = &(mark_frame->stop_here);
+  mark_frame->top  = MARK_STACK_START(mark_frame);
-  mark_frame->end  = PPTR(NUM(mark_frame) + STACK_PART_SIZE);
   return mark_frame;
 }
 
-inline static void push_ptr(void *ptr)
+inline static void init_mark_stack()
 {
-  /* This happens at the very beginning */
   if(!mark_stack) {
     mark_stack = mark_stack_create_frame();
     mark_stack->prev = NULL;
   }
+}
 
+inline static void push_ptr(void *ptr)
+{
   /* This happens during propoagation if we go past the end of this MarkSegment*/
-  if(mark_stack->top == mark_stack->end) {
+  if(mark_stack->top == MARK_STACK_END(mark_stack)) {
     /* test to see if we already have another stack page ready */
     if(mark_stack->next) {
       /* we do, so just use it */
       mark_stack = mark_stack->next;
-      mark_stack->top = &(mark_stack->stop_here);
+      mark_stack->top = MARK_STACK_START(mark_stack);
     } else {
       /* we don't, so we need to allocate one */
       mark_stack->next = mark_stack_create_frame();
@@ -1287,7 +1289,7 @@ inline static void push_ptr(void *ptr)
 
 inline static int pop_ptr(void **ptr)
 {
-  if(mark_stack->top == &mark_stack->stop_here) {
+  if(mark_stack->top == MARK_STACK_START(mark_stack)) {
     if(mark_stack->prev) {
       /* if there is a previous page, go to it */
       mark_stack = mark_stack->prev;
@@ -1323,7 +1325,7 @@ inline static void clear_stack_pages(void)
         free(mark_stack);
     }
     mark_stack = base;
-    mark_stack->top = PPTR(mark_stack) + 4;
+    mark_stack->top = MARK_STACK_START(mark_stack);
   }
 }
 
@@ -1332,7 +1334,7 @@ inline static void reset_pointer_stack(void)
   /* go to the head of the list */
   for(; mark_stack->prev; mark_stack = mark_stack->prev) {}
   /* reset the stack */
-  mark_stack->top = PPTR(mark_stack) + 4;
+  mark_stack->top = MARK_STACK_START(mark_stack);
 }
 
 /*****************************************************************************/
@@ -1424,6 +1426,8 @@ void NewGC_initialize(NewGC *newgc) {
   newgc->generations_available = 1;
   newgc->last_full_mem_use = (20 * 1024 * 1024);
   newgc->new_btc_mark = 1;
+
+  init_mark_stack();
 }
 
 void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox, int ephemeron, int weakarray, int custbox)
@@ -1558,7 +1562,7 @@ void GC_mark(const void *const_p)
       /* if we're doing memory accounting, then we need to make sure the
          btc_mark is right */
 #ifdef NEWGC_BTC_ACCOUNT
-        BTC_set_btc_mark(gc, PTR(NUM(page->addr) + PREFIX_SIZE));
+      BTC_set_btc_mark(gc, PTR(NUM(page->addr) + PREFIX_SIZE));
 #endif
     }
 
@@ -1621,7 +1625,10 @@ void GC_mark(const void *const_p)
       /* now either fetch where we're going to put this object or make
          a new page if we couldn't find a page with space to spare */
       if(work) {
-        pagemap_add(gc->page_maps, work);
+        if (!work->added) {
+          pagemap_add(gc->page_maps, work);
+          work->added = 1;
+        }
         work->marked_on = 1;
         if (work->mprotected) {
           work->mprotected = 0;
@@ -1642,6 +1649,7 @@ void GC_mark(const void *const_p)
         if(work->next)
           work->next->prev = work;
         pagemap_add(gc->page_maps, work);
+        work->added = 1;
         gc->gen1_pages[type] = work;
         newplace = PTR(NUM(work->addr) + PREFIX_SIZE);
       }
@@ -1651,11 +1659,11 @@ void GC_mark(const void *const_p)
       work->has_new = 1;
 
       /* transfer the object */
+      ohead->mark = 1; /* mark is copied to newplace, too */
       memcpy(newplace, (const void *)ohead, size);
       /* mark the old location as marked and moved, and the new location
          as marked */
-      ohead->mark = ohead->moved = 1;
+      ohead->moved = 1;
-      ((struct objhead *)newplace)->mark = 1;
       /* if we're doing memory accounting, then we need the btc_mark
          to be set properly */
 #ifdef NEWGC_BTC_ACCOUNT
@@ -1668,7 +1676,7 @@ void GC_mark(const void *const_p)
       record_backtrace(work, newplace);
       /* set forwarding pointer */
       GCDEBUG((DEBUGOUTF,"Marking %p (moved to %p on page %p)\n", 
-            p, newplace, work));
+               p, newplace, work));
       *(void**)p = newplace;
       push_ptr(newplace);
     }
@@ -1992,6 +2000,7 @@ static void remove_all_gen1_pages_from_pagemap(NewGC *gc)
         add_protect_page_range(protect_range, work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, APAGE_SIZE, 1);
       }
       pagemap_remove(pagemap, work);
+      work->added = 0;
     }
   }
   flush_protect_page_ranges(protect_range, 1);

src/mzscheme/gc2/newgc.h

@@ -22,6 +22,7 @@ typedef struct mpage {
   unsigned char marked_on     ;
   unsigned char has_new       ;
   unsigned char mprotected    ;
+  unsigned char added         ;
   unsigned short live_size;
   void **backtrace;
 } mpage;

src/mzscheme/src/cstartup.inc

@@ -1,111 +1,115 @@
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,51,50,0,0,0,1,0,0,6,0,9,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,50,0,0,0,1,0,0,6,0,9,0,
-13,0,26,0,29,0,34,0,41,0,46,0,51,0,58,0,65,0,69,0,78,
+18,0,22,0,35,0,38,0,43,0,50,0,55,0,60,0,67,0,74,0,78,
 0,84,0,98,0,112,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0,
-177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,68,1,107,1,146,
+177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,87,1,126,1,165,
-1,215,1,4,2,92,2,137,2,142,2,162,2,51,3,71,3,121,3,187,3,
+1,234,1,42,2,130,2,194,2,199,2,219,2,110,3,130,3,181,3,247,3,
-72,4,230,4,17,5,28,5,107,5,0,0,106,7,0,0,65,98,101,103,105,
+132,4,34,5,84,5,107,5,186,5,0,0,201,7,0,0,65,98,101,103,105,
-110,29,11,11,63,108,101,116,72,112,97,114,97,109,101,116,101,114,105,122,101,
+110,29,11,11,68,104,101,114,101,45,115,116,120,63,108,101,116,72,112,97,114,
-62,111,114,64,108,101,116,42,66,117,110,108,101,115,115,64,99,111,110,100,64,
+97,109,101,116,101,114,105,122,101,62,111,114,64,108,101,116,42,66,117,110,108,
-119,104,101,110,66,108,101,116,114,101,99,66,100,101,102,105,110,101,63,97,110,
+101,115,115,64,99,111,110,100,64,119,104,101,110,66,108,101,116,114,101,99,66,
-100,68,104,101,114,101,45,115,116,120,65,113,117,111,116,101,29,94,2,14,68,
+100,101,102,105,110,101,63,97,110,100,65,113,117,111,116,101,29,94,2,14,68,
 35,37,107,101,114,110,101,108,11,29,94,2,14,68,35,37,112,97,114,97,109,
 122,11,62,105,102,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101,
 115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109,
 98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,
 45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,98,
-10,35,11,8,133,229,94,159,2,16,35,35,159,2,15,35,35,16,20,2,3,
+10,35,11,8,180,243,94,159,2,16,35,35,159,2,15,35,35,16,20,2,4,
-2,2,2,4,2,2,2,10,2,2,2,5,2,2,2,6,2,2,2,7,2,
+2,2,2,5,2,2,2,11,2,2,2,6,2,2,2,7,2,2,2,8,2,
-2,2,8,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97,36,11,8,
+2,2,9,2,2,2,10,2,2,2,12,2,2,2,13,2,2,97,36,11,8,
-133,229,93,159,2,15,35,36,16,2,2,13,161,2,2,36,2,13,2,2,2,
+180,243,93,159,2,15,35,36,16,2,2,3,161,2,2,36,2,3,2,2,2,
-13,97,10,11,11,8,133,229,16,0,97,10,37,11,8,133,229,16,0,13,16,
+3,97,10,11,11,8,180,243,16,0,97,10,37,11,8,180,243,16,0,13,16,
-4,35,29,11,11,2,2,11,18,98,64,104,101,114,101,8,31,8,30,8,29,
+4,35,29,11,11,2,2,11,18,16,2,99,64,104,101,114,101,8,31,8,30,
-8,28,8,27,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,
+8,29,8,28,8,27,93,8,224,251,60,0,0,95,9,8,224,251,60,0,0,
-22,74,2,17,248,22,89,23,200,2,12,249,22,64,2,1,248,22,91,23,202,
+2,2,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74,
-1,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74,2,
+2,17,248,22,89,23,200,2,12,249,22,64,2,1,248,22,91,23,202,1,27,
-17,248,22,89,23,200,2,249,22,64,2,1,248,22,91,23,202,1,12,27,248,
+248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74,2,17,248,
-22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,
+22,89,23,200,2,249,22,64,2,1,248,22,91,23,202,1,12,27,248,22,66,
-36,28,248,22,72,248,22,66,23,195,2,248,22,65,193,249,22,190,3,80,158,
+248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,36,28,
-38,35,251,22,74,2,17,248,22,65,23,200,2,249,22,64,2,12,248,22,66,
+248,22,72,248,22,66,23,195,2,248,22,65,193,249,22,190,3,80,158,38,35,
-23,202,1,11,18,100,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11,
+251,22,74,2,17,248,22,65,23,200,2,249,22,64,2,13,248,22,66,23,202,
-2,18,3,1,7,101,110,118,57,55,57,56,16,4,11,11,2,19,3,1,7,
+1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11,
-101,110,118,57,55,57,57,27,248,22,66,248,22,133,4,23,197,1,28,248,22,
+2,18,3,1,7,101,110,118,57,55,57,52,16,4,11,11,2,19,3,1,7,
-72,23,194,2,20,15,159,36,35,36,28,248,22,72,248,22,66,23,195,2,248,
+101,110,118,57,55,57,53,93,8,224,252,60,0,0,95,9,8,224,252,60,0,
-22,65,193,249,22,190,3,80,158,38,35,250,22,74,2,20,248,22,74,249,22,
+0,2,2,27,248,22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2,
-74,248,22,74,2,21,248,22,65,23,202,2,251,22,74,2,17,2,21,2,21,
+20,15,159,36,35,36,28,248,22,72,248,22,66,23,195,2,248,22,65,193,249,
-249,22,64,2,5,248,22,66,23,205,1,18,100,11,8,31,8,30,8,29,8,
+22,190,3,80,158,38,35,250,22,74,2,20,248,22,74,249,22,74,248,22,74,
-28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,56,48,49,16,4,
+2,21,248,22,65,23,202,2,251,22,74,2,17,2,21,2,21,249,22,64,2,
-11,11,2,19,3,1,7,101,110,118,57,56,48,50,248,22,133,4,193,27,248,
+6,248,22,66,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8,28,8,
-22,133,4,194,249,22,64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,
+27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,57,55,16,4,11,11,
-66,248,22,133,4,23,197,1,249,22,190,3,80,158,38,35,28,248,22,52,248,
+2,19,3,1,7,101,110,118,57,55,57,56,93,8,224,253,60,0,0,95,9,
-22,191,3,248,22,65,23,198,2,27,249,22,2,32,0,89,162,43,36,42,9,
+8,224,253,60,0,0,2,2,248,22,133,4,193,27,248,22,133,4,194,249,22,
-222,33,39,248,22,133,4,248,22,89,23,200,2,250,22,74,2,22,248,22,74,
+64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,133,4,23,
-249,22,74,248,22,74,248,22,65,23,204,2,250,22,75,2,23,249,22,2,22,
+197,1,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3,248,22,65,
-65,23,204,2,248,22,91,23,206,2,249,22,64,248,22,65,23,202,1,249,22,
+23,198,2,27,249,22,2,32,0,89,162,8,44,36,42,9,222,33,39,248,22,
-2,22,89,23,200,1,250,22,75,2,20,249,22,2,32,0,89,162,43,36,46,
+133,4,248,22,89,23,200,2,250,22,74,2,22,248,22,74,249,22,74,248,22,
-9,222,33,40,248,22,133,4,248,22,65,201,248,22,66,198,27,248,22,133,4,
+74,248,22,65,23,204,2,250,22,75,2,23,249,22,2,22,65,23,204,2,248,
-194,249,22,64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,
+22,91,23,206,2,249,22,64,248,22,65,23,202,1,249,22,2,22,89,23,200,
-133,4,23,197,1,249,22,190,3,80,158,38,35,250,22,75,2,22,249,22,2,
+1,250,22,75,2,20,249,22,2,32,0,89,162,8,44,36,46,9,222,33,40,
-32,0,89,162,43,36,46,9,222,33,42,248,22,133,4,248,22,65,201,248,22,
+248,22,133,4,248,22,65,201,248,22,66,198,27,248,22,133,4,194,249,22,64,
-66,198,27,248,22,66,248,22,133,4,196,27,248,22,133,4,248,22,65,195,249,
+248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,133,4,23,197,
-22,190,3,80,158,39,35,28,248,22,72,195,250,22,75,2,20,9,248,22,66,
+1,249,22,190,3,80,158,38,35,250,22,75,2,22,249,22,2,32,0,89,162,
-199,250,22,74,2,3,248,22,74,248,22,65,199,250,22,75,2,6,248,22,66,
+8,44,36,46,9,222,33,42,248,22,133,4,248,22,65,201,248,22,66,198,27,
-201,248,22,66,202,27,248,22,66,248,22,133,4,23,197,1,27,249,22,1,22,
+248,22,66,248,22,133,4,196,27,248,22,133,4,248,22,65,195,249,22,190,3,
-78,249,22,2,22,133,4,248,22,133,4,248,22,65,199,249,22,190,3,80,158,
+80,158,39,35,28,248,22,72,195,250,22,75,2,20,9,248,22,66,199,250,22,
-39,35,251,22,74,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,
+74,2,4,248,22,74,248,22,65,199,250,22,75,2,7,248,22,66,201,248,22,
-105,111,110,45,109,97,114,107,2,24,250,22,75,1,23,101,120,116,101,110,100,
+66,202,27,248,22,66,248,22,133,4,23,197,1,27,249,22,1,22,78,249,22,
-45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,
+2,22,133,4,248,22,133,4,248,22,65,199,249,22,190,3,80,158,39,35,251,
-99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,
+22,74,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110,
-45,102,105,114,115,116,11,2,24,201,250,22,75,2,20,9,248,22,66,203,27,
+45,109,97,114,107,2,24,250,22,75,1,23,101,120,116,101,110,100,45,112,97,
-248,22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,
+114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,99,111,110,
-35,36,249,22,190,3,80,158,38,35,27,248,22,133,4,248,22,65,23,198,2,
+116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,45,102,105,
-28,249,22,162,8,62,61,62,248,22,191,3,248,22,89,23,197,2,250,22,74,
+114,115,116,11,2,24,201,250,22,75,2,20,9,248,22,66,203,27,248,22,66,
-2,20,248,22,74,249,22,74,21,93,2,25,248,22,65,199,250,22,75,2,8,
+248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,36,249,
-249,22,74,2,25,249,22,74,248,22,98,203,2,25,248,22,66,202,251,22,74,
+22,190,3,80,158,38,35,27,248,22,133,4,248,22,65,23,198,2,28,249,22,
-2,17,28,249,22,162,8,248,22,191,3,248,22,65,23,201,2,64,101,108,115,
+162,8,62,61,62,248,22,191,3,248,22,89,23,197,2,250,22,74,2,20,248,
-101,10,248,22,65,23,198,2,250,22,75,2,20,9,248,22,66,23,201,1,249,
+22,74,249,22,74,21,93,2,25,248,22,65,199,250,22,75,2,9,249,22,74,
-22,64,2,8,248,22,66,23,203,1,99,8,31,8,30,8,29,8,28,8,27,
+2,25,249,22,74,248,22,98,203,2,25,248,22,66,202,251,22,74,2,17,28,
-16,4,11,11,2,18,3,1,7,101,110,118,57,56,50,52,16,4,11,11,2,
+249,22,162,8,248,22,191,3,248,22,65,23,201,2,64,101,108,115,101,10,248,
-19,3,1,7,101,110,118,57,56,50,53,18,158,94,10,64,118,111,105,100,8,
+22,65,23,198,2,250,22,75,2,20,9,248,22,66,23,201,1,249,22,64,2,
-47,27,248,22,66,248,22,133,4,196,249,22,190,3,80,158,38,35,28,248,22,
+9,248,22,66,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16,4,11,
-52,248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,199,
+11,2,18,3,1,7,101,110,118,57,56,50,48,16,4,11,11,2,19,3,1,
-248,22,89,198,27,248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,
+7,101,110,118,57,56,50,49,93,8,224,254,60,0,0,18,16,2,158,94,10,
-248,22,65,197,250,22,75,2,23,248,22,66,199,248,22,66,202,159,35,20,103,
+64,118,111,105,100,8,47,95,9,8,224,254,60,0,0,2,2,27,248,22,66,
-159,35,16,1,2,1,16,0,83,158,41,20,100,138,69,35,37,109,105,110,45,
+248,22,133,4,196,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3,
-115,116,120,2,2,11,10,11,10,35,80,158,35,35,20,103,159,35,16,0,16,
+248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,199,248,22,89,198,27,
-0,11,11,16,0,35,11,38,35,11,11,16,10,2,3,2,4,2,5,2,6,
+248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,197,250,
-2,7,2,8,2,9,2,10,2,11,2,12,16,10,11,11,11,11,11,11,11,
+22,75,2,23,248,22,66,199,248,22,66,202,159,35,20,103,159,35,16,1,2,
-11,11,11,16,10,2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,10,
+1,16,0,83,158,41,20,100,141,69,35,37,109,105,110,45,115,116,120,2,2,
-2,11,2,12,35,45,36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,
+11,10,11,10,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,1,
-0,16,0,16,0,35,35,16,11,16,5,93,2,13,20,15,159,35,35,35,35,
+2,3,36,16,0,35,11,11,38,35,11,11,16,10,2,4,2,5,2,6,2,
-20,103,159,35,16,0,16,1,33,32,10,16,5,93,2,7,89,162,43,36,52,
+7,2,8,2,9,2,10,2,11,2,12,2,13,16,10,11,11,11,11,11,11,
-9,223,0,33,33,35,20,103,159,35,16,1,20,25,159,36,2,2,2,13,16,
+11,11,11,11,16,10,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,
-0,11,16,5,93,2,9,89,162,43,36,52,9,223,0,33,34,35,20,103,159,
+11,2,12,2,13,35,45,36,11,11,16,0,16,0,16,0,35,35,11,11,11,
-35,16,1,20,25,159,36,2,2,2,13,16,0,11,16,5,93,2,12,89,162,
+16,0,16,0,16,0,35,35,16,11,16,5,93,2,3,20,15,159,35,35,35,
-43,36,52,9,223,0,33,35,35,20,103,159,35,16,1,20,25,159,36,2,2,
+35,20,103,159,35,16,0,16,1,33,32,10,16,5,93,2,8,89,162,8,44,
-2,13,16,1,33,36,11,16,5,93,2,5,89,162,43,36,55,9,223,0,33,
+36,52,9,223,0,33,33,35,20,103,159,35,16,1,20,25,159,36,2,2,2,
-37,35,20,103,159,35,16,1,20,25,159,36,2,2,2,13,16,1,33,38,11,
+3,16,0,11,16,5,93,2,10,89,162,8,44,36,52,9,223,0,33,34,35,
-16,5,93,2,3,89,162,43,36,57,9,223,0,33,41,35,20,103,159,35,16,
+20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2,
-1,20,25,159,36,2,2,2,13,16,0,11,16,5,93,2,10,89,162,43,36,
+13,89,162,8,44,36,52,9,223,0,33,35,35,20,103,159,35,16,1,20,25,
-52,9,223,0,33,43,35,20,103,159,35,16,1,20,25,159,36,2,2,2,13,
+159,36,2,2,2,3,16,1,33,36,11,16,5,93,2,6,89,162,8,44,36,
-16,0,11,16,5,93,2,6,89,162,43,36,53,9,223,0,33,44,35,20,103,
+55,9,223,0,33,37,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,
-159,35,16,1,20,25,159,36,2,2,2,13,16,0,11,16,5,93,2,4,89,
+16,1,33,38,11,16,5,93,2,4,89,162,8,44,36,57,9,223,0,33,41,
-162,43,36,54,9,223,0,33,45,35,20,103,159,35,16,1,20,25,159,36,2,
+35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,
-2,2,13,16,0,11,16,5,93,2,8,89,162,43,36,57,9,223,0,33,46,
+2,11,89,162,8,44,36,52,9,223,0,33,43,35,20,103,159,35,16,1,20,
-35,20,103,159,35,16,1,20,25,159,36,2,2,2,13,16,1,33,48,11,16,
+25,159,36,2,2,2,3,16,0,11,16,5,93,2,7,89,162,8,44,36,53,
-5,93,2,11,89,162,43,36,53,9,223,0,33,49,35,20,103,159,35,16,1,
+9,223,0,33,44,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,
-20,25,159,36,2,2,2,13,16,0,11,16,0,94,2,15,2,16,93,2,15,
+0,11,16,5,93,2,5,89,162,8,44,36,54,9,223,0,33,45,35,20,103,
-9,9,35,0};
+159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2,9,89,
-    EVAL_ONE_SIZED_STR((char *)expr, 2019);
+162,8,44,36,57,9,223,0,33,46,35,20,103,159,35,16,1,20,25,159,36,
+2,2,2,3,16,1,33,48,11,16,5,93,2,12,89,162,8,44,36,53,9,
+223,0,33,49,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,
+11,16,0,94,2,15,2,16,93,2,15,9,9,35,0};
+    EVAL_ONE_SIZED_STR((char *)expr, 2114);
   }
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,51,60,0,0,0,1,0,0,3,0,16,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,60,0,0,0,1,0,0,3,0,16,0,
 21,0,38,0,53,0,71,0,87,0,97,0,115,0,135,0,151,0,169,0,200,
 0,229,0,251,0,9,1,15,1,29,1,34,1,44,1,52,1,80,1,112,1,
 157,1,202,1,226,1,9,2,11,2,68,2,158,3,199,3,33,5,137,5,241,
 5,102,6,116,6,150,6,166,6,16,8,30,8,193,8,194,9,194,10,201,10,
 208,10,215,10,90,11,103,11,58,12,160,12,173,12,195,12,147,13,51,14,122,
-15,130,15,138,15,164,15,18,16,0,0,63,19,0,0,29,11,11,72,112,97,
+15,130,15,138,15,164,15,18,16,0,0,67,19,0,0,29,11,11,72,112,97,
 116,104,45,115,116,114,105,110,103,63,64,98,115,98,115,76,110,111,114,109,97,
 108,45,99,97,115,101,45,112,97,116,104,74,45,99,104,101,99,107,45,114,101,
 108,112,97,116,104,77,45,99,104,101,99,107,45,99,111,108,108,101,99,116,105,
@@ -302,7 +306,7 @@
 173,3,23,202,1,28,192,192,35,249,22,151,5,23,197,1,83,158,39,20,97,
 95,89,162,8,44,35,47,9,224,3,2,33,58,23,195,1,23,196,1,27,248,
 22,136,5,23,195,1,248,80,159,38,53,36,193,159,35,20,103,159,35,16,1,
-65,98,101,103,105,110,16,0,83,158,41,20,100,138,67,35,37,117,116,105,108,
+65,98,101,103,105,110,16,0,83,158,41,20,100,141,67,35,37,117,116,105,108,
 115,2,1,11,11,10,10,42,80,158,35,35,20,103,159,37,16,17,30,2,1,
 2,2,193,30,2,1,2,3,193,30,2,1,2,4,193,30,2,1,2,5,193,
 30,2,1,2,6,193,30,2,1,2,7,193,30,2,1,2,8,193,30,2,1,
@@ -311,62 +315,63 @@
 2,16,193,30,2,18,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,
 105,111,110,45,107,101,121,4,30,2,18,1,23,101,120,116,101,110,100,45,112,
 97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,16,0,11,11,16,
-4,2,6,2,5,2,3,2,9,39,11,38,35,11,11,16,11,2,8,2,7,
+0,35,16,4,2,6,2,5,2,3,2,9,39,11,11,38,35,11,11,16,11,
-2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,16,11,11,
+2,8,2,7,2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,
-11,11,11,11,11,11,11,11,11,11,16,11,2,8,2,7,2,16,2,15,2,
+2,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,8,2,7,2,
-13,2,12,2,4,2,11,2,14,2,10,2,2,46,46,36,11,11,16,0,16,
+16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,46,46,36,11,
-0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,17,83,
+11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,
-158,35,16,2,89,162,43,36,48,2,19,223,0,33,29,80,159,35,53,36,83,
+0,16,17,83,158,35,16,2,89,162,43,36,48,2,19,223,0,33,29,80,159,
-158,35,16,2,89,162,8,44,36,55,2,19,223,0,33,30,80,159,35,52,36,
+35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,19,223,0,33,30,80,
-83,158,35,16,2,32,0,89,162,43,36,44,2,2,222,33,31,80,159,35,35,
+159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,2,222,33,31,
-36,83,158,35,16,2,249,22,159,6,7,92,7,92,80,159,35,36,36,83,158,
+80,159,35,35,36,83,158,35,16,2,249,22,159,6,7,92,7,92,80,159,35,
-35,16,2,89,162,43,36,53,2,4,223,0,33,32,80,159,35,37,36,83,158,
+36,36,83,158,35,16,2,89,162,43,36,53,2,4,223,0,33,32,80,159,35,
-35,16,2,32,0,89,162,8,44,37,49,2,5,222,33,33,80,159,35,38,36,
+37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,5,222,33,33,80,
-83,158,35,16,2,32,0,89,162,8,44,38,50,2,6,222,33,35,80,159,35,
+159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,6,222,33,
-39,36,83,158,35,16,2,89,162,8,45,37,47,2,7,223,0,33,37,80,159,
+35,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,7,223,0,
-35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,8,222,33,40,80,
+33,37,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,8,
-159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2,9,222,33,41,
+222,33,40,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2,
-80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52,2,10,222,33,
+9,222,33,41,80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52,
-42,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37,53,2,11,222,
+2,10,222,33,42,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37,
-33,43,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43,36,43,2,12,
+53,2,11,222,33,43,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43,
-222,33,44,80,159,35,45,36,83,158,35,16,2,83,158,38,20,96,96,2,13,
+36,43,2,12,222,33,44,80,159,35,45,36,83,158,35,16,2,83,158,38,20,
-89,162,43,35,43,9,223,0,33,45,89,162,43,36,44,9,223,0,33,46,89,
+96,96,2,13,89,162,43,35,43,9,223,0,33,45,89,162,43,36,44,9,223,
-162,43,37,54,9,223,0,33,47,80,159,35,46,36,83,158,35,16,2,27,248,
+0,33,46,89,162,43,37,54,9,223,0,33,47,80,159,35,46,36,83,158,35,
-22,182,13,248,22,168,7,27,28,249,22,162,8,247,22,176,7,2,21,6,1,
+16,2,27,248,22,182,13,248,22,168,7,27,28,249,22,162,8,247,22,176,7,
-1,59,6,1,1,58,250,22,141,7,6,14,14,40,91,94,126,97,93,42,41,
+2,21,6,1,1,59,6,1,1,58,250,22,141,7,6,14,14,40,91,94,126,
-126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,47,2,14,223,
+97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,
-0,33,50,80,159,35,47,36,83,158,35,16,2,83,158,38,20,96,96,2,15,
+47,2,14,223,0,33,50,80,159,35,47,36,83,158,35,16,2,83,158,38,20,
-89,162,8,44,38,53,9,223,0,33,55,89,162,43,37,46,9,223,0,33,56,
+96,96,2,15,89,162,8,44,38,53,9,223,0,33,55,89,162,43,37,46,9,
-89,162,43,36,45,9,223,0,33,57,80,159,35,48,36,83,158,35,16,2,89,
+223,0,33,56,89,162,43,36,45,9,223,0,33,57,80,159,35,48,36,83,158,
-162,43,38,51,2,16,223,0,33,59,80,159,35,49,36,94,29,94,2,17,68,
+35,16,2,89,162,43,38,51,2,16,223,0,33,59,80,159,35,49,36,94,29,
-35,37,107,101,114,110,101,108,11,29,94,2,17,69,35,37,109,105,110,45,115,
+94,2,17,68,35,37,107,101,114,110,101,108,11,29,94,2,17,69,35,37,109,
-116,120,11,9,9,9,35,0};
+105,110,45,115,116,120,11,9,9,9,35,0};
-    EVAL_ONE_SIZED_STR((char *)expr, 5068);
+    EVAL_ONE_SIZED_STR((char *)expr, 5072);
   }
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,51,8,0,0,0,1,0,0,6,0,19,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,8,0,0,0,1,0,0,6,0,19,0,
-34,0,48,0,62,0,76,0,111,0,0,0,255,0,0,0,65,113,117,111,116,
+34,0,48,0,62,0,76,0,111,0,0,0,3,1,0,0,65,113,117,111,116,
 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,
 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,
 11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35,
-37,107,101,114,110,101,108,11,98,10,35,11,8,135,231,97,159,2,2,35,35,
+37,107,101,114,110,101,108,11,98,10,35,11,8,186,245,97,159,2,2,35,35,
 159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,16,
 0,159,35,20,103,159,35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,
-100,138,69,35,37,98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11,
+100,141,69,35,37,98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11,
 42,42,42,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,0,35,
-11,38,35,11,11,16,0,16,0,16,0,35,35,36,11,11,16,0,16,0,16,
+16,0,35,11,11,38,35,11,11,16,0,16,0,16,0,35,35,36,11,11,16,
-0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,0,99,2,6,
+0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,
-2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11,2,4,2,3,
+0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11,
-2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9,9,35,0};
+2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9,
-    EVAL_ONE_SIZED_STR((char *)expr, 292);
+9,35,0};
+    EVAL_ONE_SIZED_STR((char *)expr, 296);
   }
   {
-    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,51,53,0,0,0,1,0,0,3,0,14,0,
+    static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,53,0,0,0,1,0,0,3,0,14,0,
 41,0,47,0,60,0,74,0,96,0,122,0,134,0,152,0,172,0,184,0,200,
 0,223,0,3,1,8,1,13,1,18,1,27,1,32,1,63,1,67,1,75,1,
 83,1,91,1,194,1,239,1,3,2,31,2,62,2,117,2,127,2,174,2,184,
 2,191,2,78,4,91,4,110,4,229,4,241,4,137,5,151,5,15,6,21,6,
-35,6,62,6,147,6,149,6,214,6,149,12,208,12,240,12,0,0,164,15,0,
+35,6,62,6,147,6,149,6,214,6,149,12,208,12,240,12,0,0,168,15,0,
 0,29,11,11,70,100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,
 117,108,116,45,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,
 65,113,117,111,116,101,29,94,2,4,67,35,37,117,116,105,108,115,11,29,94,
@@ -525,7 +530,7 @@
 33,43,89,162,43,38,48,9,223,1,33,44,89,162,43,39,8,30,9,225,2,
 3,0,33,50,208,87,95,248,22,150,4,248,80,158,37,49,247,22,183,11,248,
 22,188,4,80,158,36,36,248,22,174,12,80,159,36,41,36,159,35,20,103,159,
-35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,100,138,66,35,37,98,
+35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,100,141,66,35,37,98,
 111,111,116,2,1,11,11,10,10,36,80,158,35,35,20,103,159,39,16,19,30,
 2,1,2,2,193,30,2,1,2,3,193,30,2,5,72,112,97,116,104,45,115,
 116,114,105,110,103,63,10,30,2,5,75,112,97,116,104,45,97,100,100,45,115,
@@ -537,26 +542,26 @@
 1,2,14,193,30,2,1,2,15,193,30,2,5,69,45,102,105,110,100,45,99,
 111,108,0,30,2,5,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97,
 116,104,6,30,2,5,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115,
-117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,11,2,10,2,
+117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,0,35,16,11,
-11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2,14,46,11,
+2,10,2,11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2,
-38,35,11,11,16,1,2,16,16,1,11,16,1,2,16,36,36,36,11,11,16,
+14,46,11,11,38,35,11,11,16,1,2,16,16,1,11,16,1,2,16,36,36,
-0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,
+36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,
-16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,159,35,57,36,
+35,16,0,16,16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,
-83,158,35,16,2,89,162,43,36,44,9,223,0,33,25,80,159,35,56,36,83,
+159,35,57,36,83,158,35,16,2,89,162,43,36,44,9,223,0,33,25,80,159,
-158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,223,0,33,26,
+35,56,36,83,158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,
-80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,105,116,104,45,
+223,0,33,26,80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,
-100,105,114,223,0,33,27,80,159,35,54,36,83,158,35,16,2,248,22,176,7,
+105,116,104,45,100,105,114,223,0,33,27,80,159,35,54,36,83,158,35,16,2,
-69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,35,16,2,89,
+248,22,176,7,69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,
-162,43,37,59,2,3,223,0,33,36,80,159,35,36,36,83,158,35,16,2,32,
+35,16,2,89,162,43,37,59,2,3,223,0,33,36,80,159,35,36,36,83,158,
-0,89,162,8,44,36,41,2,7,222,192,80,159,35,41,36,83,158,35,16,2,
+35,16,2,32,0,89,162,8,44,36,41,2,7,222,192,80,159,35,41,36,83,
-247,22,125,80,159,35,42,36,83,158,35,16,2,247,22,124,80,159,35,43,36,
+158,35,16,2,247,22,125,80,159,35,42,36,83,158,35,16,2,247,22,124,80,
-83,158,35,16,2,247,22,60,80,159,35,44,36,83,158,35,16,2,248,22,18,
+159,35,43,36,83,158,35,16,2,247,22,60,80,159,35,44,36,83,158,35,16,
-74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,35,45,36,83,
+2,248,22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,
-158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,35,47,83,158,
+35,45,36,83,158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,
-35,16,2,32,0,89,162,43,37,44,2,14,222,33,42,80,159,35,48,36,83,
+35,47,83,158,35,16,2,32,0,89,162,43,37,44,2,14,222,33,42,80,159,
-158,35,16,2,89,162,8,44,36,44,2,15,223,0,33,51,80,159,35,49,36,
+35,48,36,83,158,35,16,2,89,162,8,44,36,44,2,15,223,0,33,51,80,
-83,158,35,16,2,89,162,43,35,43,2,16,223,0,33,52,80,159,35,53,36,
+159,35,49,36,83,158,35,16,2,89,162,43,35,43,2,16,223,0,33,52,80,
-95,29,94,2,4,68,35,37,107,101,114,110,101,108,11,29,94,2,4,69,35,
+159,35,53,36,95,29,94,2,4,68,35,37,107,101,114,110,101,108,11,29,94,
-37,109,105,110,45,115,116,120,11,2,5,9,9,9,35,0};
+2,4,69,35,37,109,105,110,45,115,116,120,11,2,5,9,9,9,35,0};
-    EVAL_ONE_SIZED_STR((char *)expr, 4131);
+    EVAL_ONE_SIZED_STR((char *)expr, 4135);
   }

src/mzscheme/src/eval.c

@@ -2220,6 +2220,11 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
   if (info->inline_fuel < 0)
     return NULL;
   
+  if (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) {
+    /* Found a `((lambda' */
+    single_use = 1;
+  }
+
   if (SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) {
     /* Check for inlining: */
     le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le), &offset, &single_use);
@@ -2458,6 +2463,16 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
     le = scheme_optimize_expr(app->args[i], info);
     app->args[i] = le;
 
+    if (!i) {
+      if (SAME_TYPE(SCHEME_TYPE(app->args[0]),scheme_compiled_unclosed_procedure_type)) {
+        /* Found "((lambda" after optimizing; try again */
+        le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags);
+        if (le)
+          return le;
+      }
+    }
+
+
     if (i && (SCHEME_TYPE(le) < _scheme_compiled_values_types_))
       all_vals = 0;
   }
@@ -2501,6 +2516,13 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
   le = scheme_optimize_expr(app->rator, info);
   app->rator = le;
 
+  if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) {
+    /* Found "((lambda" after optimizing; try again */
+    le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags);
+    if (le)
+      return le;
+  }
+
   le = scheme_optimize_expr(app->rand, info);
   app->rand = le;
   if (SCHEME_TYPE(le) > _scheme_compiled_values_types_) {
@@ -2564,6 +2586,13 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
   le = scheme_optimize_expr(app->rator, info);
   app->rator = le;
 
+  if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) {
+    /* Found "((lambda" after optimizing; try again */
+    le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags);
+    if (le)
+      return le;
+  }
+
   /* 1st arg */
 
   le = scheme_optimize_expr(app->rand1, info);

src/mzscheme/src/jit.c

@@ -3185,10 +3185,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
   }
   CHECK_LIMIT();
 
-  if (arith == 2) {
+  if (arith == -2) {
-    if (rand2 || ((v != 0) && (v != 1)))
-      has_fixnum_fast = 0;
-  } else if (arith == -2) {
     if (rand2 || (v != 1) || reversed)
       has_fixnum_fast = 0;
   }
@@ -3326,10 +3323,10 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
 	}
 	jit_ori_ul(JIT_R0, JIT_R2, 0x1);
       } else if (arith == 2) {
-        if (has_fixnum_fast) {
+        jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
-          /* No fast path for fixnum multiplication, yet */
+        jit_rshi_l(JIT_V1, JIT_R0, 0x1);
-          (void)jit_jmpi(refslow);
+        (void)jit_bomulr_l(refslow, JIT_V1, JIT_R2);
-        }
+        jit_ori_ul(JIT_R0, JIT_V1, 0x1);
       } else if (arith == -2) {
         if (has_fixnum_fast) {
           /* No fast path for fixnum division, yet */
@@ -3432,11 +3429,11 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
         } else if (v == 0) {
           (void)jit_movi_p(JIT_R0, scheme_make_integer(0));
         } else {
-          if (has_fixnum_fast) {
+          (void)jit_movi_p(JIT_R1, scheme_make_integer(v));
-            /* No general fast path for fixnum multiplication, yet */
+          jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
-            (void)jit_movi_p(JIT_R1, scheme_make_integer(v));
+          jit_rshi_l(JIT_V1, JIT_R0, 0x1);
-            (void)jit_jmpi(refslow);
+          (void)jit_bomulr_l(refslow, JIT_V1, JIT_R2);
-          }
+          jit_ori_ul(JIT_R0, JIT_V1, 0x1);
         }
       } else if (arith == -2) {
         if ((v == 1) && !reversed) {

src/mzscheme/src/lightning/i386/asm.h

@@ -217,6 +217,11 @@ typedef _uc		jit_insn;
 # define _qOr(       OP,R                       ) _Or(OP,R) 
 #endif
 #define	 _OO(	     OP				)  ( _jit_B((OP)>>8), _jit_B( (OP)	)				  )
+#ifdef JIT_X86_64
+# define _qOO(OP)  ( _REX(0,0,0), _OO(OP))
+#else
+# define _qOO(OP) _OO(OP)
+#endif
 #define	 _OOr(	     OP,R			)  ( _jit_B((OP)>>8), _jit_B( (OP)|_r(R))				  )
 #define	  _Os(	     OP,B			)  (	_s8P(B) ? _jit_B(((OP)|_b10)) : _jit_B(OP)			  )
 #ifdef JIT_X86_64
@@ -240,6 +245,7 @@ typedef _uc		jit_insn;
 #define	  _O_Mrm(    OP	 ,MO,R,M		)  (	    _O	    (  OP  ),_Mrm(MO,R,M	    )		  )
 #define	 _qO_Mrm(    OP	 ,MO,R,M		)  (	    _qO	    (  OP,R,0,M),_qMrm(MO,R,M	    )		  )
 #define	 _OO_Mrm(    OP	 ,MO,R,M		)  (	   _OO	    (  OP  ),_Mrm(MO,R,M	    )		  )
+#define	 _qOO_Mrm(   OP	 ,MO,R,M		)  (	   _qOO	    (  OP  ),_Mrm(MO,R,M	    )		  )
 #define	  _O_Mrm_B(  OP	 ,MO,R,M	    ,B	)  (	    _O	    (  OP  ),_Mrm(MO,R,M	    ) ,_jit_B(B)	  )
 #define	 _qO_Mrm_B(  OP	 ,MO,R,M	    ,B	)  (	    _qO	    (  OP,R,0,M),_qMrm(MO,R,M	    ) ,_jit_B(B)	  )
 #define	  _O_Mrm_W(  OP	 ,MO,R,M	    ,W	)  (	    _O	    (  OP  ),_Mrm(MO,R,M	    ) ,_jit_W(W)	  )
@@ -500,6 +506,7 @@ typedef _uc		jit_insn;
 #define IMULLirr(IM,RS,RD)		_Os_Mrm_sL	(0x69		,_b11,_r4(RS),_r4(RD)			,IM	)
 #define IMULLimr(IM,MD,MB,MI,MS,RD)	_Os_r_X_sL	(0x69		     ,_r4(RD)		,MD,MB,MI,MS	,IM	)
 
+#define IMULQrr(RS,RD)			_qOO_Mrm	(0x0faf		,_b11,_r4(RD),_r4(RS)				)
 
 #define INCBr(RD)			_O_Mrm		(0xfe		,_b11,_b000  ,_r1(RD)				)
 #define INCBm(MD,MB,MI,MS)		_O_r_X		(0xfe		     ,_b000		,MD,MB,MI,MS		)

src/mzscheme/src/lightning/i386/core.h

@@ -467,6 +467,7 @@ static int jit_arg_reg_order[] = { _EDI, _ESI, _EDX, _ECX };
 #define jit_bosubr_l(label, s1, s2)	(SUBQrr((s2), (s1)), JOm(label,0,0,0), _jit.x.pc)
 #define jit_boaddr_ul(label, s1, s2)	(ADDQrr((s2), (s1)), JCm(label,0,0,0), _jit.x.pc)
 #define jit_bosubr_ul(label, s1, s2)	(SUBQrr((s2), (s1)), JCm(label,0,0,0), _jit.x.pc)
+#define jit_bomulr_l(label, s1, s2)	(IMULQrr((s2), (s1)), JOm(label,0,0,0), _jit.x.pc)
 
 #define jit_blti_i(label, rs, is)	jit_bra_i0((rs), (is), JLm(label, 0,0,0), JSm(label, 0,0,0) )
 #define jit_blei_i(label, rs, is)	jit_bra_i ((rs), (is), JLEm(label,0,0,0)		    )

src/mzscheme/src/lightning/ppc/core.h

@@ -177,6 +177,7 @@ struct jit_local_state {
 #define jit_bosubi_ui(label, rs, is)	(jit_chk_ims ((is), SUBICri((rs), (rs), is), SUBCrr((rs), JIT_AUX)),       MCRXRi(0), BEQi((label)), _jit.x.pc)
 #define jit_boaddr_ui(label, s1, s2)	(		  			     ADDCrr((s1), (s1), (s2)), 	   MCRXRi(0), BEQi((label)), _jit.x.pc)
 #define jit_bosubr_ui(label, s1, s2)	(		  			     SUBCrr((s1), (s1), (s2)), 	   MCRXRi(0), BEQi((label)), _jit.x.pc)
+#define jit_bomulr_i(label, s1, s2)	(		         MULLWOrrr((s1), (s1), (s2)), 	   MCRXRi(0), BGTi((label)), _jit.x.pc)
 #define jit_calli(label)	        ((void)jit_movi_p(JIT_AUX, (label)), MTCTRr(JIT_AUX), BCTRL(), _jitl.nextarg_puti = _jitl.nextarg_putf = _jitl.nextarg_putd = 0, _jit.x.pc)
 #define jit_callr(reg)			(MTCTRr(reg), BCTRL())
 #define jit_divi_i(d, rs, is)		jit_big_ims((is), DIVWrrr ((d), (rs), JIT_AUX))

src/mzscheme/src/module.c

@@ -244,7 +244,11 @@ static char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash
                                     Scheme_Module_Exports *me,
                                     Scheme_Env *genv,
                                     int reprovide_kernel,
-                                    Scheme_Object *form);
+                                    Scheme_Object *form,
+                                    char **_phase1_protects);
+static Scheme_Object **compute_indirects(Scheme_Env *genv, 
+                                         Scheme_Module_Phase_Exports *pt,
+                                         int *_count);
 static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, 
                          int eval_exp, int eval_run, long base_phase, Scheme_Object *cycle_list);
 static void finish_expstart_module(Scheme_Env *menv);
@@ -3100,28 +3104,51 @@ static Scheme_Module *module_load(Scheme_Object *name, Scheme_Env *env, const ch
 static void setup_accessible_table(Scheme_Module *m)
 {
   if (!m->accessible) {
-    Scheme_Hash_Table *ht;
+    Scheme_Module_Phase_Exports *pt;
-    int i, count, nvp;
+    int j;
 
-    ht = scheme_make_hash_table(SCHEME_hash_ptr);
+    for (j = 0; j < 2; j++) {
-    nvp = m->me->rt->num_var_provides;
+      if (!j)
-    for (i = 0; i < nvp; i++) {
+        pt = m->me->rt;
-      if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) {
+      else
-	scheme_hash_set(ht, m->me->rt->provide_src_names[i], scheme_make_integer(i));
+        pt = m->me->et;
-      }
-    }
       
-    count = m->num_indirect_provides;
+      if (pt) {
-    for (i = 0; i < count; i++) {
+        Scheme_Hash_Table *ht;
-      scheme_hash_set(ht, m->indirect_provides[i], scheme_make_integer(i + nvp));
+        int i, count, nvp;
-    }
-    m->accessible = ht;
         
-    /* Add syntax as negative ids: */
+        ht = scheme_make_hash_table(SCHEME_hash_ptr);
-    count = m->me->rt->num_provides;
+        nvp = pt->num_var_provides;
-    for (i = nvp; i < count; i++) {
+        for (i = 0; i < nvp; i++) {
-      if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) {
+          if (SCHEME_FALSEP(pt->provide_srcs[i])) {
-	scheme_hash_set(ht, m->me->rt->provide_src_names[i], scheme_make_integer(-(i+1)));
+            scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(i));
+          }
+        }
+        
+        if (j == 0) {
+          count = m->num_indirect_provides;
+          for (i = 0; i < count; i++) {
+            scheme_hash_set(ht, m->indirect_provides[i], scheme_make_integer(i + nvp));
+          }
+        } else {
+          count = m->num_indirect_et_provides;
+          for (i = 0; i < count; i++) {
+            scheme_hash_set(ht, m->et_indirect_provides[i], scheme_make_integer(i + nvp));
+          }
+        }
+        
+        /* Add syntax as negative ids: */
+        count = pt->num_provides;
+        for (i = nvp; i < count; i++) {
+          if (SCHEME_FALSEP(pt->provide_srcs[i])) {
+            scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(-(i+1)));
+          }
+        }
+
+        if (!j)
+          m->accessible = ht;
+        else
+          m->et_accessible = ht;
       }
     }
   }
@@ -3212,110 +3239,163 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
 	supplied (not both). For unprotected access, both prot_insp
 	and stx+certs should be supplied. */
 {
-  symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL, NULL);
+  Scheme_Module_Phase_Exports *pt;
+
+  if (!SCHEME_SYMBOLP(symbol))
+    symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL, NULL);
 
   if (scheme_is_kernel_env(env)
-      || ((env->module->primitive && !env->module->provide_protects))
+      || ((env->module->primitive && !env->module->provide_protects))) {
-      /* For now[?], we're pretending that all definitions exists for
-	 non-0 local phase. */
-      || env->mod_phase) {
     if (want_pos)
       return scheme_make_integer(-1);
     else
       return symbol;
   }
 
-  if (position >= 0) {
+  switch (env->mod_phase) {
-    /* Check whether the symbol at `pos' matches the string part of
+  case 0:
-       the expected symbol.  */
+    pt = env->module->me->rt;
-    Scheme_Object *isym;
+    break;
-    int need_cert = 0;
+  case 1:
+    pt = env->module->me->et;
+    break;
+  default:
+    pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(env->module->me->other_phases,
+                                                        scheme_make_integer(env->mod_phase));
+    break;
+  }
 
-    if (position < env->module->me->rt->num_var_provides) {
+  if (pt) {
-      if (!env->module->me->rt->provide_srcs
+    if (position >= 0) {
-          || SCHEME_FALSEP(env->module->me->rt->provide_srcs[position]))
+      /* Check whether the symbol at `pos' matches the string part of
-	isym = env->module->me->rt->provide_src_names[position];
+         the expected symbol.  */
-      else
+      Scheme_Object *isym;
-	isym = NULL;
+      int need_cert = 0;
-    } else {
-      int ipos = position - env->module->me->rt->num_var_provides;
-      if (ipos < env->module->num_indirect_provides) {
-	isym = env->module->indirect_provides[ipos];
-	need_cert = 1;
-	if (_protected)
-	  *_protected = 1;
-      } else
-	isym = NULL;
-    }
 
-    if (isym) {
+      if (position < pt->num_var_provides) {
-      if (SAME_OBJ(isym, symbol)
+        if (!pt->provide_srcs
-	  || (SCHEME_SYM_LEN(isym) == SCHEME_SYM_LEN(symbol)
+            || SCHEME_FALSEP(pt->provide_srcs[position]))
-	      && !memcmp(SCHEME_SYM_VAL(isym), SCHEME_SYM_VAL(symbol), SCHEME_SYM_LEN(isym)))) {
+          isym = pt->provide_src_names[position];
-	
+        else
-	if ((position < env->module->me->rt->num_var_provides)
+          isym = NULL;
-	    && scheme_module_protected_wrt(env->insp, prot_insp)
-	    && env->module->provide_protects
-	    && env->module->provide_protects[position]) {
-	  if (_protected)
-	    *_protected = 1;
-	  check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1);
-	}
-
-	if (need_cert)
-	  check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0);
-	
-	if (want_pos)
-	  return scheme_make_integer(position);
-	else
-	  return isym;
-      } 
-    }
-    /* failure */
-  } else {
-    Scheme_Object *pos;
-
-    pos = scheme_hash_get(env->module->accessible, symbol);
-
-    if (pos) {
-      if (position < -1) {
-	if (SCHEME_INT_VAL(pos) < 0)
-	  pos = scheme_make_integer(-SCHEME_INT_VAL(pos) - 1);
-	else
-	  pos = NULL;
       } else {
-	if (SCHEME_INT_VAL(pos) < 0)
+        int ipos = position - pt->num_var_provides;
-	  pos = NULL;
+        int num_indirect_provides;
-      }
+        Scheme_Object **indirect_provides;
-    }
 
-    if (pos) {
+        if (env->mod_phase == 0) {
-      if (env->module->provide_protects
+          num_indirect_provides = env->module->num_indirect_provides;
-	  && (SCHEME_INT_VAL(pos) < env->module->me->rt->num_provides)
+          indirect_provides = env->module->indirect_provides;
-	  && env->module->provide_protects[SCHEME_INT_VAL(pos)]) {
+        } else if (env->mod_phase == 1) {
-	if (_protected)
+          num_indirect_provides = env->module->num_indirect_et_provides;
-	  *_protected = 1;
+          indirect_provides = env->module->et_indirect_provides;
-	check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1);
+        } else {
+          num_indirect_provides = 0;
+          indirect_provides = NULL;
+        }
+
+        if (ipos < num_indirect_provides) {
+          isym = indirect_provides[ipos];
+          need_cert = 1;
+          if (_protected)
+            *_protected = 1;
+        } else
+          isym = NULL;
       }
 
-      if ((position >= -1) 
+      if (isym) {
-	  && (SCHEME_INT_VAL(pos) >= env->module->me->rt->num_var_provides)) {
+        if (SAME_OBJ(isym, symbol)
-	/* unexported var -- need cert */
+            || (SCHEME_SYM_LEN(isym) == SCHEME_SYM_LEN(symbol)
-	if (_protected)
+                && !memcmp(SCHEME_SYM_VAL(isym), SCHEME_SYM_VAL(symbol), SCHEME_SYM_LEN(isym)))) {
-	  *_protected = 1;
-	check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0);
-      }
 	
-      if (want_pos)
+          if ((position < pt->num_var_provides)
-        return pos;
+              && scheme_module_protected_wrt(env->insp, prot_insp)) {
+            char *provide_protects;
+            
+            if (env->mod_phase == 0)
+              provide_protects = env->module->provide_protects;
+            else if (env->mod_phase == 0)
+              provide_protects = env->module->et_provide_protects;
+            else
+              provide_protects = NULL;
+            
+            if (provide_protects
+                && provide_protects[position]) {
+              if (_protected)
+                *_protected = 1;
+              check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1);
+            }
+          }
+
+          if (need_cert)
+            check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0);
+	
+          if (want_pos)
+            return scheme_make_integer(position);
+          else
+            return isym;
+        } 
+      }
+      /* failure */
+    } else {
+      Scheme_Object *pos;
+
+      if (!env->mod_phase)
+        pos = scheme_hash_get(env->module->accessible, symbol);
+      else if (env->mod_phase == 1)
+        pos = scheme_hash_get(env->module->et_accessible, symbol);
       else
-	return symbol;
+        pos = NULL;
-    }
 
-    if (position < -1) {
+      if (pos) {
-      /* unexported syntax -- need cert */
+        if (position < -1) {
-      check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 0, 0);
+          if (SCHEME_INT_VAL(pos) < 0)
-      return NULL;
+            pos = scheme_make_integer(-SCHEME_INT_VAL(pos) - 1);
+          else
+            pos = NULL;
+        } else {
+          if (SCHEME_INT_VAL(pos) < 0)
+            pos = NULL;
+        }
+      }
+
+      if (pos) {
+        char *provide_protects;
+
+        if (env->mod_phase == 0)
+          provide_protects = env->module->provide_protects;
+        else if (env->mod_phase == 1)
+          provide_protects = env->module->et_provide_protects;
+        else
+          provide_protects = NULL;
+
+        if (provide_protects
+            && (SCHEME_INT_VAL(pos) < pt->num_provides)
+            && provide_protects[SCHEME_INT_VAL(pos)]) {
+          if (_protected)
+            *_protected = 1;
+          check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1);
+        }
+
+        if ((position >= -1) 
+            && (SCHEME_INT_VAL(pos) >= pt->num_var_provides)) {
+          /* unexported var -- need cert */
+          if (_protected)
+            *_protected = 1;
+          check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0);
+        }
+
+        if (want_pos)
+          return pos;
+        else
+          return symbol;
+      }
+
+      if (position < -1) {
+        /* unexported syntax -- need cert */
+        check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 0, 0);
+        return NULL;
+      }
     }
   }
 
@@ -3338,11 +3418,12 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
 
     scheme_wrong_syntax("link", stx, symbol, 
                         "module mismatch, probably from old bytecode whose dependencies have changed: "
-                        "variable not provided (directly or indirectly%s) from module: %D %s%t",
+                        "variable not provided (directly or indirectly%s) from module: %D%s%t at source phase level: %d",
                         (position >= 0) ? " and at the expected position" : "",
                         env->module->modname,
-                        srclen ? "accessed from module: " : "",
+                        srclen ? " accessed from module: " : "",
-                        srcstr, srclen);
+                        srcstr, srclen,
+                        env->mod_phase);
   }
 
   return NULL;
@@ -5597,10 +5678,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
   Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */
   Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */
   Scheme_Object *exclude_hint = scheme_false, *lift_data;
-  Scheme_Object **exis;
+  Scheme_Object **exis, **et_exis;
   Scheme_Object *lift_ctx;
-  int exicount;
+  int exicount, et_exicount;
-  char *exps;
+  char *exps, *et_exps;
   int all_simple_renames = 1;
   int maybe_has_lifts = 0;
   int reprovide_kernel;
@@ -5979,13 +6060,14 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
           mrec.pre_unwrapped = 0;
           mrec.env_already = 0;
           mrec.comp_flags = rec[drec].comp_flags;
+          scheme_rec_add_certs(&mrec, 0, e);
 
 	  if (!rec[drec].comp) {
 	    Scheme_Expand_Info erec1;
 	    erec1.comp = 0;
 	    erec1.depth = -1;
 	    erec1.value_name = boundname;
-	    erec1.certs = rec[drec].certs;
+	    erec1.certs = mrec.certs;
             erec1.observer = rec[drec].observer;
             erec1.pre_unwrapped = 0;
             erec1.env_already = 0;
@@ -6310,51 +6392,16 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
                                 env->genv->module->me,
                                 env->genv,
                                 reprovide_kernel,
-                                form);
+                                form, &et_exps);
+  
+  /* Compute indirect provides (which is everything at the top-level): */
+  exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount);
+  et_exis = compute_indirects(env->genv->exp_env, env->genv->module->me->et, &et_exicount);
 
   if (rec[drec].comp || (rec[drec].depth != -2)) {
     scheme_clean_dead_env(env->genv);
   }
 
-  /* Compute indirect provides (which is everything at the top-level): */
-  {
-    int i, count, j;
-    Scheme_Bucket **bs, *b;
-    Scheme_Object **exsns = env->genv->module->me->rt->provide_src_names;
-    int exvcount = env->genv->module->me->rt->num_var_provides;
-    
-    bs = env->genv->toplevel->buckets;
-    for (count = 0, i = env->genv->toplevel->size; i--; ) {
-      b = bs[i];
-      if (b && b->val)
-	count++;
-    }
-
-    exis = MALLOC_N(Scheme_Object *, count);
-
-    for (count = 0, i = env->genv->toplevel->size; i--; ) {
-      b = bs[i];
-      if (b && b->val) {
-	Scheme_Object *name;
-	  
-	name = (Scheme_Object *)b->key;
-	
-	/* If the name is directly provided, no need for indirect... */
-	for (j = 0; j < exvcount; j++) {
-	  if (SAME_OBJ(name, exsns[j]))
-	    break;
-	}
-	
-	if (j == exvcount)
-	  exis[count++] = name;
-      }
-    }
-
-    exicount = count;
-
-    qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1);
-  }
-
   if (!rec[drec].comp) {
     Scheme_Module_Phase_Exports *rt = env->genv->module->me->rt;
     int excount = rt->num_provides;
@@ -6464,6 +6511,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
     env->genv->module->et_body = exp_body_r;
 
     env->genv->module->provide_protects = exps;
+    env->genv->module->et_provide_protects = et_exps;
 
     env->genv->module->me->rt->reprovide_kernel = reprovide_kernel;
     env->genv->module->me->rt->kernel_exclusion = exclude_hint;
@@ -6471,6 +6519,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
     env->genv->module->indirect_provides = exis;
     env->genv->module->num_indirect_provides = exicount;
 
+    env->genv->module->et_indirect_provides = et_exis;
+    env->genv->module->num_indirect_et_provides = et_exicount;
+
     env->genv->module->comp_prefix = cenv->prefix;
 
     if (all_simple_renames) {
@@ -6877,6 +6928,64 @@ int compute_reprovides(Scheme_Hash_Table *all_provided,
   return reprovide_kernel;
 }
 
+static Scheme_Object **compute_indirects(Scheme_Env *genv, 
+                                         Scheme_Module_Phase_Exports *pt,
+                                         int *_count)
+{
+  int i, count, j;
+  Scheme_Bucket **bs, *b;
+  Scheme_Object **exsns = pt->provide_src_names, **exis;
+  int exvcount = pt->num_var_provides, exicount;
+
+  if (!genv->toplevel)
+    count = 0;
+  else {
+    bs = genv->toplevel->buckets;
+    for (count = 0, i = genv->toplevel->size; i--; ) {
+      b = bs[i];
+      if (b && b->val)
+        count++;
+    }
+  }
+
+  if (!count) {
+    *_count = 0;
+    return NULL;
+  }
+  
+  exis = MALLOC_N(Scheme_Object *, count);
+
+  for (count = 0, i = genv->toplevel->size; i--; ) {
+    b = bs[i];
+    if (b && b->val) {
+      Scheme_Object *name;
+      
+      name = (Scheme_Object *)b->key;
+      
+      /* If the name is directly provided, no need for indirect... */
+      for (j = 0; j < exvcount; j++) {
+        if (SAME_OBJ(name, exsns[j]))
+          break;
+      }
+	
+      if (j == exvcount)
+        exis[count++] = name;
+    }
+  }
+
+  if (!count) {
+    *_count = 0;
+    return NULL;
+  }
+  
+  exicount = count;
+
+  qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1);
+
+  *_count = exicount;
+  return exis;
+}
+
 Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bindings, Scheme_Object *modpath,
                                            Scheme_Object *mode)
 {
@@ -6978,12 +7087,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
                              Scheme_Module_Exports *me,
                              Scheme_Env *genv,
                              int reprovide_kernel,
-                             Scheme_Object *form)
+                             Scheme_Object *form,
+                             char **_phase1_protects)
 {
   int i, count, z;
   Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase;
   Scheme_Hash_Table *provided, *required;
-  char *exps, *exets, *phase0_exps = NULL;
+  char *exps, *exets, *phase0_exps = NULL, *phase1_exps = NULL;
   int excount, exvcount;
   Scheme_Module_Phase_Exports *pt;
   
@@ -7189,9 +7299,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
 
       if (SAME_OBJ(phase, scheme_make_integer(0)))
         phase0_exps = exps;
+      else if (SAME_OBJ(phase, scheme_make_integer(1)))
+        phase1_exps = exps;
     }
   }
 
+  *_phase1_protects = phase1_exps;
+    
   return phase0_exps;
 }
 
@@ -8944,7 +9058,6 @@ static Scheme_Object *write_module(Scheme_Object *obj)
   l = cons(scheme_make_integer(cnt), l);
 
   count = m->me->rt->num_provides;
-
   if (m->provide_protects) {
     for (i = 0; i < count; i++) {
       if (m->provide_protects[i])
@@ -8961,16 +9074,39 @@ static Scheme_Object *write_module(Scheme_Object *obj)
   } else
     l = cons(scheme_false, l);
   
-  l = cons(scheme_make_integer(m->num_indirect_provides), l);
+  count = m->me->et->num_provides;
+  if (m->et_provide_protects) {
+    for (i = 0; i < count; i++) {
+      if (m->et_provide_protects[i])
+	break;
+    }
+    if (i < count) {
+      v = scheme_make_vector(count, NULL);
+      for (i = 0; i < count; i++) {
+	SCHEME_VEC_ELS(v)[i] = (m->et_provide_protects[i] ? scheme_true : scheme_false);
+      }
+    } else
+      v = scheme_false;
+    l = cons(v, l);
+  } else
+    l = cons(scheme_false, l);
   
   count = m->num_indirect_provides;
-
+  l = cons(scheme_make_integer(count), l);
   v = scheme_make_vector(count, NULL);
   for (i = 0; i < count; i++) {
     SCHEME_VEC_ELS(v)[i] = m->indirect_provides[i];
   }
   l = cons(v, l);
 
+  count = m->num_indirect_et_provides;
+  l = cons(scheme_make_integer(count), l);
+  v = scheme_make_vector(count, NULL);
+  for (i = 0; i < count; i++) {
+    SCHEME_VEC_ELS(v)[i] = m->et_indirect_provides[i];
+  }
+  l = cons(v, l);
+
   l = cons(m->me->rt->reprovide_kernel ? scheme_true : scheme_false, l);
   l = cons(m->me->rt->kernel_exclusion, l);
 
@@ -9017,7 +9153,7 @@ static Scheme_Object *read_module(Scheme_Object *obj)
 {
   Scheme_Module *m;
   Scheme_Object *ie, *nie;
-  Scheme_Object *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v;
+  Scheme_Object *eesp, *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v;
   Scheme_Module_Exports *me;
   Scheme_Module_Phase_Exports *pt;
   char *ps, *sps;
@@ -9095,6 +9231,24 @@ static Scheme_Object *read_module(Scheme_Object *obj)
   
   count = SCHEME_INT_VAL(nie);
 
+  if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL();
+  v = MALLOC_N(Scheme_Object *, count);
+  for (i = 0; i < count; i++) {
+    v[i] = SCHEME_VEC_ELS(ie)[i];
+  }
+  m->et_indirect_provides = v;
+  m->num_indirect_et_provides = count;
+
+  if (!SCHEME_PAIRP(obj)) return_NULL();
+  ie = SCHEME_CAR(obj);
+  obj = SCHEME_CDR(obj);
+
+  if (!SCHEME_PAIRP(obj)) return_NULL();
+  nie = SCHEME_CAR(obj);
+  obj = SCHEME_CDR(obj);
+  
+  count = SCHEME_INT_VAL(nie);
+
   if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL();
   v = MALLOC_N(Scheme_Object *, count);
   for (i = 0; i < count; i++) {
@@ -9103,6 +9257,10 @@ static Scheme_Object *read_module(Scheme_Object *obj)
   m->indirect_provides = v;
   m->num_indirect_provides = count;
 
+  if (!SCHEME_PAIRP(obj)) return_NULL();
+  eesp = SCHEME_CAR(obj);
+  obj = SCHEME_CDR(obj);
+
   if (!SCHEME_PAIRP(obj)) return_NULL();
   esp = SCHEME_CAR(obj);
   obj = SCHEME_CDR(obj);
@@ -9230,6 +9388,17 @@ static Scheme_Object *read_module(Scheme_Object *obj)
     m->provide_protects = ps;
   }
 
+  if (SCHEME_FALSEP(eesp)) {
+    m->et_provide_protects = NULL;
+  } else {
+    if (!SCHEME_VECTORP(eesp) || (SCHEME_VEC_SIZE(eesp) != count)) return_NULL();
+    ps = MALLOC_N_ATOMIC(char, count);
+    for (i = 0; i < count; i++) {
+      ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(eesp)[i]);
+    }
+    m->et_provide_protects = ps;
+  }
+
   if (!SCHEME_PAIRP(obj)) return_NULL();
   e = SCHEME_CAR(obj);
   if (!SCHEME_VECTORP(e)) return_NULL();

src/mzscheme/src/schpriv.h

@@ -2563,8 +2563,8 @@ typedef struct Scheme_Module
 
   Scheme_Object *self_modidx;
 
-  Scheme_Hash_Table *accessible;
+  Scheme_Hash_Table *accessible; /* (symbol -> ...) */
-  Scheme_Hash_Table *et_accessible;
+  Scheme_Hash_Table *et_accessible; /* phase -> (symbol -> ...) */
   Scheme_Object *insp; /* declaration-time inspector, for creating certificates
 			  and for module instantiation */
 

src/mzscheme/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "4.1.3.3"
+#define MZSCHEME_VERSION "4.1.3.4"
 
 #define MZSCHEME_VERSION_X 4
 #define MZSCHEME_VERSION_Y 1
 #define MZSCHEME_VERSION_Z 3
-#define MZSCHEME_VERSION_W 3
+#define MZSCHEME_VERSION_W 4
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

src/mzscheme/src/stxobj.c

@@ -185,8 +185,10 @@ typedef struct Scheme_Cert {
 /* Certs encoding:
     - NULL: no inactive or active certs; 
             maybe inactive certs in nested parts
-    - cons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL); 
+    - rcons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL); 
-                    no inactive certs in nested parts */
+            maybe inactive certs in nested parts 
+    - immutable-rcons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL); 
+            no inactive certs in nested parts (using the immutable flag as a hack!) */
 #define ACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CAR((stx)->certs) : (stx)->certs) : NULL))
 #define INACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CDR((stx)->certs) : NULL) : NULL))
 static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp);
@@ -557,6 +559,7 @@ void scheme_init_stx(Scheme_Env *env)
 
   REGISTER_SO(no_nested_inactive_certs);
   no_nested_inactive_certs = scheme_make_raw_pair(NULL, NULL);
+  SCHEME_SET_IMMUTABLE(no_nested_inactive_certs);
 }
 
 /*========================================================================*/
@@ -1983,15 +1986,20 @@ static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int
 	icerts = first;
     }
 
-    /* Even if icerts is NULL, preserve the pair in ->certs, 
+    /* Even if icerts is NULL, may preserve the pair in ->certs, 
-       to indicate no nested inactive certs. */
+       to indicate no nested inactive certs: */
+    {
+      int no_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs)
+                    && SCHEME_IMMUTABLEP(((Scheme_Stx *)o)->certs));
+      if (icerts || no_sub) {
+        nc = scheme_make_raw_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts);
+        if (no_sub)
+          SCHEME_SET_IMMUTABLE(nc);
+      } else
+        nc = (Scheme_Object *)acerts;
       
-    if (icerts || SCHEME_RPAIRP(((Scheme_Stx *)o)->certs)) {
+      ((Scheme_Stx *)o)->certs = nc;
-      nc = scheme_make_raw_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts);
+    }
-    } else
-      nc = (Scheme_Object *)acerts;
-
-    ((Scheme_Stx *)o)->certs = nc;
   }
 }
 
@@ -2396,7 +2404,6 @@ static Scheme_Cert *append_certs(Scheme_Cert *a, Scheme_Cert *b)
 }
 
 static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Object *use_key, int active)
-/* If !active, then inactive certs must have been lifted already. */
 {
   Scheme_Cert *orig_certs, *cl, *now_certs, *next_certs;
   Scheme_Stx *stx = (Scheme_Stx *)o, *res;
@@ -2469,9 +2476,13 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
 	if (!active) {
 	  pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)orig_certs);
 	  res->certs = pr;
+          if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs))
+            SCHEME_SET_IMMUTABLE(pr);
 	} else if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
 	  pr = scheme_make_raw_pair((Scheme_Object *)orig_certs, SCHEME_CDR(stx->certs));
 	  res->certs = pr;
+          if (SCHEME_IMMUTABLEP(stx->certs))
+            SCHEME_SET_IMMUTABLE(pr);
 	} else
 	  res->certs = (Scheme_Object *)orig_certs;
 	stx = res;
@@ -2529,7 +2540,8 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
 			       int active)
      /* If `name' is module-bound, add the module's certification.
 	Also copy any certifications from plus_stx.
-	If active and mark is non-NULL, make inactive certificates active. */
+	If active and mark is non-NULL, make inactive certificates active.
+        Existing inactive are lifted when adding from plus_stx_or_certs. */
 {
   if (mark && active) {
     o = scheme_stx_activate_certs(o);
@@ -2576,19 +2588,23 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
       cert = INACTIVE_CERTS(stx);
 
     cert = cons_cert(mark, menv->link_midx ? menv->link_midx : menv->module->me->src_modidx, 
-		     menv->module->insp, key, cert);
+                     menv->module->insp, key, cert);
 
     if (active) {
       if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
 	Scheme_Object *pr;
 	pr = scheme_make_raw_pair((Scheme_Object *)cert, SCHEME_CDR(stx->certs));
 	res->certs = pr;
+        if (SCHEME_IMMUTABLEP(stx->certs))
+          SCHEME_SET_IMMUTABLE(pr);
       } else
 	res->certs = (Scheme_Object *)cert;
     } else {
       Scheme_Object *pr;
       pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)cert);
       res->certs = pr;
+      if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs))
+        SCHEME_SET_IMMUTABLE(pr);
     }
     
     o = (Scheme_Object *)res;
@@ -2871,28 +2887,38 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp)
     Scheme_Stx *stx = (Scheme_Stx *)o;
 
     if (INACTIVE_CERTS(stx)) {
-      /* Change inactive certs to active certs. (No
+      /* Change inactive certs to active certs. */
-	 sub-object has inactive certs, because they
+      Scheme_Object *np, *v;
-	 are always lifted when inactive certs are added.) */
-      Scheme_Object *np;
       Scheme_Stx *res;
       Scheme_Cert *certs;
 
-      res = (Scheme_Stx *)scheme_make_stx(stx->val, 
+      if (SCHEME_IMMUTABLEP(stx->certs)) {
+        /* No sub-object has other inactive certs */
+        v = stx->val;
+      } else {
+        v = stx_activate_certs(stx->val, cp);
+      }
+
+      res = (Scheme_Stx *)scheme_make_stx(v, 
 					  stx->srcloc,
 					  stx->props);
       res->wraps = stx->wraps;
       res->u.lazy_prefix = stx->u.lazy_prefix;
-      np = scheme_make_raw_pair(SCHEME_CAR(stx->certs), NULL);
+      if (!ACTIVE_CERTS(stx))
+        np = no_nested_inactive_certs;
+      else {
+        np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL);
+        SCHEME_SET_IMMUTABLE(np);
+      }
       res->certs = np;
 
       certs = append_certs(INACTIVE_CERTS(stx), *cp);
       *cp = certs;
 
       return (Scheme_Object *)res;
-    } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
+    } else if (stx->certs && SCHEME_RPAIRP(stx->certs) 
-      /* Explicit pair but NULL for inactive certs means no
+               && SCHEME_IMMUTABLEP(stx->certs)) {
-	 inactive certs anywhere in this object. */
+      /* Explicit pair, but no inactive certs anywhere in this object. */
       return (Scheme_Object *)stx;
     } else {
       o = stx_activate_certs(stx->val, cp);
@@ -2904,14 +2930,11 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp)
 					    stx->props);
 	res->wraps = stx->wraps;
 	res->u.lazy_prefix = stx->u.lazy_prefix;
-	/* stx->certs must not be a pair, otherwise we
+	if (ACTIVE_CERTS(stx)) {
-	   would have taken an earlier branch; allocate
-	   a pair with an explicitl NULL now to inidicate 
-	   that there are no nested certs here */
-	if (stx->certs) {
 	  Scheme_Object *np;
-	  np = scheme_make_raw_pair(stx->certs, NULL);
+	  np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL);
 	  res->certs = np;
+          SCHEME_SET_IMMUTABLE(np);
 	} else
 	  res->certs = no_nested_inactive_certs;
 
@@ -2922,6 +2945,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp)
 	  Scheme_Object *np;
 	  np = scheme_make_raw_pair(stx->certs, NULL);
 	  stx->certs = np;
+          SCHEME_SET_IMMUTABLE(np);
 	} else
 	  stx->certs = no_nested_inactive_certs;
         
@@ -2937,6 +2961,8 @@ static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active)
   Scheme_Cert *certs = NULL;
 
   o = stx_activate_certs(o, &certs);
+  /* the inactive certs collected into `certs'
+     have been stripped from `o' at this point */
 
   if (certs)
     o = add_certs(o, certs, NULL, as_active);
@@ -6925,10 +6951,8 @@ static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv)
     ((Scheme_Stx *)src)->props = properties;
   }
 
-  if (certs) {
+  if (certs)
-    src = lift_inactive_certs(src, 0);
     src = add_certs(src, (Scheme_Cert *)certs, NULL, 0);    
-  }
 
   return src;
 }

src/mzscheme/src/syntax.c

@@ -5184,6 +5184,10 @@ quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_In
 
   /* Push all certificates in the environment down to the syntax object. */
   stx = scheme_stx_add_inactive_certs(stx, rec[drec].certs);
+  if (env->genv->module) {
+    /* Also certify access to the enclosing module: */
+    stx = scheme_stx_cert(stx, scheme_false, env->genv, NULL, NULL, 0);
+  }
   
   if (rec[drec].comp) {
     return scheme_register_stx_in_prefix(stx, env, rec, drec);

src/worksp/mred/mred.manifest

@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8" standalone="yes"?> 
 <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> 
 <assemblyIdentity 
-version="4.1.3.3" 
+version="4.1.3.4" 
 processorArchitecture="X86" 
 name="Org.PLT-Scheme.MrEd" 
 type="win32" 

src/worksp/mred/mred.rc

@@ -20,8 +20,8 @@ APPLICATION             ICON    DISCARDABLE     "mred.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,3,3
+ FILEVERSION 4,1,3,4
- PRODUCTVERSION 4,1,3,3
+ PRODUCTVERSION 4,1,3,4
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -39,11 +39,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "PLT Scheme GUI application\0"
             VALUE "InternalName", "MrEd\0"
-            VALUE "FileVersion", "4, 1, 3, 3\0"
+            VALUE "FileVersion", "4, 1, 3, 4\0"
             VALUE "LegalCopyright", "Copyright © 1995-2008\0"
             VALUE "OriginalFilename", "MrEd.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 3, 3\0"
+            VALUE "ProductVersion", "4, 1, 3, 4\0"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/mzcom/mzcom.rc

@@ -53,8 +53,8 @@ END
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,3,3
+ FILEVERSION 4,1,3,4
- PRODUCTVERSION 4,1,3,3
+ PRODUCTVERSION 4,1,3,4
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -70,12 +70,12 @@ BEGIN
         BLOCK "040904b0"
         BEGIN
             VALUE "FileDescription", "MzCOM Module"
-            VALUE "FileVersion", "4, 1, 3, 3"
+            VALUE "FileVersion", "4, 1, 3, 4"
             VALUE "InternalName", "MzCOM"
             VALUE "LegalCopyright", "Copyright 2000-2008 PLT (Paul Steckler)"
             VALUE "OriginalFilename", "MzCOM.EXE"
             VALUE "ProductName", "MzCOM Module"
-            VALUE "ProductVersion", "4, 1, 3, 3"
+            VALUE "ProductVersion", "4, 1, 3, 4"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/mzcom/mzobj.rgs

@@ -1,19 +1,19 @@
 HKCR
 {
-	MzCOM.MzObj.4.1.3.3 = s 'MzObj Class'
+	MzCOM.MzObj.4.1.3.4 = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
 	}
 	MzCOM.MzObj = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
-		CurVer = s 'MzCOM.MzObj.4.1.3.3'
+		CurVer = s 'MzCOM.MzObj.4.1.3.4'
 	}
 	NoRemove CLSID
 	{
 		ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
 		{
-			ProgID = s 'MzCOM.MzObj.4.1.3.3'
+			ProgID = s 'MzCOM.MzObj.4.1.3.4'
 			VersionIndependentProgID = s 'MzCOM.MzObj'
 			ForceRemove 'Programmable'
 			LocalServer32 = s '%MODULE%'

src/worksp/mzscheme/mzscheme.rc

@@ -29,8 +29,8 @@ APPLICATION             ICON    DISCARDABLE     "mzscheme.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,3,3
+ FILEVERSION 4,1,3,4
- PRODUCTVERSION 4,1,3,3
+ PRODUCTVERSION 4,1,3,4
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -48,11 +48,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "PLT Scheme application\0"
             VALUE "InternalName", "MzScheme\0"
-            VALUE "FileVersion", "4, 1, 3, 3\0"
+            VALUE "FileVersion", "4, 1, 3, 4\0"
             VALUE "LegalCopyright", "Copyright <20>© 1995-2008\0"
             VALUE "OriginalFilename", "mzscheme.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 3, 3\0"
+            VALUE "ProductVersion", "4, 1, 3, 4\0"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/starters/start.rc

@@ -22,8 +22,8 @@ APPLICATION             ICON    DISCARDABLE     "mzstart.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,3,3
+ FILEVERSION 4,1,3,4
- PRODUCTVERSION 4,1,3,3
+ PRODUCTVERSION 4,1,3,4
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -45,7 +45,7 @@ BEGIN
 #ifdef MZSTART
             VALUE "FileDescription", "PLT Scheme Launcher\0"
 #endif
-            VALUE "FileVersion", "4, 1, 3, 3\0"
+            VALUE "FileVersion", "4, 1, 3, 4\0"
 #ifdef MRSTART
             VALUE "InternalName", "mrstart\0"
 #endif
@@ -60,7 +60,7 @@ BEGIN
             VALUE "OriginalFilename", "MzStart.exe\0"
 #endif
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 3, 3\0"
+            VALUE "ProductVersion", "4, 1, 3, 4\0"
         END
     END
     BLOCK "VarFileInfo"