Sync

svn: r12845

collects/compiler/decompile.ss

@@ -57,7 +57,8 @@
        (values (append 
                 (map (lambda (tl)
                        (match tl
-                         [(? symbol?) '#%linkage]
+                         [#f '#%linkage]
+                         [(? symbol?) (string->symbol (format "_~a" tl))]
                          [(struct global-bucket (name)) 
                           (string->symbol (format "_~a" name))]
                          [(struct module-variable (modidx sym pos phase))

collects/compiler/zo-parse.ss

@@ -85,15 +85,10 @@
 (define (read-variable v)
   (if (symbol? v)
       (make-global-bucket v)
-      (let-values ([(phase modname varname)
+      (error "expected a symbol")))
-                    (match v
+
-                      [(list* phase modname varname)
+(define (do-not-read-variable v)
-                       (values phase modname varname)]
+  (error "should not get here"))
-                      [(list* modname varname)
-                       (values 0 modname varname)])])
-        (if (and (zero? phase) (eq? modname '#%kernel))
-            (error 'bucket "var ~a" varname)
-            (make-module-variable modname varname -1 phase)))))
 
 (define (read-compilation-top v)
   (match v
@@ -198,6 +193,7 @@
              ,rename ,max-let-depth ,dummy
              ,prefix ,kernel-exclusion ,reprovide-kernel?
              ,indirect-provides ,num-indirect-provides 
+             ,indirect-syntax-provides ,num-indirect-syntax-provides 
              ,indirect-et-provides ,num-indirect-et-provides 
              ,protects ,et-protects
              ,provide-phase-count . ,rest)
@@ -282,7 +278,7 @@
     (cons 'with-cont-mark-type read-with-cont-mark)
     (cons 'quote-syntax-type read-topsyntax)
     (cons 'variable-type read-variable)
-    (cons 'module-variable-type read-variable)
+    (cons 'module-variable-type do-not-read-variable)
     (cons 'compilation-top-type read-compilation-top)
     (cons 'case-lambda-sequence-type read-case-lambda)
     (cons 'begin0-sequence-type read-sequence)
@@ -719,7 +715,11 @@
            (let ([mod (read-compact cp)]
                  [var (read-compact cp)]
                  [pos (read-compact-number cp)])
-             (make-module-variable mod var pos 0))]
+             (let-values ([(mod-phase pos)
+                           (if (= pos -2)
+                                  (values 1 (read-compact-number cp))
+                                  (values 0 pos))])
+               (make-module-variable mod var pos mod-phase)))]
           [(local-unbox)
            (let* ([p* (read-compact-number cp)]
                   [p (if (< p* 0)

collects/games/cards/cards.scrbl

@@ -198,7 +198,8 @@ Removes @scheme[card] from the table.}
 @defmethod[(move-cards [cards (listof (is-a?/c card<%>))]
                        [x real?]
                        [y real?]
-                       [offset-proc (exact-nonnegative-integer? . -> . (values real? real?))
+                       [offset-proc (exact-nonnegative-integer? 
+                                     . -> . (values real? real?))
                                     (lambda (i) (values 0 0))])
             void?]{
 

collects/handin-server/checker.ss

@@ -653,7 +653,7 @@
   (and (procedure? proc) (procedure-arity-includes? proc arity)))
 
 (define (get-namespace evaluator)
-  (call-in-sandbox-context evaluator (lambda () (current-namespace))))
+  (call-in-sandbox-context evaluator current-namespace))
 
 ;; checks that ids are defined, either as variables or syntaxes
 (provide !defined)

collects/handin-server/sandbox.ss

@@ -8,6 +8,7 @@
 (sandbox-error-output #f)
 
 ;; no limits -- the handin server uses per-session limits
+(sandbox-memory-limit #f)
 (sandbox-eval-limits #f)
 
 ;; share these with evaluators

collects/macro-debugger/model/deriv-find.ss

@@ -2,12 +2,14 @@
 #lang scheme/base
 (require scheme/match
          scheme/list
+         syntax/stx
          "deriv-c.ss"
          "deriv-util.ss")
 (provide find-derivs
          find-deriv
          find-derivs/syntax
          extract-all-fresh-names
+         compute-shift-table
          flatten-identifiers)
 
 ;; Utilities for finding subderivations
@@ -126,8 +128,12 @@
                (lambda _ #f)
                d))
 
-;; extract-all-fresh-names : Derivation -> syntaxlike
+;; extract-all-fresh-names : Derivation -> (listof identifier)
 (define (extract-all-fresh-names d)
+  (define ht (make-hasheq))
+  (define (add stxish)
+    (for-each (lambda (id) (hash-set! ht id #t))
+              (flatten-identifiers stxish)))
   (define (renaming-node? x)
     (or (p:lambda? x)
         ;;(p:case-lambda? x)
@@ -142,69 +148,83 @@
   (define (extract-fresh-names d)
     (match d
       [(Wrap p:lambda (e1 e2 rs ?1 renames body))
-       (if renames
+       (when renames
          (with-syntax ([(?formals . ?body) renames])
-             #'?formals)
+           (add #'?formals)))]
-           null)]
       [(Wrap clc (_ renames _))
-       (if renames
+       (when renames
          (with-syntax ([(?formals . ?body) renames])
-             #'?formals)
+           (add #'?formals)))]
-           null)]
       [(Wrap p:let-values (e1 e2 rs ?1 renames rhss body))
-       (if renames
+       (when renames
          (with-syntax ([(((?vars ?rhs) ...) . ?body) renames])
-             #'(?vars ...))
+           (add #'(?vars ...))))]
-           null)]
       [(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body))
-       (if renames
+       (when renames
          (with-syntax ([(((?vars ?rhs) ...) . ?body) renames])
-             #'(?vars ...))
+           (add #'(?vars ...))))]
-           null)]
+      [(Wrap p:letrec-syntaxes+values (e1 e2 rs ?1 srenames srhss vrenames _ _ _))
-      [(Wrap p:letrec-syntaxes+values (e1 e2 rs ?1 srenames srhss vrenames vrhss body _))
+       (when srenames
-       (cons
-        (if srenames
          (with-syntax ([(((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body)
                         srenames])
-              #'(?svars ... ?vvars ...))
+           (add #'(?svars ... ?vvars ...))))
-            null)
+       (when vrenames
-        (if vrenames
          (with-syntax ([(((?vvars ?vrhs) ...) . ?body) vrenames])
-              #'(?vvars ...))
+           (add #'(?vvars ...))))]
-            null))]
       [(Wrap b:defvals (rename head ?1 rename2 ?2))
        (let ([head-e2 (wderiv-e2 head)])
-         (if head-e2
+         (when head-e2
            (with-syntax ([(?dv ?vars ?rhs) head-e2])
-               #'?vars)
+             (add #'?vars))))]
-             null))]
       [(Wrap b:defstx (rename head ?1 rename2 ?2 rhs))
        (let ([head-e2 (wderiv-e2 head)])
-         (if head-e2
+         (when head-e2
            (with-syntax ([(?ds ?svars ?rhs) head-e2])
-               #'?svars)
+             (add #'?svars))))]
-             null))]
       [(Wrap p:define-values (e1 e2 rs ?1 rhs))
-       (if rhs
+       (when rhs
          (with-syntax ([(?dv ?vars ?rhs) e1])
-             #'?vars)
+           (add #'?vars)))]
-           null)]
       [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs _))
-       (if rhs
+       (when rhs
          (with-syntax ([(?ds ?svars ?srhs) e1])
-             #'?svars)
+           (add #'?svars)))]
-           null)]
+      [_ (void)]))
-      [_ null]))
+  (define renaming-forms
-
+    (find-deriv/unit+join+zero renaming-node?
-  (let ([all-renaming-forms
-         (find-deriv/unit+join+zero
-          renaming-node?
                                (lambda (d) #f)
                                d
                                list
                                append
-          null)])
+                               null))
-    (flatten-identifiers (map extract-fresh-names all-renaming-forms))))
+  (for ([rf renaming-forms])
+    (extract-fresh-names rf))
+  (hash-map ht (lambda (k v) k)))
+
+;; compute-shift-table : deriv -> hash[id => (listof id)]
+(define (compute-shift-table d)
+  (define ht (make-hasheq))
+  (define module-forms
+    (find-derivs p:module? (lambda _ #f) d))
+  (define module-shift-renamers
+    (for/list ([mf module-forms])
+      (let ([shift (p:module-shift mf)]
+            [body (p:module-body mf)])
+        (and shift body
+             (with-syntax ([(_module _name _lang shifted-body) shift])
+               (add-rename-mapping ht (wderiv-e2 body) #'shifted-body))))))
+  ht)
+
+(define (add-rename-mapping ht from to)
+  (define (loop from to)
+    (cond [(and (stx-pair? from) (stx-pair? to))
+           (loop (stx-car from) (stx-car to))
+           (loop (stx-cdr from) (stx-cdr to))]
+          [(and (identifier? from) (identifier? to))
+           (hash-set! ht from (cons to (hash-ref ht from null)))]
+          [else (void)]))
+  (loop from to)
+  (void))
 
 ;; flatten-identifiers : syntaxlike -> (list-of identifier)
 (define (flatten-identifiers stx)

collects/macro-debugger/syntax-browser/display.ss

@@ -79,18 +79,28 @@
     ;; highlight-syntaxes : (list-of syntax) string -> void
     (define/public (highlight-syntaxes stxs hi-color)
       (let ([style-delta (highlight-style-delta hi-color #f)])
-        (for-each (lambda (stx) (hash-set! extra-styles stx style-delta))
+        (for ([stx stxs])
-                  stxs))
+          (add-extra-styles stx (list style-delta))))
       (refresh))
 
+    ;; underline-syntaxes : (listof syntax) -> void
+    (define/public (underline-syntaxes stxs)
+      (for ([stx stxs])
+        (add-extra-styles stx (list underline-style-delta)))
+      (refresh))
+
+    (define/public (add-extra-styles stx styles)
+      (hash-set! extra-styles stx
+                 (append (hash-ref extra-styles stx null)
+                         styles)))
+
     ;; apply-extra-styles : -> void
     ;; Applies externally-added styles (such as highlighting)
     (define/private (apply-extra-styles)
-      (hash-for-each
+      (for ([(stx style-deltas) extra-styles])
-       extra-styles
+        (for ([r (send range get-ranges stx)])
-       (lambda (hi-stx style-delta)
+          (for ([style-delta style-deltas])
-         (let ([rs (send range get-ranges hi-stx)])
+            (restyle-range r style-delta)))))
-           (for-each (lambda (r) (restyle-range r style-delta)) rs)))))
 
     ;; apply-secondary-partition-styles : selected-syntax -> void
     ;; If the selected syntax is an identifier, then styles all identifiers
@@ -243,6 +253,11 @@
       (send sd set-weight-off 'bold))
     sd))
 
+(define underline-style-delta
+  (let ([sd (new style-delta%)])
+    (send sd set-underlined-on #t)
+    sd))
+
 (define selection-color "yellow")
 (define subselection-color "yellow")
 

collects/macro-debugger/syntax-browser/prefs.ss

@@ -5,7 +5,8 @@
          "interfaces.ss"
          "../util/notify.ss"
          "../util/misc.ss")
-(provide syntax-prefs-base%
+(provide prefs-base%
+         syntax-prefs-base%
          syntax-prefs%
          syntax-prefs/readonly%)
 
@@ -19,7 +20,7 @@
 (pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
 (pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
 
-(define syntax-prefs-base%
+(define prefs-base%
   (class object%
     ;; columns : number
     (field/notify columns (new notify-box% (value 60)))
@@ -41,6 +42,10 @@
                     "indigo" "purple" 
                     "orange" "salmon" "darkgoldenrod" "olive"))))
 
+    (super-new)))
+
+(define syntax-prefs-base%
+  (class prefs-base%
     ;; width, height : number
     (notify-methods width)
     (notify-methods height)

collects/macro-debugger/syntax-browser/syntax-snip.ss

@@ -1,11 +1,11 @@
 
-(module syntax-snip mzscheme
+#lang scheme/base
-  (require mzlib/class
+(require scheme/class
+         scheme/match
+         scheme/list
+         mzlib/string
          mred
          framework
-           mzlib/match
-           mzlib/list
-           mzlib/string
          "../util/notify.ss"
          "interfaces.ss"
          "display.ss"
@@ -15,37 +15,26 @@
          "partition.ss"
          "prefs.ss")
 
-  (provide syntax-snip%
+(provide syntax-snip%
          syntax-value-snip%)
 
-  (define syntax-snip-config-base%
+(define syntax-snip-config-base%
-    (class object%
+  (class prefs-base%
     (notify-methods props-shown?)
     (super-new)))
-  (define syntax-snip-config%
+
+(define syntax-snip-config%
   (class syntax-snip-config-base%
     (define/override (init-props-shown?) (new notify-box% (value #f)))
     (super-new)))
 
-  (define dumb-host%
+;; syntax-value-snip%
-    (class object%
+(define syntax-value-snip%
-      (define controller (new controller%))
-      (define config (new syntax-snip-config%))
-      (super-new)
-      (define/public (get-controller) controller)
-      (define/public (get-config) config)
-      (define/public (add-keymap text snip)
-        (send text set-keymap
-              (new syntax-keymap%
-                   (controller controller)
-                   (editor text)
-                   (config config))))))
-
-  ;; syntax-value-snip%
-  (define syntax-value-snip%
   (class* editor-snip% (readable-snip<%>)
     (init-field ((stx syntax)))
-      (init-field (host (new dumb-host%)))
+    (init-field (controller (new controller%)))
+    (init-field (config (new syntax-snip-config%)))
+
     (inherit set-margin
              set-inset)
 
@@ -60,18 +49,25 @@
     (send text begin-edit-sequence)
     (send text change-style (make-object style-delta% 'change-alignment 'top))
     (define display
-        (print-syntax-to-editor stx text
+      (print-syntax-to-editor stx text controller config))
-                                (send host get-controller)
-                                (send host get-config)))
     (send text lock #t)
     (send text end-edit-sequence)
     (send text hide-caret #t)
 
-      (send host add-keymap text this)
+    (setup-keymap text)
+
+    (define/public (setup-keymap text)
+      (new syntax-keymap%
+           (controller controller)
+           (config config)
+           (editor text)))
 
     ;; snip% Methods
     (define/override (copy)
-        (new syntax-value-snip% (host host) (syntax stx)))
+      (new syntax-value-snip%
+           (config config)
+           (controller controller)
+           (syntax stx)))
 
     ;; read-special : any number/#f number/#f number/#f -> syntax
     ;; Produces 3D syntax to preserve eq-ness of syntax
@@ -81,13 +77,13 @@
         #'(p)))
     ))
 
-  (define top-aligned
+(define top-aligned
   (make-object style-delta% 'change-alignment 'top))
 
-  (define-struct styled (contents style clickback))
+(define-struct styled (contents style clickback))
 
-  ;; clicky-snip%
+;; clicky-snip%
-  (define clicky-snip%
+(define clicky-snip%
   (class* editor-snip% ()
 
     (init-field [open-style '(border)]
@@ -163,19 +159,21 @@
     (refresh-contents)
     ))
 
-  ;; syntax-snip%
+;; syntax-snip%
-  (define syntax-snip%
+(define syntax-snip%
   (class* clicky-snip% (readable-snip<%>)
     (init-field ((stx syntax)))
-      (init-field (host (new dumb-host%)))
+    (init-field [controller (new controller%)])
-      (define config (send host get-config))
+    (init-field [config (new syntax-snip-config%)])
+
     (inherit set-snipclass
              refresh-contents)
 
     (define the-syntax-snip
       (new syntax-value-snip%
            (syntax stx)
-             (host host)))
+           (controller controller)
+           (config config)))
     (define the-summary
       (let* ([t (new text%)]
              [es (new editor-snip% (editor t) (with-border? #f))])
@@ -186,7 +184,7 @@
 
     (define properties-snip
       (new properties-container-snip%
-             (controller (send host get-controller))))
+           (controller controller)))
 
     (define/override (closed-contents)
       (list the-summary))
@@ -211,10 +209,10 @@
           (lambda (?) (refresh-contents)))
 
     (super-new)
-      (set-snipclass snip-class)))
+    (set-snipclass snip-class)
+    ))
 
-
+(define properties-container-snip%
-  (define properties-container-snip%
   (class clicky-snip%
     (init controller)
 
@@ -231,34 +229,34 @@
     (super-new (open-style '())
                (closed-style '()))))
 
-  (define style:normal (make-object style-delta% 'change-normal))
+(define style:normal (make-object style-delta% 'change-normal))
-  (define style:hyper
+(define style:hyper
   (let ([s (make-object style-delta% 'change-normal)])
     (send s set-delta 'change-toggle-underline)
     (send s set-delta-foreground "blue")
     s))
-  (define style:green
+(define style:green
   (let ([s (make-object style-delta% 'change-normal)])
     (send s set-delta-foreground "darkgreen")
     s))
-  (define style:bold
+(define style:bold
   (let ([s (make-object style-delta% 'change-normal)])
     (send s set-delta 'change-bold)
     s))
 
-  (define (show-icon)
+(define (show-icon)
   (make-object image-snip%
     (build-path (collection-path "icons") "turn-up.png")))
-  (define (hide-icon)
+(define (hide-icon)
   (make-object image-snip%
     (build-path (collection-path "icons") "turn-down.png")))
 
-  (define (show-properties-icon)
+(define (show-properties-icon)
   (make-object image-snip%
     (build-path (collection-path "icons") "syncheck.png")))
 
-  ;; marshall-syntax : syntax -> printable
+;; marshall-syntax : syntax -> printable
-  (define (marshall-syntax stx)
+(define (marshall-syntax stx)
   (unless (syntax? stx)
     (error 'marshall-syntax "not syntax: ~s\n" stx))
   `(syntax
@@ -275,9 +273,9 @@
     (contents
      ,(marshall-object (syntax-e stx)))))
 
-  ;; marshall-object : any -> printable
+;; marshall-object : any -> printable
-  ;; really only intended for use with marshall-syntax
+;; really only intended for use with marshall-syntax
-  (define (marshall-object obj)
+(define (marshall-object obj)
   (cond
     [(syntax? obj) (marshall-syntax obj)]
     [(pair? obj) 
@@ -292,21 +290,21 @@
      `(other ,obj)]
     [else (string->symbol (format "unknown-object: ~s" obj))]))
 
-  ;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
+;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
-  (define syntax-snipclass%
+(define syntax-snipclass%
   (class snip-class%
     (define/override (read stream)
       (make-object syntax-snip%
         (unmarshall-syntax (read-from-string (send stream get-bytes)))))
     (super-instantiate ())))
 
-  (define snip-class (make-object syntax-snipclass%))
+(define snip-class (make-object syntax-snipclass%))
-  (send snip-class set-version 2)
+(send snip-class set-version 2)
-  (send snip-class set-classname
+(send snip-class set-classname
       (format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser")))
-  (send (get-the-snip-class-list) add snip-class)
+(send (get-the-snip-class-list) add snip-class)
 
-  (define (unmarshall-syntax stx)
+(define (unmarshall-syntax stx)
   (match stx
     [`(syntax
        (source ,src)
@@ -316,11 +314,11 @@
        (column ,col)
        (span ,span)
        (original? ,original?)
-         (properties ,@(properties ...))
+       (properties . ,properties)
        (contents ,contents))
       (foldl
        add-properties
-         (datum->syntax-object
+       (datum->syntax
         #'here ;; ack
         (unmarshall-object contents)
         (list (unmarshall-object src)
@@ -331,15 +329,15 @@
        properties)]
     [else #'unknown-syntax-object]))
 
-  ;; add-properties : syntax any -> syntax
+;; add-properties : syntax any -> syntax
-  (define (add-properties prop-spec stx)
+(define (add-properties prop-spec stx)
   (match prop-spec
     [`(,(and sym (? symbol?))
         ,prop)
       (syntax-property stx sym (unmarshall-object prop))]
     [else stx]))
 
-  (define (unmarshall-object obj)
+(define (unmarshall-object obj)
   (let ([unknown (lambda () (string->symbol (format "unknown: ~s" obj)))])
     (if (and (pair? obj)
              (symbol? (car obj)))
@@ -359,5 +357,3 @@
           [(syntax) (unmarshall-syntax obj)]
           [else (unknown)])
         (unknown))))
-
-  )

collects/macro-debugger/syntax-browser/widget.ss

@@ -1,11 +1,10 @@
 
-#lang mzscheme
+#lang scheme/base
 (require scheme/class
          mred
          framework/framework
          scheme/list
          scheme/match
-         mzlib/kw
          syntax/boundmap
          "interfaces.ss"
          "controller.ss"
@@ -14,7 +13,8 @@
          "hrule-snip.ss"
          "properties.ss"
          "text.ss"
-         "util.ss")
+         "util.ss"
+         "../util/mpi.ss")
 (provide widget%)
 
 ;; widget%
@@ -104,63 +104,73 @@
             (send -text set-clickback a b handler)
             (send -text change-style clickback-style a b)))))
 
-    (define/public add-syntax
+    (define/public (add-syntax stx
-      (lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]
+                               #:binder-table [alpha-table #f]
-                      hi2-color [hi2-stxs null])
+                               #:shift-table [shift-table #f]
-        (define (get-binder id)
+                               #:definites [definites null]
+                               #:hi-colors [hi-colors null]
+                               #:hi-stxss [hi-stxss null])
+      (define (get-binders id)
+        (define binder
           (module-identifier-mapping-get alpha-table id (lambda () #f)))
-        (when (and (pair? hi-stxs) (not hi-color))
+        (if shift-table
-          (error 'syntax-widget%::add-syntax "no highlight color specified"))
+            (cons binder (hash-ref shift-table binder null))
+            (list binder)))
       (let ([display (internal-add-syntax stx)]
-              [definite-table (make-hash-table)])
+            [definite-table (make-hasheq)])
-          (when (and hi2-color (pair? hi2-stxs))
+        (for-each (lambda (hi-stxs hi-color)
-            (send display highlight-syntaxes hi2-stxs hi2-color))
-          (when (and hi-color (pair? hi-stxs))
                     (send display highlight-syntaxes hi-stxs hi-color))
-          (for-each (lambda (x) (hash-table-put! definite-table x #t)) definites)
+                  hi-stxss
+                  hi-colors)
+        (for ([definite definites])
+          (hash-set! definite-table definite #t)
+          (when shift-table
+            (for ([shifted-definite (hash-ref shift-table definite null)])
+              (hash-set! definite-table shifted-definite #t))))
         (when alpha-table
           (let ([range (send display get-range)]
                 [start (send display get-start-position)])
-              (define (adjust n) (+ start n))
+            (let* ([binders0
-              (for-each
+                    (module-identifier-mapping-map alpha-table (lambda (k v) k))]
-               (lambda (id)
+                   [binders
-                 #; ;; DISABLED
+                    (apply append (map get-binders binders0))])
-                 (match (identifier-binding id)
+              (send display underline-syntaxes binders))
-                   [(list src-mod src-name nom-mod nom-name _)
+            (for ([id (send range get-identifier-list)])
-                    (for-each (lambda (id-r)
+              (define definite? (hash-ref definite-table id #f))
-                                (send -text add-billboard
+              (when #f ;; DISABLED
-                                      (adjust (car id-r))
+                (add-binding-billboard start range id definite?))
-                                      (adjust (cdr id-r))
+              (for ([binder (get-binders id)])
-                                      (string-append "from "
+                (for ([binder-r (send range get-ranges binder)])
-                                                     (mpi->string src-mod))
+                  (for ([id-r (send range get-ranges id)])
-                                      (if (hash-table-get definite-table id #f)
+                    (add-binding-arrow start binder-r id-r definite?)))))))
-                                          "blue"
+        display))
-                                          "purple")))
-                              (send range get-ranges id))]
-                   [_ (void)])
 
-                 (let ([binder (get-binder id)])
+    (define/private (add-binding-arrow start binder-r id-r definite?)
-                   (when binder
+      (if definite?
-                     (for-each
-                      (lambda (binder-r)
-                        (for-each (lambda (id-r)
-                                    (if (hash-table-get definite-table id #f)
           (send -text add-arrow
-                                              (adjust (car binder-r))
+                (+ start (car binder-r))
-                                              (adjust (cdr binder-r))
+                (+ start (cdr binder-r))
-                                              (adjust (car id-r))
+                (+ start (car id-r))
-                                              (adjust (cdr id-r))
+                (+ start (cdr id-r))
                 "blue")
           (send -text add-question-arrow
-                                              (adjust (car binder-r))
+                (+ start (car binder-r))
-                                              (adjust (cdr binder-r))
+                (+ start (cdr binder-r))
-                                              (adjust (car id-r))
+                (+ start (car id-r))
-                                              (adjust (cdr id-r))
+                (+ start (cdr id-r))
                 "purple")))
-                                  (send range get-ranges id)))
+
-                      (send range get-ranges binder)))))
+    (define/private (add-binding-billboard start range id definite?)
-               (send range get-identifier-list))))
+      (match (identifier-binding id)
-          display)))
+        [(list-rest src-mod src-name nom-mod nom-name _)
+         (for-each (lambda (id-r)
+                     (send -text add-billboard
+                           (+ start (car id-r))
+                           (+ start (cdr id-r))
+                           (string-append "from " (mpi->string src-mod))
+                           (if definite? "blue" "purple")))
+                   (send range get-ranges id))]
+        [_ (void)]))
 
     (define/public (add-separator)
       (with-unlock -text

collects/macro-debugger/view/step-display.ss

@@ -0,0 +1,261 @@
+
+#lang scheme/base
+(require scheme/class
+         scheme/unit
+         scheme/list
+         scheme/match
+         scheme/gui
+         framework/framework
+         syntax/boundmap
+         "interfaces.ss"
+         "prefs.ss"
+         "extensions.ss"
+         "warning.ss"
+         "hiding-panel.ss"
+         "../model/deriv.ss"
+         "../model/deriv-util.ss"
+         "../model/deriv-find.ss"
+         "../model/deriv-parser.ss"
+         "../model/trace.ss"
+         "../model/reductions-config.ss"
+         "../model/reductions.ss"
+         "../model/steps.ss"
+         "../util/notify.ss"
+         "cursor.ss"
+         "debug-format.ss")
+#;
+(provide step-display%
+         step-display<%>)
+(provide (all-defined-out))
+;; Struct for one-by-one stepping
+
+(define-struct (prestep protostep) ())
+(define-struct (poststep protostep) ())
+
+(define (prestep-term1 s) (state-term (protostep-s1 s)))
+(define (poststep-term2 s) (state-term (protostep-s1 s)))
+
+
+(define step-display<%>
+  (interface ()
+    ;; add-syntax
+    add-syntax
+
+    ;; add-step
+    add-step
+
+    ;; add-error
+    add-error
+
+    ;; add-final
+    add-final
+
+    ;; add-internal-error
+    add-internal-error))
+
+(define step-display%
+  (class* object% (step-display<%>)
+
+    (init-field config)
+    (init-field ((sbview syntax-widget)))
+    (super-new)
+
+    (define/public (add-internal-error part exn stx events)
+      (send sbview add-text
+            (if part
+                (format "Macro stepper error (~a)" part)
+                "Macro stepper error"))
+      (when (exn? exn)
+        (send sbview add-text " ")
+        (send sbview add-clickback "[details]"
+              (lambda _ (show-internal-error-details exn events))))
+      (send sbview add-text ".  ")
+      (when stx (send sbview add-text "Original syntax:"))
+      (send sbview add-text "\n")
+      (when stx (send sbview add-syntax stx)))
+
+    (define/private (show-internal-error-details exn events)
+      (case (message-box/custom "Macro stepper internal error"
+                                (format "Internal error:\n~a" (exn-message exn))
+                                "Show error"
+                                "Dump debugging file"
+                                "Cancel")
+        ((1) (queue-callback
+              (lambda ()
+                (raise exn))))
+        ((2) (queue-callback
+              (lambda ()
+                (let ([file (put-file)])
+                  (when file
+                    (write-debug-file file exn events))))))
+        ((3 #f) (void))))
+
+    (define/public (add-error exn)
+      (send sbview add-error-text (exn-message exn))
+      (send sbview add-text "\n"))
+
+    (define/public (add-step step
+                             #:binders binders
+                             #:shift-table [shift-table #f])
+      (cond [(step? step)
+             (show-step step binders shift-table)]
+            [(misstep? step)
+             (show-misstep step binders shift-table)]
+            [(prestep? step)
+             (show-prestep step binders shift-table)]
+            [(poststep? step)
+             (show-poststep step binders shift-table)]))
+
+    (define/public (add-syntax stx
+                               #:binders binders
+                               #:shift-table [shift-table #f]
+                               #:definites definites)
+      (send sbview add-syntax stx
+            #:binder-table binders
+            #:shift-table shift-table
+            #:definites (or definites null)))
+
+    (define/public (add-final stx error
+                              #:binders binders
+                              #:shift-table [shift-table #f]
+                              #:definites definites)
+      (when stx
+        (send sbview add-text "Expansion finished\n")
+        (send sbview add-syntax stx
+              #:binder-table binders
+              #:shift-table shift-table
+              #:definites (or definites null)))
+      (when error
+        (add-error error)))
+
+    ;; show-lctx : Step -> void
+    (define/private (show-lctx step binders shift-table)
+      (define state (protostep-s1 step))
+      (define lctx (state-lctx state))
+      (when (pair? lctx)
+        (send sbview add-text "\n")
+        (for-each (lambda (bf)
+                    (send sbview add-text 
+                          "while executing macro transformer in:\n")
+                    (insert-syntax/redex (bigframe-term bf)
+                                         (bigframe-foci bf)
+                                         binders
+                                         shift-table
+                                         (state-uses state)
+                                         (state-frontier state)))
+                  (reverse lctx))))
+
+    ;; separator : Step -> void
+    (define/private (separator step)
+      (insert-step-separator (step-type->string (protostep-type step))))
+
+    ;; separator/small : Step -> void
+    (define/private (separator/small step)
+      (insert-step-separator/small
+       (step-type->string (protostep-type step))))
+    
+    ;; show-step : Step -> void
+    (define/private (show-step step binders shift-table)
+      (show-state/redex (protostep-s1 step) binders shift-table)
+      (separator step)
+      (show-state/contractum (step-s2 step) binders shift-table)
+      (show-lctx step binders shift-table))
+
+    (define/private (show-state/redex state binders shift-table)
+      (insert-syntax/redex (state-term state)
+                           (state-foci state)
+                           binders
+                           shift-table
+                           (state-uses state)
+                           (state-frontier state)))
+
+    (define/private (show-state/contractum state binders shift-table)
+      (insert-syntax/contractum (state-term state)
+                                (state-foci state)
+                                binders
+                                shift-table
+                                (state-uses state)
+                                (state-frontier state)))
+
+    ;; show-prestep : Step -> void
+    (define/private (show-prestep step binders shift-table)
+      (separator/small step)
+      (show-state/redex (protostep-s1 step) binders shift-table)
+      (show-lctx step binders shift-table))
+
+    ;; show-poststep : Step -> void
+    (define/private (show-poststep step binders shift-table)
+      (separator/small step)
+      (show-state/contractum (protostep-s1 step) binders shift-table)
+      (show-lctx step binders shift-table))
+
+    ;; show-misstep : Step -> void
+    (define/private (show-misstep step binders shift-table)
+      (define state (protostep-s1 step))
+      (show-state/redex state binders shift-table)
+      (separator step)
+      (send sbview add-error-text (exn-message (misstep-exn step)))
+      (send sbview add-text "\n")
+      (when (exn:fail:syntax? (misstep-exn step))
+        (for-each (lambda (e)
+                    (send sbview add-syntax e
+                          #:binder-table binders
+                          #:shift-table shift-table
+                          #:definites (or (state-uses state) null)))
+                  (exn:fail:syntax-exprs (misstep-exn step))))
+      (show-lctx step binders shift-table))
+
+    ;; insert-syntax/color
+    (define/private (insert-syntax/color stx foci binders shift-table
+                                         definites frontier hi-color)
+      (define highlight-foci? (send config get-highlight-foci?))
+      (define highlight-frontier? (send config get-highlight-frontier?))
+      (send sbview add-syntax stx
+            #:definites (or definites null)
+            #:binder-table binders
+            #:shift-table shift-table
+            #:hi-colors (list hi-color
+                              "WhiteSmoke")
+            #:hi-stxss (list (if highlight-foci? foci null)
+                             (if highlight-frontier? frontier null))))
+
+    ;; insert-syntax/redex
+    (define/private (insert-syntax/redex stx foci binders shift-table
+                                         definites frontier)
+      (insert-syntax/color stx foci binders shift-table
+                           definites frontier "MistyRose"))
+
+    ;; insert-syntax/contractum 
+    (define/private (insert-syntax/contractum stx foci binders shift-table
+                                              definites frontier)
+      (insert-syntax/color stx foci binders shift-table
+                           definites frontier "LightCyan"))
+
+    ;; insert-step-separator : string -> void
+    (define/private (insert-step-separator text)
+      (send sbview add-text "\n    ")
+      (send sbview add-text
+            (make-object image-snip% 
+                         (build-path (collection-path "icons")
+                                     "red-arrow.bmp")))
+      (send sbview add-text "  ")
+      (send sbview add-text text)
+      (send sbview add-text "\n\n"))
+
+    ;; insert-as-separator : string -> void
+    (define/private (insert-as-separator text)
+      (send sbview add-text "\n    ")
+      (send sbview add-text text)
+      (send sbview add-text "\n\n"))
+
+    ;; insert-step-separator/small : string -> void
+    (define/private (insert-step-separator/small text)
+      (send sbview add-text "    ")
+      (send sbview add-text
+            (make-object image-snip% 
+                         (build-path (collection-path "icons")
+                                     "red-arrow.bmp")))
+      (send sbview add-text "  ")
+      (send sbview add-text text)
+      (send sbview add-text "\n\n"))
+    ))

collects/macro-debugger/view/stepper.ss

@@ -13,6 +13,7 @@
          "warning.ss"
          "hiding-panel.ss"
          "term-record.ss"
+         "step-display.ss"
          "../model/deriv.ss"
          "../model/deriv-util.ss"
          "../model/deriv-find.ss"
@@ -95,6 +96,7 @@
     (define/public (get-config) config)
     (define/public (get-controller) sbc)
     (define/public (get-view) sbview)
+    (define/public (get-step-displayer) step-displayer)
     (define/public (get-warnings-area) warnings-area)
     (define/public (get-macro-hiding-prefs) macro-hiding-prefs)
 
@@ -127,6 +129,9 @@
     (define sbview (new stepper-syntax-widget% 
                         (parent area)
                         (macro-stepper this)))
+    (define step-displayer (new step-display%
+                                (config config)
+                                (syntax-widget sbview)))
     (define sbc (send sbview get-controller))
     (define control-pane
       (new vertical-panel% (parent area) (stretchable-height #f)))

collects/macro-debugger/view/term-record.ss

@@ -12,6 +12,7 @@
          "extensions.ss"
          "warning.ss"
          "hiding-panel.ss"
+         "step-display.ss"
          "../model/deriv.ss"
          "../model/deriv-util.ss"
          "../model/deriv-find.ss"
@@ -26,23 +27,18 @@
 
 (provide term-record%)
 
-;; Struct for one-by-one stepping
-
-(define-struct (prestep protostep) ())
-(define-struct (poststep protostep) ())
-
-(define (prestep-term1 s) (state-term (protostep-s1 s)))
-(define (poststep-term2 s) (state-term (protostep-s1 s)))
-
 ;; TermRecords
 
 (define term-record%
   (class object%
     (init-field stepper)
-    (init-field [events #f])
 
     (define config (send stepper get-config))
-    (define sbview (send stepper get-view))
+    (define displayer (send stepper get-step-displayer))
+
+    ;; Data
+    
+    (init-field [events #f])
 
     (init-field [raw-deriv #f])
     (define raw-deriv-oops #f)
@@ -50,15 +46,18 @@
     (define deriv #f)
     (define deriv-hidden? #f)
     (define binders #f)
+    (define shift-table #f)
 
     (define raw-steps #f)
-    (define raw-steps-estx #f)
+    (define raw-steps-estx #f) ;; #f if raw-steps-exn is exn
-    (define definites #f)
+    (define raw-steps-exn #f) ;; #f if raw-steps-estx is syntax
-    (define error #f)
+    (define raw-steps-definites #f)
     (define raw-steps-oops #f)
 
     (define steps #f)
 
+    ;; --
+    
     (define steps-position #f)
 
     (super-new)
@@ -74,10 +73,11 @@
     (define-guarded-getters (recache-deriv!)
       [get-deriv deriv]
       [get-deriv-hidden? deriv-hidden?]
-      [get-binders binders])
+      [get-binders binders]
+      [get-shift-table shift-table])
     (define-guarded-getters (recache-raw-steps!)
-      [get-definites definites]
+      [get-raw-steps-definites raw-steps-definites]
-      [get-error error]
+      [get-raw-steps-exn raw-steps-exn]
       [get-raw-steps-oops raw-steps-oops])
     (define-guarded-getters (recache-steps!)
       [get-steps steps])
@@ -92,8 +92,8 @@
       (invalidate-steps!)
       (set! raw-steps #f)
       (set! raw-steps-estx #f)
-      (set! definites #f)
+      (set! raw-steps-exn #f)
-      (set! error #f)
+      (set! raw-steps-definites #f)
       (set! raw-steps-oops #f))
 
     ;; invalidate-synth! : -> void
@@ -106,7 +106,8 @@
       (invalidate-synth!)
       (set! deriv #f)
       (set! deriv-hidden? #f)
-      (set! binders #f))
+      (set! binders #f)
+      (set! shift-table #f))
 
     ;; recache! : -> void
     (define/public (recache!)
@@ -132,12 +133,14 @@
               (when (not d)
                 (set! deriv-hidden? #t))
               (when d
-                (let ([alpha-table (make-module-identifier-mapping)])
+                (let ([alpha-table (make-module-identifier-mapping)]
+                      [binder-ids (extract-all-fresh-names d)])
                   (for-each (lambda (id)
                               (module-identifier-mapping-put! alpha-table id id))
-                            (extract-all-fresh-names d))
+                            binder-ids)
                   (set! deriv d)
-                  (set! binders alpha-table))))))))
+                  (set! binders alpha-table)
+                  (set! shift-table (compute-shift-table d)))))))))
 
     ;; recache-synth! : -> void
     (define/private (recache-synth!)
@@ -158,8 +161,8 @@
                               (reductions+ deriv))])
                 (set! raw-steps raw-steps*)
                 (set! raw-steps-estx estx*)
-                (set! error error*)
+                (set! raw-steps-exn error*)
-                (set! definites definites*)))))))
+                (set! raw-steps-definites definites*)))))))
 
     ;; recache-steps! : -> void
     (define/private (recache-steps!)
@@ -271,20 +274,19 @@
 
     ;; display-initial-term : -> void
     (define/public (display-initial-term)
-      (add-syntax (wderiv-e1 deriv) #f null))
+      (send displayer add-syntax (wderiv-e1 deriv) #f null))
 
     ;; display-final-term : -> void
     (define/public (display-final-term)
       (recache-steps!)
       (cond [(syntax? raw-steps-estx)
-             (add-syntax raw-steps-estx binders definites)]
+             (send displayer add-syntax raw-steps-estx
-            [(exn? error)
+                   #:binders binders
-             (add-error error)]
+                   #:shift-table shift-table
-            [raw-steps-oops
+                   #:definites raw-steps-definites)]
-             (add-internal-error "steps" raw-steps-oops #f)]
+            [(exn? raw-steps-exn)
-            [else
+             (send displayer add-error raw-steps-exn)]
-             (error 'term-record::display-final-term
+            [else (display-oops #f)]))
-                    "internal error")]))
 
     ;; display-step : -> void
     (define/public (display-step)
@@ -292,191 +294,25 @@
       (cond [steps
              (let ([step (cursor:next steps)])
                (if step
-                   (add-step step binders)
+                   (send displayer add-step step
-                   (add-final raw-steps-estx error binders definites)))]
+                         #:binders binders
-            [raw-steps-oops
+                         #:shift-table shift-table)
-             (add-internal-error "steps" raw-steps-oops (wderiv-e1 deriv))]
+                   (send displayer add-final raw-steps-estx raw-steps-exn
+                         #:binders binders
+                         #:shift-table shift-table
+                         #:definites raw-steps-definites)))]
+            [else (display-oops #t)]))
+
+    ;; display-oops : boolean -> void
+    (define/private (display-oops show-syntax?)
+      (cond [raw-steps-oops
+             (send displayer add-internal-error
+                   "steps" raw-steps-oops
+                   (and show-syntax? (wderiv-e1 deriv))
+                   events)]
             [raw-deriv-oops
-             (add-internal-error "derivation" raw-deriv-oops #f)]
+             (send displayer add-internal-error
+                   "derivation" raw-deriv-oops #f events)]
             [else
-             (add-internal-error "derivation" #f)]))
+             (error 'term-record::display-oops "internal error")]))
-
-    (define/public (add-internal-error part exn stx)
-      (send sbview add-text
-            (if part
-                (format "Macro stepper error (~a)" part)
-                "Macro stepper error"))
-      (when (exn? exn)
-        (send sbview add-text " ")
-        (send sbview add-clickback "[details]"
-              (lambda _ (show-internal-error-details exn))))
-      (send sbview add-text ".  ")
-      (when stx (send sbview add-text "Original syntax:"))
-      (send sbview add-text "\n")
-      (when stx (send sbview add-syntax stx)))
-
-    (define/private (show-internal-error-details exn)
-      (case (message-box/custom "Macro stepper internal error"
-                                (format "Internal error:\n~a" (exn-message exn))
-                                "Show error"
-                                "Dump debugging file"
-                                "Cancel")
-        ((1) (queue-callback
-              (lambda ()
-                (raise exn))))
-        ((2) (queue-callback
-              (lambda ()
-                (let ([file (put-file)])
-                  (when file
-                    (write-debug-file file exn events))))))
-        ((3 #f) (void))))
-
-    (define/public (add-error exn)
-      (send sbview add-error-text (exn-message exn))
-      (send sbview add-text "\n"))
-
-    (define/public (add-step step binders)
-      (cond [(step? step)
-             (show-step step binders)]
-            [(misstep? step)
-             (show-misstep step binders)]
-            [(prestep? step)
-             (show-prestep step binders)]
-            [(poststep? step)
-             (show-poststep step binders)]))
-
-    (define/public (add-syntax stx binders definites)
-      (send sbview add-syntax stx
-            '#:alpha-table binders
-            '#:definites (or definites null)))
-
-    (define/private (add-final stx error binders definites)
-      (when stx
-        (send sbview add-text "Expansion finished\n")
-        (send sbview add-syntax stx
-              '#:alpha-table binders
-              '#:definites (or definites null)))
-      (when error
-        (add-error error)))
-
-    ;; show-lctx : Step -> void
-    (define/private (show-lctx step binders)
-      (define state (protostep-s1 step))
-      (define lctx (state-lctx state))
-      (when (pair? lctx)
-        (send sbview add-text "\n")
-        (for-each (lambda (bf)
-                    (send sbview add-text 
-                          "while executing macro transformer in:\n")
-                    (insert-syntax/redex (bigframe-term bf)
-                                         (bigframe-foci bf)
-                                         binders
-                                         (state-uses state)
-                                         (state-frontier state)))
-                  (reverse lctx))))
-
-    ;; separator : Step -> void
-    (define/private (separator step)
-      (insert-step-separator (step-type->string (protostep-type step))))
-
-    ;; separator/small : Step -> void
-    (define/private (separator/small step)
-      (insert-step-separator/small
-       (step-type->string (protostep-type step))))
-    
-    ;; show-step : Step -> void
-    (define/private (show-step step binders)
-      (show-state/redex (protostep-s1 step) binders)
-      (separator step)
-      (show-state/contractum (step-s2 step) binders)
-      (show-lctx step binders))
-
-    (define/private (show-state/redex state binders)
-      (insert-syntax/contractum (state-term state)
-                                (state-foci state)
-                                binders
-                                (state-uses state)
-                                (state-frontier state)))
-
-    (define/private (show-state/contractum state binders)
-      (insert-syntax/contractum (state-term state)
-                                (state-foci state)
-                                binders
-                                (state-uses state)
-                                (state-frontier state)))
-
-    ;; show-prestep : Step -> void
-    (define/private (show-prestep step binders)
-      (separator/small step)
-      (show-state/redex (protostep-s1 step) binders)
-      (show-lctx step binders))
-
-    ;; show-poststep : Step -> void
-    (define/private (show-poststep step binders)
-      (separator/small step)
-      (show-state/contractum (protostep-s1 step) binders)
-      (show-lctx step binders))
-
-    ;; show-misstep : Step -> void
-    (define/private (show-misstep step binders)
-      (define state (protostep-s1 step))
-      (show-state/redex state binders)
-      (separator step)
-      (send sbview add-error-text (exn-message (misstep-exn step)))
-      (send sbview add-text "\n")
-      (when (exn:fail:syntax? (misstep-exn step))
-        (for-each (lambda (e)
-                    (send sbview add-syntax e
-                          '#:alpha-table binders
-                          '#:definites (or (state-uses state) null)))
-                  (exn:fail:syntax-exprs (misstep-exn step))))
-      (show-lctx step binders))
-
-    ;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
-    (define/private (insert-syntax/color stx foci binders definites frontier hi-color)
-      (send sbview add-syntax stx
-            '#:definites (or definites null)
-            '#:alpha-table binders
-            '#:hi-color hi-color
-            '#:hi-stxs (if (send config get-highlight-foci?) foci null)
-            '#:hi2-color "WhiteSmoke"
-            '#:hi2-stxs (if (send config get-highlight-frontier?) frontier null)))
-
-    ;; insert-syntax/redex : syntax syntaxes identifiers syntaxes -> void
-    (define/private (insert-syntax/redex stx foci binders definites frontier)
-      (insert-syntax/color stx foci binders definites frontier "MistyRose"))
-
-    ;; insert-syntax/contractum : syntax syntaxes identifiers syntaxes -> void
-    (define/private (insert-syntax/contractum stx foci binders definites frontier)
-      (insert-syntax/color stx foci binders definites frontier "LightCyan"))
-
-    ;; insert-step-separator : string -> void
-    (define/private (insert-step-separator text)
-      (send sbview add-text "\n    ")
-      (send sbview add-text
-            (make-object image-snip% 
-                         (build-path (collection-path "icons")
-                                     "red-arrow.bmp")))
-      (send sbview add-text "  ")
-      (send sbview add-text text)
-      (send sbview add-text "\n\n"))
-
-    ;; insert-as-separator : string -> void
-    (define/private (insert-as-separator text)
-      (send sbview add-text "\n    ")
-      (send sbview add-text text)
-      (send sbview add-text "\n\n"))
-
-    ;; insert-step-separator/small : string -> void
-    (define/private (insert-step-separator/small text)
-      (send sbview add-text "    ")
-      (send sbview add-text
-            (make-object image-snip% 
-                         (build-path (collection-path "icons")
-                                     "red-arrow.bmp")))
-      (send sbview add-text "  ")
-      (send sbview add-text text)
-      (send sbview add-text "\n\n"))
-
-
     ))

collects/macro-debugger/view/warning.ss

@@ -1,13 +1,13 @@
 
-(module warning mzscheme
+#lang scheme/base
-  (require mzlib/class
+(require scheme/class
          mred
          framework)
-  (provide warnings%
+(provide warnings%
          stepper-warnings%)
 
-  ;; warnings%
+;; warnings%
-  (define warnings%
+(define warnings%
   (class object%
     (init parent)
     (super-new)
@@ -70,7 +70,7 @@
     
     ))
 
-  (define stepper-warnings%
+(define stepper-warnings%
   (class warnings%
     (super-new)
     (inherit add)
@@ -128,4 +128,3 @@
         ((hidden-lift-site/continuing)
          (add-hidden-lift-site/continuing-warning))))
     ))
-  )

collects/repos-time-stamp/stamp.ss

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

collects/scheme/sandbox.ss

@@ -2,6 +2,7 @@
 
 (require scheme/port
          scheme/list
+         scheme/string
          syntax/moddep
          scheme/gui/dynamic)
 
@@ -17,9 +18,10 @@
          sandbox-override-collection-paths
          sandbox-path-permissions
          sandbox-security-guard
-         sandbox-exit-handler
          sandbox-network-guard
+         sandbox-exit-handler
          sandbox-make-inspector
+         sandbox-make-code-inspector
          sandbox-make-logger
          sandbox-memory-limit
          sandbox-eval-limits
@@ -37,6 +39,8 @@
          call-in-nested-thread*
          call-with-limits
          with-limits
+         exn:fail:sandbox-terminated?
+         exn:fail:sandbox-terminated-reason
          exn:fail:resource?
          exn:fail:resource-resource)
 
@@ -110,25 +114,23 @@
 (define sandbox-path-permissions
   (make-parameter '()
     (lambda (new)
-                    (map (lambda (perm) (cons (car perm) (map path->bregexp (cdr perm))))
+      (map (lambda (perm) (list (car perm) (path->bregexp (cadr perm))))
            new))))
 
 (define sandbox-network-guard
   (make-parameter (lambda (what . xs)
                     (error what "network access denied: ~e" xs))))
 
-(define default-sandbox-guard
+(define (make-default-sandbox-guard)
   (let ([orig-security (current-security-guard)])
     (make-security-guard
      orig-security
      (lambda (what path modes)
        (when path
-         (let ([needed (let loop ([order permission-order])
+         (let ([needed (car (or (for/or ([p (in-list permission-order)])
-                         (cond [(null? order)
+                                  (memq p modes))
                                 (error 'default-sandbox-guard
-                                       "unknown access modes: ~e" modes)]
+                                       "unknown access modes: ~e" modes)))]
-                               [(memq (car order) modes) (car order)]
-                               [else (loop (cdr order))]))]
                [bpath (parameterize ([current-security-guard orig-security])
                         (path->bytes (simplify-path* path)))])
            (unless (ormap (lambda (perm)
@@ -136,20 +138,29 @@
                                  (regexp-match (cadr perm) bpath)))
                           (sandbox-path-permissions))
              (error what "`~a' access denied for ~a"
-                    (apply string-append
+                    (string-append* (add-between (map symbol->string modes) "+"))
-                           (add-between (map symbol->string modes) "+"))
                     path)))))
      (lambda args (apply (sandbox-network-guard) args)))))
 
-(define sandbox-security-guard (make-parameter default-sandbox-guard))
+(define sandbox-security-guard
+  (make-parameter make-default-sandbox-guard
+    (lambda (x)
+      (if (or (security-guard? x)
+              (and (procedure? x) (procedure-arity-includes? x 0)))
+        x
+        (raise-type-error
+         'sandbox-security-guard
+         "security-guard or a security-guard translator procedure" x)))))
 
-(define (default-sandbox-exit-handler _)
+;; this is never really used (see where it's used in the evaluator)
-  (error 'exit "sandboxed code cannot exit"))
+(define (default-sandbox-exit-handler _) (error 'exit "sandbox exits"))
 
 (define sandbox-exit-handler (make-parameter default-sandbox-exit-handler))
 
 (define sandbox-make-inspector (make-parameter make-inspector))
 
+(define sandbox-make-code-inspector (make-parameter make-inspector))
+
 (define sandbox-make-logger (make-parameter current-logger))
 
 (define (compute-permissions paths+require-perms)
@@ -169,7 +180,7 @@
             (let ([base (simplify-path* base)])
               (loop (cdr paths)
                     (if (member base bases) bases (cons base bases))))))))
-  (append (map (lambda (p) `(read ,(path->bytes p))) paths)
+  (append (map (lambda (p) `(read ,p)) paths)
           (map (lambda (b) `(read ,(build-path b "compiled"))) bases)
           (map (lambda (b) `(exists ,b)) bases)))
 
@@ -433,21 +444,34 @@
                     (lambda (x) (abort-current-continuation deftag x)))
                    (loop (car exprs) (cdr exprs))))))))))
 
+;; We need a powerful enough code inspector to invoke the errortrace library
+;; (indirectly through private/sandbox-coverage).  But there is a small problem
+;; here -- errortrace/stacktrace.ss will grab the global code inspector value
+;; at the time it is invoked.  So we grab it here too, and use it to wrap the
+;; code that invokes errortrace.  If errortrace/stacktrace.ss is changed to
+;; grab the current inspector, then it would be better to avoid this here, and
+;; pass `evaluate-program' the inspector that was in effect when the sandbox
+;; was created.
+(define orig-code-inspector (current-code-inspector))
+
 (define (evaluate-program program limit-thunk uncovered!)
+  (parameterize ([current-code-inspector orig-code-inspector])
     (when uncovered!
-    (eval `(,#'#%require scheme/private/sandbox-coverage)))
+      (eval `(,#'#%require scheme/private/sandbox-coverage))))
-  ;; the actual evaluation happens under the specified limits
-  ((limit-thunk (lambda ()
-                  (if (and (pair? program) (eq? 'begin (car program)))
-                    (eval* (cdr program))
-                    (eval program)))))
   (let ([ns (syntax-case* program (module) literal-identifier=?
               [(module mod . body)
                (identifier? #'mod)
                (let ([mod #'mod])
+                 (lambda ()
                    (eval `(,#'require (quote ,mod)))
-                 (module->namespace `(quote ,(syntax-e mod))))]
+                   (module->namespace `(quote ,(syntax-e mod)))))]
               [_else #f])])
+    ;; the actual evaluation happens under the specified limits
+    ((limit-thunk (lambda ()
+                    (if (and (pair? program) (eq? 'begin (car program)))
+                      (eval* (cdr program))
+                      (eval program))
+                    (when ns (set! ns (ns))))))
     (when uncovered!
       (let ([get (let ([ns (current-namespace)])
                    (lambda () (eval '(get-uncovered-expressions) ns)))])
@@ -492,11 +516,21 @@
 (define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered)
 (define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk)
 
+
+(define-struct (exn:fail:sandbox-terminated exn:fail) (reason) #:transparent)
+(define (make-terminated reason)
+  (make-exn:fail:sandbox-terminated
+   (format "evaluator: terminated (~a)" reason)
+   (current-continuation-marks)
+   reason))
+
 (define (make-evaluator* init-hook allow program-maker)
+  (define orig-code-inspector (current-code-inspector))
   (define orig-cust     (current-custodian))
   (define memory-cust   (make-custodian orig-cust))
   (define memory-cust-box (make-custodian-box memory-cust #t))
   (define user-cust     (make-custodian memory-cust))
+  (define user-cust-box (make-custodian-box user-cust #t))
   (define coverage?     (sandbox-coverage-enabled))
   (define uncovered     #f)
   (define input-ch      (make-channel))
@@ -507,6 +541,18 @@
   (define limits        (sandbox-eval-limits))
   (define user-thread   #t) ; set later to the thread
   (define user-done-evt #t) ; set in the same place
+  (define terminated?   #f) ; set to an exception value when the sandbox dies
+  (define (terminated! reason)
+    (unless terminated?
+      (set! terminated?
+            (make-terminated
+             (cond [(eq? reason #t) ; => guess
+                    (if (custodian-box-value user-cust-box)
+                      'thread-killed
+                      'custodian-shutdown)]
+                   [reason reason] ; => explicit
+                   ;; otherwise it's an indication of an internal error
+                   [else "internal error: no termination reason"])))))
   (define (limit-thunk thunk)
     (let* ([sec (and limits (car limits))]
            [mb  (and limits (cadr limits))])
@@ -515,6 +561,7 @@
     (when user-thread
       (let ([t user-thread])
         (set! user-thread #f)
+        (terminated! #f)
         (custodian-shutdown-all user-cust)
         (kill-thread t))) ; just in case
     (void))
@@ -535,7 +582,8 @@
     (let ([n 0])
       (let loop ()
         (let ([expr (channel-get input-ch)])
-          (when (eof-object? expr) (channel-put result-ch expr) (user-kill))
+          (when (eof-object? expr)
+            (terminated! 'eof) (channel-put result-ch expr) (user-kill))
           (with-handlers ([void (lambda (exn)
                                   (channel-put result-ch (cons 'exn exn)))])
             (define run
@@ -549,22 +597,28 @@
             (channel-put result-ch (cons 'vals (call-with-values run list))))
           (loop)))))
   (define (user-eval expr)
-    (let ([r (if user-thread
+    ;; the thread will usually be running, but it might be killed outside of
-               (begin (channel-put input-ch expr)
+    ;; the sandboxed environment, for example, if you do something like
-                      (let loop ()
+    ;; (kill-thread (ev '(current-thread))) when there are no per-expression
-                        (with-handlers ([(lambda (e)
+    ;; limits (since then you get a different thread, which is already dead).
-                                           (and (sandbox-propagate-breaks)
+    (when (and user-thread (thread-dead? user-thread))
-                                                (exn:break? e)))
+      (terminated! #t))
-                                         (lambda (e)
+    (cond
-                                           (user-break)
+      [terminated? => raise]
-                                           (loop))])
+      [(not user-thread) (error 'sandbox "internal error (user-thread is #f)")]
-                          (sync user-done-evt result-ch))))
+      [else
-               eof)])
+       (channel-put input-ch expr)
-      (cond [(eof-object? r) (error 'evaluator "terminated~a"
+       (let ([r (let loop ()
-                                    (if (custodian-box-value memory-cust-box)
+                  (with-handlers ([(if (sandbox-propagate-breaks)
-                                      "" " (memory exceeded)"))]
+                                     exn:break? (lambda (_) #f))
+                                   (lambda (e) (user-break) (loop))])
+                    (sync user-done-evt result-ch)))])
+         (cond [(eof-object? r)
+                (terminated! (and (not (custodian-box-value memory-cust-box))
+                                  'out-of-memory))
+                (raise terminated?)]
                [(eq? (car r) 'exn) (raise (cdr r))]
-            [else (apply values (cdr r))])))
+               [else (apply values (cdr r))]))]))
   (define get-uncovered
     (case-lambda
      [() (get-uncovered #t)]
@@ -592,7 +646,7 @@
       (let ([msg (evaluator-message-msg expr)])
         (case msg
           [(alive?) (and user-thread (not (thread-dead? user-thread)))]
-          [(kill)   (user-kill)]
+          [(kill)   (terminated! 'evaluator-killed) (user-kill)]
           [(break)  (user-break)]
           [(limits) (set! limits (evaluator-message-args expr))]
           [(input)  (apply input-putter (evaluator-message-args expr))]
@@ -623,7 +677,7 @@
              out)]
           [else (error 'make-evaluator "bad sandox-~a spec: ~e" what out)]))
   ;; set global memory limit
-  (when (sandbox-memory-limit)
+  (when (and memory-accounting? (sandbox-memory-limit))
     (custodian-limit-memory
      memory-cust (* (sandbox-memory-limit) 1024 1024) memory-cust))
   (parameterize* ; the order in these matters
@@ -660,12 +714,26 @@
     ;; general info
     [current-command-line-arguments '#()]
     ;; restrict the sandbox context from this point
-    [current-security-guard (sandbox-security-guard)]
+    [current-security-guard
-    [exit-handler (sandbox-exit-handler)]
+     (let ([g (sandbox-security-guard)]) (if (security-guard? g) g (g)))]
+    [exit-handler
+     (let ([h (sandbox-exit-handler)])
+       (if (eq? h default-sandbox-exit-handler)
+         (lambda _ (terminated! 'exited) (user-kill))
+         h))]
     [current-inspector ((sandbox-make-inspector))]
     [current-logger ((sandbox-make-logger))]
-    ;; This breaks because we need to load some libraries that are trusted
+    [current-code-inspector (make-inspector)]
-    ;; [current-code-inspector (make-inspector)]
+    ;; The code inspector serves two purposes -- making sure that only trusted
+    ;; byte-code is loaded, and avoiding using protected moduel bindings, like
+    ;; the foreign library's `unsafe!'.  We don't need the first because we
+    ;; control it indirectly through the security guard, so this handler makes
+    ;; sure that byte-code is loaded using the original inspector.
+    [current-load/use-compiled
+     (let ([handler (current-load/use-compiled)])
+       (lambda (path modname)
+         (parameterize ([current-code-inspector orig-code-inspector])
+           (handler path modname))))]
     ;; Note the above definition of `current-eventspace': in MzScheme, it
     ;; is an unused parameter.  Also note that creating an eventspace
     ;; starts a thread that will eventually run the callback code (which
@@ -673,8 +741,10 @@
     ;; must be nested in the above (which is what paramaterize* does), or
     ;; it will not use the new namespace.
     [current-eventspace (make-eventspace)])
-   (set! user-thread (bg-run->thread (run-in-bg user-process)))
+   (let ([t (bg-run->thread (run-in-bg user-process))])
-   (set! user-done-evt (handle-evt user-thread (lambda (_) (user-kill) eof)))
+     (set! user-done-evt
+           (handle-evt t (lambda (_) (terminated! #t) (user-kill) eof)))
+     (set! user-thread t))
    (let ([r (channel-get result-ch)])
      (if (eq? r 'ok)
        ;; initial program executed ok, so return an evaluator

collects/scribblings/reference/sandbox.scrbl

@@ -16,7 +16,10 @@
 The @schememodname[scheme/sandbox] module provides utilities for
 creating ``sandboxed'' evaluators, which are configured in a
 particular way and can have restricted resources (memory and time),
-filesystem access, and network access.
+filesystem access, and network access.  The common use case for this
+module is for a restricted sandboxed environment, so the defaults are
+set up to make it safe.  For other uses you will likely need to change
+mane of these settings.
 
 @defproc*[([(make-evaluator [language (or/c module-path? 
                                             (list/c 'special symbol?)
@@ -240,6 +243,19 @@ used from a module (by using a new namespace):
 
 }
 
+
+@defproc*[([(exn:fail:sandbox-terminated? [v any/c]) boolean?]
+           [(exn:fail:sandbox-terminated-reason [exn exn:fail:sandbox-terminated?])
+            symbol/c])]{
+
+A predicate and accessor for exceptions that are raised when a sandbox
+is terminated.  Once a sandbox raises such an exception, it will
+continue to raise it on further evaluation attempts.
+
+@scheme[call-with-limits].  The @scheme[resource] field holds a symbol,
+either @scheme['time] or @scheme['memory].}
+
+
 @; ----------------------------------------------------------------------
 
 @section{Customizing Evaluators}
@@ -414,12 +430,15 @@ done using a fake library that provides the same interface but no
 actual interaction. The default is @scheme[null].}
 
 
-@defparam[sandbox-security-guard guard security-guard?]{
+@defparam[sandbox-security-guard guard
+          (or/c security-guard? (-> security-guard?))]{
 
 A parameter that determines the initial
-@scheme[(current-security-guard)] for sandboxed evaluations.  The
+@scheme[(current-security-guard)] for sandboxed evaluations.  It can
-default forbids all filesystem I/O except for things in
+be either a security guard, or a function to construct one.  The
-@scheme[sandbox-path-permissions], and it uses
+default is a function that restricts the access of the current
+security guard by forbidding all filesystem I/O except for
+specifications in @scheme[sandbox-path-permissions], and it uses
 @scheme[sandbox-network-guard] for network connections.}
 
 
@@ -451,12 +470,6 @@ collection libraries (including
 @scheme[make-evalautor] for more information.}
 
 
-@defparam[sandbox-exit-handler handler (any/c . -> . any)]{
-
-A parameter that determines the initial @scheme[(exit-handler)] for
-sandboxed evaluations.  The default handler simply throws an error.}
-
-
 @defparam[sandbox-network-guard proc
           (symbol?
            (or/c (and/c string? immutable?) #f)
@@ -469,6 +482,14 @@ default @scheme[sandbox-security-guard].  The default forbids all
 network connection.}
 
 
+@defparam[sandbox-exit-handler handler (any/c . -> . any)]{
+
+A parameter that determines the initial @scheme[(exit-handler)] for
+sandboxed evaluations.  The default kills the evaluator with an
+appropriate error message (see
+@scheme[exn:fail:sandbox-terminated-reason]).}
+
+
 @defparam[sandbox-memory-limit limit (or/c exact-nonnegative-integer? #f)]{
 
 A parameter that determines the total memory limit on the sandbox.
@@ -495,8 +516,14 @@ is @scheme[(list 30 20)].
 
 Note that these limits apply to the creation of the sandbox
 environment too --- even @scheme[(make-evaluator 'scheme/base)] can
-fail if the limits are strict enough.  Therefore, to avoid surprises
+fail if the limits are strict enough.  For example,
-you need to catch errors that happen when the sandbox is created.
+@schemeblock[
+  (parameterize ([sandbox-eval-limits '(0.25 5)])
+    (make-evaluator 'scheme/base '(sleep 2)))
+]
+will throw an error instead of creating an evaluator.  Therefore, to
+avoid surprises you need to catch errors that happen when the sandbox
+is created.
 
 When limits are set, @scheme[call-with-limits] (see below) is wrapped
 around each use of the evaluator, so consuming too much time or memory
@@ -545,14 +572,26 @@ then, assuming sufficiently small limits,
 @defparam[sandbox-make-inspector make (-> inspector?)]{
 
 A parameter that determines the procedure used to create the inspector
-for sandboxed evaluation. The procedure is called when initializing an
+for sandboxed evaluation.  The procedure is called when initializing
-evaluator, and the default parameter value is @scheme[make-inspector].}
+an evaluator, and the default parameter value is
+@scheme[make-inspector].}
+
+
+@defparam[sandbox-make-code-inspector make (-> inspector?)]{
+
+A parameter that determines the procedure used to create the code
+inspector for sandboxed evaluation.  The procedure is called when
+initializing an evaluator, and the default parameter value is
+@scheme[make-inspector].}
+
 
 @defparam[sandbox-make-logger make (-> logger?)]{
 
 A parameter that determines the procedure used to create the logger
-for sandboxed evaluation. The procedure is called when initializing an
+for sandboxed evaluation.  The procedure is called when initializing
-evaluator, and the default parameter value is @scheme[current-logger].}
+an evaluator, and the default parameter value is
+@scheme[current-logger].  This means that it is not creating a new
+logger (this might change in the future).}
 
 @; ----------------------------------------------------------------------
 
@@ -686,7 +725,17 @@ used for evaluating expressions.
 This is usually similar to @scheme[(evaluator (list thunk))], except
 that this relies on the common meaning of list expressions as function
 application (which is not true in all languages), and it relies on
-MzScheme's @scheme[eval] forgiving a non-S-expression input.}
+MzScheme's @scheme[eval] forgiving a non-S-expression input.  In
+addition, you can avoid some of the sandboxed restrictions by using
+your own permissions, for example,
+@schemeblock[
+  (let ([guard (current-security-guard)])
+    (call-in-sandbox-context
+      (lambda ()
+        (parameterize ([current-security-guard guard])
+          (code:comment #, @t{can access anything you want here})
+          ))))
+]}
 
 @; ----------------------------------------------------------------------
 

collects/tests/mzscheme/sandbox.ss

@@ -80,7 +80,7 @@
                          "(define (plus1 x) x)"
                          "(define (loop) (loop))"
                          "(define (memory x) (make-vector x))")))
-   (set-eval-limits ev 1 3)
+   (set-eval-limits ev 0.5 5)
    --eval--
    x => 1
    (id 1) => 1
@@ -102,7 +102,7 @@
    (loop) =err> "out of time"
    --top--
    (when (custodian-memory-accounting-available?)
-     (t --eval-- (memory 1000000) =err> "out of memory"))
+     (t --eval-- (memory 3000000) =err> "out of memory"))
    ;; test parameter settings (tricky to get this right since
    ;; with-limits runs stuff in a different thread)
    (set-eval-limits ev #f #f)
@@ -130,12 +130,30 @@
    (thread (lambda () (sleep 1) (break-evaluator ev)))
    --eval--
    (sleep 2) =err> "user break"
+   (printf "x = ~s\n" x) => (void)
    ;; termination
    --eval--
-   (printf "x = ~s\n" x) => (void)
+   ,eof =err> "terminated .eof.$"
-   ,eof =err> "terminated"
+   123  =err> "terminated .eof.$"
-   x =err> "terminated"
+   ,eof =err> "terminated .eof.$"
-   ,eof =err> "terminated"
+
+   ;; other termination messages
+   --top-- (set! ev (make-evaluator 'scheme/base)) (kill-evaluator ev)
+   --eval-- 123 =err> "terminated .evaluator-killed.$"
+
+   ;; eval-limits apply to the sandbox creation too
+   --top--
+   (set! ev (parameterize ([sandbox-eval-limits '(0.25 5)])
+              (make-evaluator 'scheme/base '(sleep 2))))
+   =err> "out of time"
+   (when (custodian-memory-accounting-available?)
+     (t --top--
+        (set! ev (parameterize ([sandbox-eval-limits '(0.25 2)])
+                   (make-evaluator 'scheme/base
+                                   '(define a (for/list ([i (in-range 10)])
+                                                (collect-garbage)
+                                                (make-string 1000))))))
+        =err> "out of memory"))
 
    ;; i/o
    --top--
@@ -186,9 +204,9 @@
    --top--
    (kill-evaluator ev) => (void)
    --eval--
-   x =err> "terminated"
+   x =err> "terminated .evaluator-killed.$"
-   y =err> "terminated"
+   y =err> "terminated .evaluator-killed.$"
-   ,eof =err> "terminated"
+   ,eof =err> "terminated .evaluator-killed.$"
    --top--
    (let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)])
      ;; o1 -> i1 -ev-> o2 -> i2
@@ -401,43 +419,47 @@
    (set! ev (parameterize ([sandbox-eval-limits #f])
               (make-evaluator 'scheme/base)))
    --eval--
-   (kill-thread (current-thread)) =err> "terminated"
+   (kill-thread (current-thread)) =err> "terminated .thread-killed.$"
    --top--
    (set! ev (parameterize ([sandbox-eval-limits #f])
               (make-evaluator 'scheme/base)))
    --eval--
-   (custodian-shutdown-all (current-custodian)) =err> "terminated"
+   (custodian-shutdown-all (current-custodian))
+   =err> "terminated .custodian-shutdown.$"
    --top--
    ;; also happens when it's done directly
    (set! ev (parameterize ([sandbox-eval-limits #f])
               (make-evaluator 'scheme/base)))
    (call-in-sandbox-context ev (lambda () (kill-thread (current-thread))))
-   =err> "terminated"
+   =err> "terminated .thread-killed.$"
    (set! ev (parameterize ([sandbox-eval-limits #f])
               (make-evaluator 'scheme/base)))
    (call-in-sandbox-context ev
      (lambda () (custodian-shutdown-all (current-custodian))))
-   =err> "terminated"
+   =err> "terminated .custodian-shutdown.$"
    --top--
    ;; now make sure it works with per-expression limits too
    (set! ev (make-evaluator 'scheme/base))
    --eval--
-   (kill-thread (current-thread)) =err> "terminated"
+   (kill-thread (current-thread)) =err> "terminated .thread-killed.$"
    --top--
    (set! ev (make-evaluator 'scheme/base))
    --eval--
-   (custodian-shutdown-all (current-custodian)) =err> "terminated"
+   (custodian-shutdown-all (current-custodian))
+   =err> "terminated .custodian-shutdown.$"
    --top--
    (set! ev (make-evaluator 'scheme/base))
    (call-in-sandbox-context ev (lambda () (kill-thread (current-thread))))
-   =err> "terminated"
+   =err> "terminated .thread-killed.$"
    (set! ev (make-evaluator 'scheme/base))
    (call-in-sandbox-context ev
      (lambda () (custodian-shutdown-all (current-custodian))))
-   =err> "terminated"
+   =err> "terminated .custodian-shutdown.$"
 
    ;; when an expression is out of memory, the sandbox should stay alive
    --top--
+   (when (custodian-memory-accounting-available?)
+     (t --top--
         (set! ev (parameterize ([sandbox-eval-limits '(2 5)]
                                 [sandbox-memory-limit 100])
                    (make-evaluator 'scheme/base)))
@@ -448,7 +470,7 @@
           (set! a (cons (make-bytes 500000) a))
           (collect-garbage))
         =err> "out of memory"
-   b => 1
+        b => 1))
 
    ))
 

collects/xml/xml.scrbl

@@ -103,7 +103,7 @@ Represents an element.}
 
 Returns @scheme[#t] if @scheme[v] is a @scheme[pcdata] instance,
 @scheme[element] instance, an @scheme[entity] instance,
-@scheme[comment], or @scheme[pcdata] instance.}
+@scheme[comment], or @scheme[cdata] instance.}
 
 @defstruct[(attribute source) ([name symbol?] [value string?])]{
 

src/mzscheme/gc2/backtrace.c

@@ -45,7 +45,7 @@ static void *print_out_pointer(const char *prefix, void *p,
   trace_page_t *page;
   const char *what;
 
-  page = find_page(p);
+  page = pagemap_find_page(GC->page_maps, p);
   if (!page || (trace_page_type(page) == TRACE_PAGE_BAD)) {
     GCPRINT(GCOUTF, "%s??? %p\n", prefix, p);
     return NULL;
@@ -94,7 +94,7 @@ static void print_traced_objects(int path_length_limit,
 				 GC_print_tagged_value_proc print_tagged_value)
 {
   int i;
-  avoid_collection++;
+  GC->dumping_avoid_collection++;
   GCPRINT(GCOUTF, "Begin Trace\n");
   for (i = 0; i < found_object_count; i++) {
     void *p;
@@ -107,5 +107,5 @@ static void print_traced_objects(int path_length_limit,
     }
   }
   GCPRINT(GCOUTF, "End Trace\n");
-  --avoid_collection;
+  --GC->dumping_avoid_collection;
 }

src/mzscheme/gc2/newgc.c

@@ -934,7 +934,7 @@ static void backtrace_new_page(NewGC *gc, mpage *page)
 
 static void free_backtrace(struct mpage *page)
 {
-  free_pages(page->backtrace, APAGE_SIZE);
+  free_pages(GC, page->backtrace, APAGE_SIZE);
 }
 
 static void *bt_source;
@@ -1590,6 +1590,11 @@ void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark,
   mark_tag = BTC_get_redirect_tag(gc, mark_tag);
 #endif
 
+#if MZ_GC_BACKTRACE
+  /* Keep tagged objects in tagged space: */
+  atomic = 0;
+#endif
+
   gc->mark_table[mark_tag]  = atomic ? (Mark_Proc)PAGE_ATOMIC : mark;
   gc->fixup_table[tag]      = fixup;
 }
@@ -2145,7 +2150,7 @@ static void mark_backpointers(NewGC *gc)
           pagemap_add(pagemap, work);
           if(work->big_page) {
             work->big_page = 2;
-            push_ptr(PPTR(NUM(work->addr) + PREFIX_SIZE));
+            push_ptr(PPTR(NUM(work->addr) + PREFIX_SIZE + sizeof(struct objhead)));
           } else {
             if(work->page_type != PAGE_ATOMIC) {
               void **start = PPTR(NUM(work->addr) + PREFIX_SIZE);

src/mzscheme/src/env.c

@@ -123,6 +123,8 @@ static Scheme_Object *write_toplevel(Scheme_Object *obj);
 static Scheme_Object *read_toplevel(Scheme_Object *obj);
 static Scheme_Object *write_variable(Scheme_Object *obj);
 static Scheme_Object *read_variable(Scheme_Object *obj);
+static Scheme_Object *write_module_variable(Scheme_Object *obj);
+static Scheme_Object *read_module_variable(Scheme_Object *obj);
 static Scheme_Object *write_local(Scheme_Object *obj);
 static Scheme_Object *read_local(Scheme_Object *obj);
 static Scheme_Object *read_local_unbox(Scheme_Object *obj);
@@ -561,8 +563,8 @@ static void make_kernel_env(void)
   scheme_install_type_reader(scheme_toplevel_type, read_toplevel);
   scheme_install_type_writer(scheme_variable_type, write_variable);
   scheme_install_type_reader(scheme_variable_type, read_variable);
-  scheme_install_type_writer(scheme_module_variable_type, write_variable);
+  scheme_install_type_writer(scheme_module_variable_type, write_module_variable);
-  scheme_install_type_reader(scheme_module_variable_type, read_variable);
+  scheme_install_type_reader(scheme_module_variable_type, read_module_variable);
   scheme_install_type_writer(scheme_local_type, write_local);
   scheme_install_type_reader(scheme_local_type, read_local);
   scheme_install_type_writer(scheme_local_unbox_type, write_local);
@@ -3319,7 +3321,7 @@ void scheme_optimize_info_done(Optimize_Info *info)
 Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify)
 {
   Resolve_Prefix *rp;
-  Scheme_Object **tls, **stxes, *simplify_cache;
+  Scheme_Object **tls, **stxes, *simplify_cache, *m;
   Scheme_Hash_Table *ht;
   int i;
 
@@ -3344,7 +3346,15 @@ Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify)
   if (ht) {
     for (i = 0; i < ht->size; i++) {
       if (ht->vals[i]) {
-	tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = ht->keys[i];
+        m = ht->keys[i];
+        if (SAME_TYPE(SCHEME_TYPE(m), scheme_module_variable_type)) {
+          if (SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->base)
+              && SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->path)) {
+            /* Reduce self-referece to just a symbol: */
+            m = ((Module_Variable *)m)->sym;
+          }
+        }
+	tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = m;
       }
     }
   }
@@ -4941,10 +4951,8 @@ static Scheme_Object *read_toplevel(Scheme_Object *obj)
 }
 
 static Scheme_Object *write_variable(Scheme_Object *obj)
-  /* WARNING: phase-0 module variables and #%kernel references
+  /* #%kernel references are handled in print.c, instead */
-     are handled in print.c, instead */
 {
-  if (SAME_TYPE(scheme_variable_type, SCHEME_TYPE(obj))) {
   Scheme_Object *sym;
   Scheme_Env *home;
   Scheme_Module *m;
@@ -4965,68 +4973,32 @@ static Scheme_Object *write_variable(Scheme_Object *obj)
   }
 
   return sym;
-  } else {
-    Module_Variable *mv = (Module_Variable *)obj;
-
-    return scheme_make_pair(scheme_make_integer(mv->mod_phase),
-			    scheme_make_pair(mv->modidx,
-					     mv->sym));
-  }
 }
 
 static Scheme_Object *read_variable(Scheme_Object *obj)
-  /* WARNING: phase-0 module variables and #%kernel references
+  /* #%kernel references are handled in read.c, instead */
-     are handled in read.c, instead */
 {
   Scheme_Env *env;
 
   env = scheme_get_env(NULL);
 
-  if (!SCHEME_SYMBOLP(obj)) {
+  if (!SCHEME_SYMBOLP(obj)) return NULL;
-    /* Find variable from module. */
-    Scheme_Object *modname, *varname;
-    int mod_phase = 0;
-
-    if (!SCHEME_PAIRP(obj)) return NULL;
-
-    modname = SCHEME_CAR(obj);
-    
-    if (SCHEME_INTP(modname)) {
-      mod_phase = SCHEME_INT_VAL(modname);
-      if (mod_phase != 1) return NULL;
-
-      obj = SCHEME_CDR(obj);
-
-      if (!SCHEME_PAIRP(obj)) return NULL;
-      modname = SCHEME_CAR(obj);
-    }
-
-    varname = SCHEME_CDR(obj);
-
-    if (SAME_OBJ(modname, kernel_symbol) && !mod_phase) {
-      return (Scheme_Object *)scheme_global_bucket(varname, scheme_get_kernel_env());
-    } else {
-      Module_Variable *mv;
-      Scheme_Object *insp;
-
-      insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
-      
-      mv = MALLOC_ONE_TAGGED(Module_Variable);
-      mv->so.type = scheme_module_variable_type;
-      
-      mv->modidx = modname;
-      mv->sym = varname;
-      mv->insp = insp;
-      mv->pos = -1;
-      mv->mod_phase = mod_phase;
-
-      return (Scheme_Object *)mv;
-    }
-  }
 
   return (Scheme_Object *)scheme_global_bucket(obj, env);
 }
 
+static Scheme_Object *write_module_variable(Scheme_Object *obj)
+{
+  scheme_signal_error("module variables should have been handled in print.c");
+  return NULL;
+}
+
+static Scheme_Object *read_module_variable(Scheme_Object *obj)
+{
+  scheme_signal_error("module variables should have been handled in read.c");
+  return NULL;
+}
+
 static Scheme_Object *write_local(Scheme_Object *obj)
 {
   return scheme_make_integer(SCHEME_LOCAL_POS(obj));
@@ -5128,9 +5100,16 @@ static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
     if (SCHEME_FALSEP(stx)) {
       stx = NULL;
     } else if (SCHEME_RPAIRP(stx)) {
-      rp->delay_info = (struct Scheme_Load_Delay *)SCHEME_CDR(stx);
+      struct Scheme_Load_Delay *d;
-      rp->delay_refcount++;
+      Scheme_Object *pr;
+      d = (struct Scheme_Load_Delay *)SCHEME_CDR(stx);
       stx = SCHEME_CAR(stx);
+      pr = rp->delay_info_rpair;
+      if (!pr) {
+        pr = scheme_make_raw_pair(scheme_make_integer(0), (Scheme_Object *)d);
+        rp->delay_info_rpair = pr;
+      }
+      SCHEME_CAR(pr) = scheme_make_integer(SCHEME_INT_VAL(SCHEME_CAR(pr)) + 1);
     } else {
       if (!SCHEME_STXP(stx)) return NULL;
     }

src/mzscheme/src/eval.c

@@ -1721,20 +1721,23 @@ Scheme_Object *scheme_make_syntax_compiled(int idx, Scheme_Object *data)
 
 static Scheme_Object *link_module_variable(Scheme_Object *modidx,
 					   Scheme_Object *varname,
-					   Scheme_Object *insp,
+					   int check_access, Scheme_Object *insp,
 					   int pos, int mod_phase,
-					   Scheme_Env *env)
+					   Scheme_Env *env, 
+                                           Scheme_Object **exprs, int which)
 {
   Scheme_Object *modname;
   Scheme_Env *menv;
+  int self = 0;
 
   /* If it's a name id, resolve the name. */
   modname = scheme_module_resolve(modidx, 1);
 
   if (env->module && SAME_OBJ(env->module->modname, modname)
-      && (env->mod_phase == mod_phase))
+      && (env->mod_phase == mod_phase)) {
+    self = 1;
     menv = env;
-  else {
+  } else {
     menv = scheme_module_access(modname, env, mod_phase);
     
     if (!menv && env->phase) {
@@ -1757,22 +1760,57 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
       return NULL;
     }
 
-    if (!SAME_OBJ(menv, env)) {
+    if (check_access && !SAME_OBJ(menv, env)) {
       varname = scheme_check_accessible_in_module(menv, insp, NULL, varname, NULL, NULL, 
                                                   insp, pos, 0, NULL, env);
     }
   }
 
+  if (exprs) {
+    if (self) {
+      exprs[which] = varname;
+    } else {
+      if (mod_phase != 0)
+        modname = scheme_make_pair(modname, scheme_make_integer(mod_phase));
+      modname = scheme_make_pair(varname, modname);
+      exprs[which] = modname;
+    }
+  }
+
   return (Scheme_Object *)scheme_global_bucket(varname, menv);
 }
 
-static Scheme_Object *link_toplevel(Scheme_Object *expr, Scheme_Env *env,
+static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env *env,
                                     Scheme_Object *src_modidx, 
                                     Scheme_Object *dest_modidx)
 {
-  if (SCHEME_SYMBOLP(expr)) {
+  Scheme_Object *expr = exprs[which];
+
+  if (SCHEME_FALSEP(expr)) {
     /* See scheme_make_environment_dummy */
     return (Scheme_Object *)scheme_global_bucket(begin_symbol, env);
+  } else if (SCHEME_PAIRP(expr) || SCHEME_SYMBOLP(expr)) {
+    /* Simplified module reference */
+    Scheme_Object *modname, *varname;
+    int mod_phase = 0;
+    if (SCHEME_SYMBOLP(expr)) {
+      varname = expr;
+      modname = env->module->modname;
+      mod_phase = env->mod_phase;
+    } else {
+      varname = SCHEME_CAR(expr);
+      modname = SCHEME_CDR(expr);
+      if (SCHEME_PAIRP(modname)) {
+        mod_phase = SCHEME_INT_VAL(SCHEME_CDR(modname));
+        modname = SCHEME_CAR(modname);
+      }
+    }
+    return link_module_variable(modname,
+                                varname,
+                                0, NULL,
+                                -1, mod_phase,
+                                env, 
+                                NULL, 0);
   } else if (SAME_TYPE(SCHEME_TYPE(expr), scheme_variable_type)) {
     Scheme_Bucket_With_Home *b = (Scheme_Bucket_With_Home *)expr;
     
@@ -1781,18 +1819,20 @@ static Scheme_Object *link_toplevel(Scheme_Object *expr, Scheme_Env *env,
     else
       return link_module_variable(b->home->module->modname,
 				  (Scheme_Object *)b->bucket.bucket.key,
-				  b->home->module->insp,
+				  1, b->home->module->insp,
 				  -1, b->home->mod_phase,
-				  env);
+				  env, 
+                                  exprs, which);
   } else {
     Module_Variable *mv = (Module_Variable *)expr;
     
     return link_module_variable(scheme_modidx_shift(mv->modidx,
                                                     src_modidx,
                                                     dest_modidx),
-				mv->sym, mv->insp,
+				mv->sym, 1, mv->insp,
 				mv->pos, mv->mod_phase,
-				env);
+				env,
+                                exprs, which);
   }
 }
 
@@ -8589,6 +8629,7 @@ static void *eval_k(void)
       v = _scheme_eval_linked_expr_wp(v, p);
   } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_compilation_top_type)) {
     Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)v;
+    Resolve_Prefix *rp;
     int depth;
 
     depth = top->max_let_depth + scheme_prefix_depth(top->prefix);
@@ -8604,6 +8645,9 @@ static void *eval_k(void)
 
     if (use_jit)
       v = scheme_jit_expr(v);
+    else
+      v = scheme_eval_clone(v);
+    rp = scheme_prefix_eval_clone(top->prefix);
 
     save_runstack = scheme_push_prefix(env, top->prefix, NULL, NULL, 0, env->phase);
 
@@ -9689,6 +9733,60 @@ local_eval(int argc, Scheme_Object **argv)
   return scheme_void;
 }
 
+/*========================================================================*/
+/*                       cloning prefix information                       */
+/*========================================================================*/
+
+Scheme_Object *scheme_eval_clone(Scheme_Object *expr)
+{
+  /* Clone as much as necessary of `expr' so that prefixes are
+     cloned. Cloned prefixes, in turn, can be updated by linking to
+     reduce the overhead of cross-module references. */
+  if (SAME_TYPE(SCHEME_TYPE(expr), scheme_syntax_type)) {
+    int kind;
+    Scheme_Object *orig, *naya;
+    
+    kind = SCHEME_PINT_VAL(expr);
+    orig = SCHEME_IPTR_VAL(expr);
+    switch (kind) {
+    case MODULE_EXPD:
+      naya = scheme_module_eval_clone(orig);
+      break;
+    case DEFINE_SYNTAX_EXPD:
+    case DEFINE_FOR_SYNTAX_EXPD:
+      naya = scheme_syntaxes_eval_clone(orig);
+      break;
+    default:
+      naya = orig;
+      break;
+    }
+
+    if (SAME_OBJ(orig, naya))
+      return expr;
+    
+    return scheme_make_syntax_resolved(kind, naya);
+  } else
+    return expr;
+}
+
+Resolve_Prefix *scheme_prefix_eval_clone(Resolve_Prefix *rp)
+{
+  Resolve_Prefix *naya;
+  Scheme_Object **tls;
+
+  if (!rp->num_toplevels)
+    return rp;
+
+  naya = MALLOC_ONE_TAGGED(Resolve_Prefix);
+  memcpy(naya, rp, sizeof(Resolve_Prefix));
+  
+  tls = MALLOC_N(Scheme_Object*, rp->num_toplevels);
+  memcpy(tls, rp->toplevels, sizeof(Scheme_Object *) * rp->num_toplevels);
+  naya->toplevels = tls;
+
+  return naya;
+}
+
 /*========================================================================*/
 /*        creating/pushing prefix for top-levels and syntax objects       */
 /*========================================================================*/
@@ -9725,7 +9823,7 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
     for (i = 0; i < rp->num_toplevels; i++) {
       v = rp->toplevels[i];
       if (genv)
-	v = link_toplevel(rp->toplevels[i], genv, src_modidx, now_modidx);
+	v = link_toplevel(rp->toplevels, i, genv, src_modidx, now_modidx);
       a[i] = v;
     }
 
@@ -9733,7 +9831,7 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
       i = rp->num_toplevels;
       v = scheme_stx_phase_shift_as_rename(now_phase - src_phase, src_modidx, now_modidx, 
 					   genv ? genv->export_registry : NULL);
-      if (v || rp->delay_info) {
+      if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) {
 	/* Put lazy-shift info in a[i]: */
         Scheme_Object **ls;
         ls = MALLOC_N(Scheme_Object *, 2);
@@ -9926,15 +10024,17 @@ int scheme_validate_rator_wants_box(Scheme_Object *app_rator, int pos,
                                     int num_toplevels, int num_stxes, int num_lifts)
 {
   Scheme_Closure_Data *data = NULL;
+  Scheme_Type ty;
 
   while (1) {
-    if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_closure_type)) {
+    ty = SCHEME_TYPE(app_rator);
+    if (SAME_TYPE(ty, scheme_closure_type)) {
       data = SCHEME_COMPILED_CLOS_CODE(app_rator);
       break;
-    } else if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_unclosed_procedure_type)) {
+    } else if (SAME_TYPE(ty, scheme_unclosed_procedure_type)) {
       data = (Scheme_Closure_Data *)app_rator;
       break;
-    } else if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_toplevel_type)) {
+    } else if (SAME_TYPE(ty, scheme_toplevel_type)) {
       int p;
       p = SCHEME_TOPLEVEL_POS(app_rator);
       while (1) {

src/mzscheme/src/module.c

@@ -3942,6 +3942,9 @@ void scheme_run_module_exptime(Scheme_Env *menv, int set_ns)
     for_stx = SCHEME_TRUEP(SCHEME_VEC_ELS(e)[4]);
     e = SCHEME_VEC_ELS(e)[1];
       
+    if (SCHEME_SYMBOLP(names))
+      names = scheme_make_pair(names, scheme_null);
+
     eval_exptime(names, scheme_list_length(names), e, exp_env, rhs_env,
                  rp, let_depth, 1, (for_stx ? for_stx_globals : syntax), for_stx,
                  NULL);
@@ -4602,7 +4605,7 @@ module_execute(Scheme_Object *data)
   return scheme_void;
 }
 
-static Scheme_Object *rebuild_et_vec(Scheme_Object *naya, Scheme_Object *vec)
+static Scheme_Object *rebuild_et_vec(Scheme_Object *naya, Scheme_Object *vec, Resolve_Prefix *rp)
 {
   Scheme_Object *vec2;
   int i;
@@ -4613,23 +4616,35 @@ static Scheme_Object *rebuild_et_vec(Scheme_Object *naya, Scheme_Object *vec)
     SCHEME_VEC_ELS(vec2)[i] = SCHEME_VEC_ELS(vec)[i];
   }
   SCHEME_VEC_ELS(vec2)[1] = naya;
+  SCHEME_VEC_ELS(vec2)[3] = (Scheme_Object *)rp;
 
   return vec2;
 }
 
-static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec)
+static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec, int jit)
 {
   Scheme_Object *orig, *naya = NULL;
+  Resolve_Prefix *orig_rp, *rp;
   int i, cnt;
 
   cnt = SCHEME_VEC_SIZE(orig_l);
   for (i = 0; i < cnt; i++) {
     orig = SCHEME_VEC_ELS(orig_l)[i];
-    if (in_vec)
+    if (in_vec) {
+      orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(orig)[3];
+      rp = scheme_prefix_eval_clone(orig_rp);
       orig = SCHEME_VEC_ELS(orig)[1];
+    } else {
+      orig_rp = rp = NULL;
+    }
 
+    if (jit)
       naya = scheme_jit_expr(orig);
-    if (!SAME_OBJ(orig, naya))
+    else
+      naya = orig;
+
+    if (!SAME_OBJ(orig, naya)
+        || !SAME_OBJ(orig_rp, rp))
       break;
   }
 
@@ -4641,16 +4656,27 @@ static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec)
       SCHEME_VEC_ELS(new_l)[j] = SCHEME_VEC_ELS(orig_l)[j];
     }
     if (in_vec)
-      naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i]);
+      naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i], rp);
     SCHEME_VEC_ELS(new_l)[i] = naya;
     for (i++; i < cnt; i++) {
       orig = SCHEME_VEC_ELS(orig_l)[i];
-      if (in_vec)
-        orig = SCHEME_VEC_ELS(orig)[1];
-      naya = scheme_jit_expr(orig);
       if (in_vec) {
-	if (!SAME_OBJ(orig, naya))
+        orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(orig)[3];
-	  naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i]);
+        rp = scheme_prefix_eval_clone(orig_rp);
+        orig = SCHEME_VEC_ELS(orig)[1];        
+      } else {
+        orig_rp = rp = NULL;
+      }
+
+      if (jit)
+        naya = scheme_jit_expr(orig);
+      else
+        naya = orig;
+
+      if (in_vec) {
+	if (!SAME_OBJ(orig, naya)
+            || !SAME_OBJ(rp, orig_rp))
+	  naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i], rp);
 	else
 	  naya = SCHEME_VEC_ELS(orig_l)[i];
       }
@@ -4661,25 +4687,44 @@ static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec)
     return orig_l;
 }
 
-static Scheme_Object *module_jit(Scheme_Object *data)
+static Scheme_Object *do_module_clone(Scheme_Object *data, int jit)
 {
   Scheme_Module *m = (Scheme_Module *)data;
   Scheme_Object *l1, *l2;
+  Resolve_Prefix *rp;
   
-  l1 = jit_vector(m->body, 0);
+  rp = scheme_prefix_eval_clone(m->prefix);
-  l2 = jit_vector(m->et_body, 1);
 
-  if (SAME_OBJ(l1, m->body) && SAME_OBJ(l2, m->body))
+  if (jit)
+    l1 = jit_vector(m->body, 0, jit);
+  else
+    l1 = m->body;
+  l2 = jit_vector(m->et_body, 1, jit);
+
+  if (SAME_OBJ(l1, m->body) 
+      && SAME_OBJ(l2, m->body)
+      && SAME_OBJ(rp, m->prefix))
     return data;
   
   m = MALLOC_ONE_TAGGED(Scheme_Module);
   memcpy(m, data, sizeof(Scheme_Module));
   m->body = l1;
   m->et_body = l2;
+  m->prefix = rp;
 
   return (Scheme_Object *)m;
 }
 
+static Scheme_Object *module_jit(Scheme_Object *data)
+{
+  return do_module_clone(data, 1);
+}
+
+Scheme_Object *scheme_module_eval_clone(Scheme_Object *data)
+{
+  return do_module_clone(data, 0);
+}
+
 static void module_validate(Scheme_Object *data, Mz_CPort *port, 
                             char *stack, Validate_TLS tls,
 			    int depth, int letlimit, int delta, 
@@ -6115,7 +6160,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
 
 	  /* Add code with names and lexical depth to exp-time body: */
 	  vec = scheme_make_vector(5, NULL);
-	  SCHEME_VEC_ELS(vec)[0] = names;
+	  SCHEME_VEC_ELS(vec)[0] = ((SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names)))
+                                    ? SCHEME_CAR(names)
+                                    : names);
 	  SCHEME_VEC_ELS(vec)[1] = m;
 	  SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(ri->max_let_depth);
 	  SCHEME_VEC_ELS(vec)[3] = (Scheme_Object *)rp;
@@ -6125,6 +6172,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
           m = scheme_sfs(m, NULL, ri->max_let_depth);
 	  if (ri->use_jit)
 	    m = scheme_jit_expr(m);
+          rp = scheme_prefix_eval_clone(rp);
 	
 	  eval_exptime(names, count, m, eenv->genv, rhs_env, rp, ri->max_let_depth, 0, 
                        (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx,

src/mzscheme/src/mzmark.c

@@ -2191,7 +2191,7 @@ static int resolve_prefix_val_MARK(void *p) {
   Resolve_Prefix *rp = (Resolve_Prefix *)p;
   gcMARK(rp->toplevels);
   gcMARK(rp->stxes);
-  gcMARK(rp->delay_info);
+  gcMARK(rp->delay_info_rpair);
 
   return
   gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));
@@ -2201,7 +2201,7 @@ static int resolve_prefix_val_FIXUP(void *p) {
   Resolve_Prefix *rp = (Resolve_Prefix *)p;
   gcFIXUP(rp->toplevels);
   gcFIXUP(rp->stxes);
-  gcFIXUP(rp->delay_info);
+  gcFIXUP(rp->delay_info_rpair);
 
   return
   gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));

src/mzscheme/src/mzmarksrc.c

@@ -870,7 +870,7 @@ resolve_prefix_val {
   Resolve_Prefix *rp = (Resolve_Prefix *)p;
   gcMARK(rp->toplevels);
   gcMARK(rp->stxes);
-  gcMARK(rp->delay_info);
+  gcMARK(rp->delay_info_rpair);
 
  size:
   gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));

src/mzscheme/src/print.c

@@ -2358,8 +2358,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
         symtab_set(pp, mt, obj);
       }
     }
-  else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_module_variable_type)
+  else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_module_variable_type))
-	   && !((Module_Variable *)obj)->mod_phase)
     {
       Scheme_Object *idx;
 
@@ -2378,6 +2377,10 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
           print(mv->modidx, notdisplay, 1, ht, mt, pp);
         }
 	print(mv->sym, notdisplay, 1, ht, mt, pp);
+        if (((Module_Variable *)obj)->mod_phase) {
+          /* mod_phase must be 1 */
+          print_compact_number(pp, -2);
+        }
         print_compact_number(pp, mv->pos);
 
         symtab_set(pp, mt, obj);

src/mzscheme/src/read.c

@@ -4357,7 +4357,7 @@ static Scheme_Object *read_compact_svector(CPort *port, int l)
   return o;
 }
 
-static int cpt_branch[256];
+static unsigned char cpt_branch[256];
 
 static Scheme_Object *read_compact(CPort *port, int use_stack);
 
@@ -4377,8 +4377,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
   unsigned int l;
   char *s, buffer[BLK_BUF_SIZE];
   int ch;
-  int need_car = 0, proper = 0;
+  Scheme_Object *v;
-  Scheme_Object *v, *first = NULL, *last = NULL;
 
 #ifdef DO_STACK_CHECK
   {
@@ -4392,7 +4391,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
   }
 #endif
 
-  while (1) {
+  {
     ZO_CHECK(port->pos < port->size);
     ch = CP_GETC(port);
 
@@ -4530,19 +4529,15 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
       SCHEME_SET_IMMUTABLE(v);
       break;
     case CPT_PAIR:
-      if (need_car) {
+      {
 	Scheme_Object *car, *cdr;
 	car = read_compact(port, 0);
 	cdr = read_compact(port, 0);
 	v = scheme_make_pair(car, cdr);
-      } else {
-	need_car = 1;
-	continue;
       }
       break;
     case CPT_LIST:
       l = read_compact_number(port);
-      if (need_car) {
       if (l == 1) {
         Scheme_Object *car, *cdr;
         car = read_compact(port, 0);
@@ -4550,10 +4545,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
         v = scheme_make_pair(car, cdr);
       } else
         v = read_compact_list(l, 0, 0, port);
-      } else {
-	need_car = l;
-	continue;
-      }
       break;
     case CPT_VECTOR:
       {
@@ -4761,6 +4752,11 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
 	mv->modidx = mod;
 	mv->insp = port->insp;
 	mv->sym = var;
+        if (pos == -2) {
+          mv->mod_phase = 1;
+          pos = read_compact_number(port);
+          mv->pos = pos;
+        } else
           mv->pos = pos;
 
 	v = (Scheme_Object *)mv;
@@ -4887,7 +4883,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
       {
 	int ppr = CPT_BETWEEN(ch, SMALL_PROPER_LIST);
 	l = ch - (ppr ? CPT_SMALL_PROPER_LIST_START : CPT_SMALL_LIST_START);
-      	if (need_car) {
       	if (l == 1) {
           Scheme_Object *car, *cdr;
           car = read_compact(port, 0);
@@ -4897,11 +4892,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
           v = scheme_make_pair(car, cdr);
         } else
           v = read_compact_list(l, ppr, /* use_stack */ 0, port);
-	} else {
-	  proper = ppr;
-	  need_car = l;
-	  continue;
-	}
       }
       break;
     case CPT_SMALL_APPLICATION_START:
@@ -4975,28 +4965,9 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
 
     if (!v)
       scheme_ill_formed_code(port);
-
-    if (need_car) {
-      Scheme_Object *pair;
-
-      pair = scheme_make_pair(v, scheme_null);
-
-      if (last)
-	SCHEME_CDR(last) = pair;
-      else
-	first = pair;
-      last = pair;
-      --need_car;
-      if (!need_car && proper)
-	break;
-    } else {
-      if (last)
-	SCHEME_CDR(last) = v;
-      break;
-    }
   }
 
-  return first ? first : v;
+  return v;
 }
 
 static Scheme_Object *read_compact_list(int c, int proper, int use_stack, CPort *port)

src/mzscheme/src/schpriv.h

@@ -1863,8 +1863,7 @@ typedef struct Resolve_Prefix
   int num_toplevels, num_stxes, num_lifts;
   Scheme_Object **toplevels;
   Scheme_Object **stxes; /* simplified */
-  int delay_refcount;
+  Scheme_Object *delay_info_rpair; /* (rcons refcount Scheme_Load_Delay*) */
-  struct Scheme_Load_Delay *delay_info;
 } Resolve_Prefix;
 
 typedef struct Resolve_Info
@@ -2394,6 +2393,11 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
 				   int src_phase, int now_phase);
 void scheme_pop_prefix(Scheme_Object **rs);
 
+Scheme_Object *scheme_eval_clone(Scheme_Object *expr);
+Resolve_Prefix *scheme_prefix_eval_clone(Resolve_Prefix *rp);
+Scheme_Object *scheme_module_eval_clone(Scheme_Object *data);
+Scheme_Object *scheme_syntaxes_eval_clone(Scheme_Object *form);
+
 Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env);
 Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy);
 

src/mzscheme/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "4.1.3.5"
+#define MZSCHEME_VERSION "4.1.3.6"
 
 #define MZSCHEME_VERSION_X 4
 #define MZSCHEME_VERSION_Y 1
 #define MZSCHEME_VERSION_Z 3
-#define MZSCHEME_VERSION_W 5
+#define MZSCHEME_VERSION_W 6
 
 #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

@@ -1823,12 +1823,18 @@ Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename)
 void scheme_load_delayed_syntax(struct Resolve_Prefix *rp, long i)
 {
   Scheme_Object *stx;
+  int c;
+
   stx = scheme_load_delayed_code(SCHEME_INT_VAL(rp->stxes[i]),
-                                 rp->delay_info);
+                                 (struct Scheme_Load_Delay *)SCHEME_CDR(rp->delay_info_rpair));
   rp->stxes[i] = stx;
-  --rp->delay_refcount;
+  c = SCHEME_INT_VAL(SCHEME_CAR(rp->delay_info_rpair));
-  if (!rp->delay_refcount)
+  --c;
-    rp->delay_info = NULL;
+  SCHEME_CAR(rp->delay_info_rpair) = scheme_make_integer(c);
+  if (!c) {
+    SCHEME_CDR(rp->delay_info_rpair) = NULL;
+    rp->delay_info_rpair = NULL;
+  } 
 }
 
 Scheme_Object *scheme_delayed_rename(Scheme_Object **o, long i)

src/mzscheme/src/syntax.c

@@ -5294,29 +5294,44 @@ define_for_syntaxes_execute(Scheme_Object *form)
   return do_define_syntaxes_execute(form, NULL, 1);
 }
 
-static Scheme_Object *do_define_syntaxes_jit(Scheme_Object *expr)
+static Scheme_Object *do_define_syntaxes_jit(Scheme_Object *expr, int jit)
 {
-  Scheme_Object *naya;
+  Resolve_Prefix *rp, *orig_rp;
+  Scheme_Object *naya, *rhs;
   
-  naya = scheme_jit_expr(SCHEME_VEC_ELS(expr)[0]);
+  rhs = SCHEME_VEC_ELS(expr)[0];
+  if (jit)
+    naya = scheme_jit_expr(rhs);
+  else
+    naya = rhs;
 
-  if (SAME_OBJ(naya, expr))
+  orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1];
+  rp = scheme_prefix_eval_clone(orig_rp);
+  
+  if (SAME_OBJ(naya, rhs)
+      && SAME_OBJ(orig_rp, rp))
     return expr;
   else {
     expr = clone_vector(expr, 0);
     SCHEME_VEC_ELS(expr)[0] = naya;
+    SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp;
     return expr;
   }
 }
 
 static Scheme_Object *define_syntaxes_jit(Scheme_Object *expr)
 {
-  return do_define_syntaxes_jit(expr);
+  return do_define_syntaxes_jit(expr, 1);
 }
 
 static Scheme_Object *define_for_syntaxes_jit(Scheme_Object *expr)
 {
-  return do_define_syntaxes_jit(expr);
+  return do_define_syntaxes_jit(expr, 1);
+}
+
+Scheme_Object *scheme_syntaxes_eval_clone(Scheme_Object *expr)
+{
+  return do_define_syntaxes_jit(expr, 0);
 }
 
 static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, 
@@ -5611,10 +5626,9 @@ define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Exp
 Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env)
 { 
   /* Get a prefixed-based accessor for a dummy top-level bucket. It's
-     used to "link" to the right environment at run time. The `begin'
+     used to "link" to the right environment at run time. The #f as
-     symbol is arbitrary; the top-level/prefix support handles a symbol
+     a toplevel is handled in the prefix linker specially. */
-     as a "toplevel" specially. */
+  return scheme_register_toplevel_in_prefix(scheme_false, env, NULL, 0);
-  return scheme_register_toplevel_in_prefix(begin_symbol, env, NULL, 0);
 }
 
 Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy)

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.5" 
+version="4.1.3.6" 
 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,5
+ FILEVERSION 4,1,3,6
- PRODUCTVERSION 4,1,3,5
+ PRODUCTVERSION 4,1,3,6
  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, 5\0"
+            VALUE "FileVersion", "4, 1, 3, 6\0"
             VALUE "LegalCopyright", "Copyright © 1995-2008\0"
             VALUE "OriginalFilename", "MrEd.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 3, 5\0"
+            VALUE "ProductVersion", "4, 1, 3, 6\0"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/mzcom/mzcom.rc

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

src/worksp/mzcom/mzobj.rgs

@@ -1,19 +1,19 @@
 HKCR
 {
-	MzCOM.MzObj.4.1.3.5 = s 'MzObj Class'
+	MzCOM.MzObj.4.1.3.6 = 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.5'
+		CurVer = s 'MzCOM.MzObj.4.1.3.6'
 	}
 	NoRemove CLSID
 	{
 		ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
 		{
-			ProgID = s 'MzCOM.MzObj.4.1.3.5'
+			ProgID = s 'MzCOM.MzObj.4.1.3.6'
 			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,5
+ FILEVERSION 4,1,3,6
- PRODUCTVERSION 4,1,3,5
+ PRODUCTVERSION 4,1,3,6
  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, 5\0"
+            VALUE "FileVersion", "4, 1, 3, 6\0"
             VALUE "LegalCopyright", "Copyright <20>© 1995-2008\0"
             VALUE "OriginalFilename", "mzscheme.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 3, 5\0"
+            VALUE "ProductVersion", "4, 1, 3, 6\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,5
+ FILEVERSION 4,1,3,6
- PRODUCTVERSION 4,1,3,5
+ PRODUCTVERSION 4,1,3,6
  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, 5\0"
+            VALUE "FileVersion", "4, 1, 3, 6\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, 5\0"
+            VALUE "ProductVersion", "4, 1, 3, 6\0"
         END
     END
     BLOCK "VarFileInfo"