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)
-                    (match v
-                      [(list* phase modname varname)
-                       (values phase modname varname)]
-                      [(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)))))
+      (error "expected a symbol")))
+
+(define (do-not-read-variable v)
+  (error "should not get here"))
 
 (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
-           (with-syntax ([(?formals . ?body) renames])
-             #'?formals)
-           null)]
+       (when renames
+         (with-syntax ([(?formals . ?body) renames])
+           (add #'?formals)))]
       [(Wrap clc (_ renames _))
-       (if renames
-           (with-syntax ([(?formals . ?body) renames])
-             #'?formals)
-           null)]
+       (when renames
+         (with-syntax ([(?formals . ?body) renames])
+           (add #'?formals)))]
       [(Wrap p:let-values (e1 e2 rs ?1 renames rhss body))
-       (if renames
-           (with-syntax ([(((?vars ?rhs) ...) . ?body) renames])
-             #'(?vars ...))
-           null)]
+       (when renames
+         (with-syntax ([(((?vars ?rhs) ...) . ?body) renames])
+           (add #'(?vars ...))))]
       [(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body))
-       (if renames
-           (with-syntax ([(((?vars ?rhs) ...) . ?body) renames])
-             #'(?vars ...))
-           null)]
-      [(Wrap p:letrec-syntaxes+values (e1 e2 rs ?1 srenames srhss vrenames vrhss body _))
-       (cons
-        (if srenames
-            (with-syntax ([(((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body)
-                           srenames])
-              #'(?svars ... ?vvars ...))
-            null)
-        (if vrenames
-            (with-syntax ([(((?vvars ?vrhs) ...) . ?body) vrenames])
-              #'(?vvars ...))
-            null))]
+       (when renames
+         (with-syntax ([(((?vars ?rhs) ...) . ?body) renames])
+           (add #'(?vars ...))))]
+      [(Wrap p:letrec-syntaxes+values (e1 e2 rs ?1 srenames srhss vrenames _ _ _))
+       (when srenames
+         (with-syntax ([(((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body)
+                        srenames])
+           (add #'(?svars ... ?vvars ...))))
+       (when vrenames
+         (with-syntax ([(((?vvars ?vrhs) ...) . ?body) vrenames])
+           (add #'(?vvars ...))))]
       [(Wrap b:defvals (rename head ?1 rename2 ?2))
        (let ([head-e2 (wderiv-e2 head)])
-         (if head-e2
-             (with-syntax ([(?dv ?vars ?rhs) head-e2])
-               #'?vars)
-             null))]
+         (when head-e2
+           (with-syntax ([(?dv ?vars ?rhs) head-e2])
+             (add #'?vars))))]
       [(Wrap b:defstx (rename head ?1 rename2 ?2 rhs))
        (let ([head-e2 (wderiv-e2 head)])
-         (if head-e2
-             (with-syntax ([(?ds ?svars ?rhs) head-e2])
-               #'?svars)
-             null))]
+         (when head-e2
+           (with-syntax ([(?ds ?svars ?rhs) head-e2])
+             (add #'?svars))))]
       [(Wrap p:define-values (e1 e2 rs ?1 rhs))
-       (if rhs
-           (with-syntax ([(?dv ?vars ?rhs) e1])
-             #'?vars)
-           null)]
+       (when rhs
+         (with-syntax ([(?dv ?vars ?rhs) e1])
+           (add #'?vars)))]
       [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs _))
-       (if rhs
-           (with-syntax ([(?ds ?svars ?srhs) e1])
-             #'?svars)
-           null)]
-      [_ null]))
+       (when rhs
+         (with-syntax ([(?ds ?svars ?srhs) e1])
+           (add #'?svars)))]
+      [_ (void)]))
+  (define renaming-forms
+    (find-deriv/unit+join+zero renaming-node?
+                               (lambda (d) #f)
+                               d
+                               list
+                               append
+                               null))
+  (for ([rf renaming-forms])
+    (extract-fresh-names rf))
+  (hash-map ht (lambda (k v) k)))
 
-  (let ([all-renaming-forms
-         (find-deriv/unit+join+zero
-          renaming-node?
-          (lambda (d) #f)
-          d
-          list
-          append
-          null)])
-    (flatten-identifiers (map extract-fresh-names all-renaming-forms))))
+;; 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

@@ -75,22 +75,32 @@
 
     ;; get-range : -> range<%>
     (define/public (get-range) range)
-    
+
     ;; 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))
-                  stxs))
+        (for ([stx 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
-       extra-styles
-       (lambda (hi-stx style-delta)
-         (let ([rs (send range get-ranges hi-stx)])
-           (for-each (lambda (r) (restyle-range r style-delta)) rs)))))
+      (for ([(stx style-deltas) extra-styles])
+        (for ([r (send range get-ranges stx)])
+          (for ([style-delta style-deltas])
+            (restyle-range r style-delta)))))
 
     ;; 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,363 +1,359 @@
 
-(module syntax-snip mzscheme
-  (require mzlib/class
-           mred
-           framework
-           mzlib/match
-           mzlib/list
-           mzlib/string
-           "../util/notify.ss"
-           "interfaces.ss"
-           "display.ss"
-           "controller.ss"
-           "keymap.ss"
-           "properties.ss"
-           "partition.ss"
-           "prefs.ss")
+#lang scheme/base
+(require scheme/class
+         scheme/match
+         scheme/list
+         mzlib/string
+         mred
+         framework
+         "../util/notify.ss"
+         "interfaces.ss"
+         "display.ss"
+         "controller.ss"
+         "keymap.ss"
+         "properties.ss"
+         "partition.ss"
+         "prefs.ss")
 
-  (provide syntax-snip%
-           syntax-value-snip%)
+(provide syntax-snip%
+         syntax-value-snip%)
 
-  (define syntax-snip-config-base%
-    (class object%
-      (notify-methods props-shown?)
-      (super-new)))
-  (define syntax-snip-config%
-    (class syntax-snip-config-base%
-      (define/override (init-props-shown?) (new notify-box% (value #f)))
-      (super-new)))
+(define syntax-snip-config-base%
+  (class prefs-base%
+    (notify-methods props-shown?)
+    (super-new)))
 
-  (define dumb-host%
-    (class object%
-      (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))))))
+(define syntax-snip-config%
+  (class syntax-snip-config-base%
+    (define/override (init-props-shown?) (new notify-box% (value #f)))
+    (super-new)))
 
-  ;; syntax-value-snip%
-  (define syntax-value-snip%
-    (class* editor-snip% (readable-snip<%>)
-      (init-field ((stx syntax)))
-      (init-field (host (new dumb-host%)))
-      (inherit set-margin
-               set-inset)
+;; syntax-value-snip%
+(define syntax-value-snip%
+  (class* editor-snip% (readable-snip<%>)
+    (init-field ((stx syntax)))
+    (init-field (controller (new controller%)))
+    (init-field (config (new syntax-snip-config%)))
 
-      (define text (new text:standard-style-list%))
-      (super-new (editor text) (with-border? #f))
+    (inherit set-margin
+             set-inset)
 
-      (set-margin 0 0 0 0)
-      ;;(set-inset 2 2 2 2)
-      ;;(set-margin 2 2 2 2)
-      (set-inset 0 0 0 0)
+    (define text (new text:standard-style-list%))
+    (super-new (editor text) (with-border? #f))
 
-      (send text begin-edit-sequence)
-      (send text change-style (make-object style-delta% 'change-alignment 'top))
-      (define display
-        (print-syntax-to-editor stx text
-                                (send host get-controller)
-                                (send host get-config)))
-      (send text lock #t)
-      (send text end-edit-sequence)
-      (send text hide-caret #t)
+    (set-margin 0 0 0 0)
+    ;;(set-inset 2 2 2 2)
+    ;;(set-margin 2 2 2 2)
+    (set-inset 0 0 0 0)
 
-      (send host add-keymap text this)
+    (send text begin-edit-sequence)
+    (send text change-style (make-object style-delta% 'change-alignment 'top))
+    (define display
+      (print-syntax-to-editor stx text controller config))
+    (send text lock #t)
+    (send text end-edit-sequence)
+    (send text hide-caret #t)
 
-      ;; snip% Methods
-      (define/override (copy)
-        (new syntax-value-snip% (host host) (syntax stx)))
+    (setup-keymap text)
 
-      ;; read-special : any number/#f number/#f number/#f -> syntax
-      ;; Produces 3D syntax to preserve eq-ness of syntax
-      ;; #'#'stx would be lose identity when wrapped
-      (define/public (read-special src line col pos)
-        (with-syntax ([p (lambda () stx)])
-          #'(p)))
-      ))
+    (define/public (setup-keymap text)
+      (new syntax-keymap%
+           (controller controller)
+           (config config)
+           (editor text)))
 
-  (define top-aligned
-    (make-object style-delta% 'change-alignment 'top))
+    ;; snip% Methods
+    (define/override (copy)
+      (new syntax-value-snip%
+           (config config)
+           (controller controller)
+           (syntax stx)))
 
-  (define-struct styled (contents style clickback))
+    ;; read-special : any number/#f number/#f number/#f -> syntax
+    ;; Produces 3D syntax to preserve eq-ness of syntax
+    ;; #'#'stx would be lose identity when wrapped
+    (define/public (read-special src line col pos)
+      (with-syntax ([p (lambda () stx)])
+        #'(p)))
+    ))
 
-  ;; clicky-snip%
-  (define clicky-snip%
-    (class* editor-snip% ()
+(define top-aligned
+  (make-object style-delta% 'change-alignment 'top))
 
-      (init-field [open-style '(border)]
-                  [closed-style '(tight-text-fit)])
+(define-struct styled (contents style clickback))
 
-      (inherit set-margin
-               set-inset
-               set-snipclass
-               set-tight-text-fit
-               show-border
-               get-admin)
+;; clicky-snip%
+(define clicky-snip%
+  (class* editor-snip% ()
 
-      (define -outer (new text%))
-      (super-new (editor -outer) (with-border? #f))
-      (set-margin 2 2 2 2)
-      (set-inset 2 2 2 2)
-      ;;(set-margin 3 0 0 0)
-      ;;(set-inset 1 0 0 0)
-      ;;(set-margin 0 0 0 0)
-      ;;(set-inset 0 0 0 0)
+    (init-field [open-style '(border)]
+                [closed-style '(tight-text-fit)])
 
-      (define/public (closed-contents) null)
-      (define/public (open-contents) null)
+    (inherit set-margin
+             set-inset
+             set-snipclass
+             set-tight-text-fit
+             show-border
+             get-admin)
 
-      (define open? #f)
+    (define -outer (new text%))
+    (super-new (editor -outer) (with-border? #f))
+    (set-margin 2 2 2 2)
+    (set-inset 2 2 2 2)
+    ;;(set-margin 3 0 0 0)
+    ;;(set-inset 1 0 0 0)
+    ;;(set-margin 0 0 0 0)
+    ;;(set-inset 0 0 0 0)
 
-      (define/public (refresh-contents)
-        (send* -outer
-          (begin-edit-sequence)
-          (lock #f)
-          (erase))
-        (do-style (if open? open-style closed-style))
-        (outer:insert (if open? (hide-icon) (show-icon))
-                      style:hyper
-                      (if open?
-                          (lambda _
-                            (set! open? #f)
-                            (refresh-contents))
-                          (lambda _
-                            (set! open? #t)
-                            (refresh-contents))))
-        (for-each (lambda (s) (outer:insert s))
-                  (if open? (open-contents) (closed-contents)))
-        (send* -outer
-          (change-style top-aligned 0 (send -outer last-position))
-          (lock #t)
-          (end-edit-sequence)))
+    (define/public (closed-contents) null)
+    (define/public (open-contents) null)
 
-      (define/private (do-style style)
-        (show-border (memq 'border style))
-        (set-tight-text-fit (memq 'tight-text-fit style)))
+    (define open? #f)
 
-      (define/private outer:insert
-        (case-lambda
-         [(obj)
-          (if (styled? obj)
-              (outer:insert (styled-contents obj)
-                            (styled-style obj)
-                            (styled-clickback obj))
-              (outer:insert obj style:normal))]
-         [(text style)
-          (outer:insert text style #f)]
-         [(text style clickback)
-          (let ([start (send -outer last-position)])
-            (send -outer insert text)
-            (let ([end (send -outer last-position)])
-              (send -outer change-style style start end #f)
-              (when clickback
-                    (send -outer set-clickback start end clickback))))]))
+    (define/public (refresh-contents)
+      (send* -outer
+        (begin-edit-sequence)
+        (lock #f)
+        (erase))
+      (do-style (if open? open-style closed-style))
+      (outer:insert (if open? (hide-icon) (show-icon))
+                    style:hyper
+                    (if open?
+                        (lambda _
+                          (set! open? #f)
+                          (refresh-contents))
+                        (lambda _
+                          (set! open? #t)
+                          (refresh-contents))))
+      (for-each (lambda (s) (outer:insert s))
+                (if open? (open-contents) (closed-contents)))
+      (send* -outer
+        (change-style top-aligned 0 (send -outer last-position))
+        (lock #t)
+        (end-edit-sequence)))
 
-      (send -outer hide-caret #t)
-      (send -outer lock #t)
-      (refresh-contents)
-      ))
+    (define/private (do-style style)
+      (show-border (memq 'border style))
+      (set-tight-text-fit (memq 'tight-text-fit style)))
 
-  ;; syntax-snip%
-  (define syntax-snip%
-    (class* clicky-snip% (readable-snip<%>)
-      (init-field ((stx syntax)))
-      (init-field (host (new dumb-host%)))
-      (define config (send host get-config))
-      (inherit set-snipclass
-               refresh-contents)
+    (define/private outer:insert
+      (case-lambda
+       [(obj)
+        (if (styled? obj)
+            (outer:insert (styled-contents obj)
+                          (styled-style obj)
+                          (styled-clickback obj))
+            (outer:insert obj style:normal))]
+       [(text style)
+        (outer:insert text style #f)]
+       [(text style clickback)
+        (let ([start (send -outer last-position)])
+          (send -outer insert text)
+          (let ([end (send -outer last-position)])
+            (send -outer change-style style start end #f)
+            (when clickback
+                  (send -outer set-clickback start end clickback))))]))
 
-      (define the-syntax-snip
-        (new syntax-value-snip%
-             (syntax stx)
-             (host host)))
-      (define the-summary
-        (let* ([t (new text%)]
-               [es (new editor-snip% (editor t) (with-border? #f))])
-          (send es set-margin 0 0 0 0)
-          (send es set-inset 0 0 0 0)
-          (send t insert (format "~s" stx))
-          es))
+    (send -outer hide-caret #t)
+    (send -outer lock #t)
+    (refresh-contents)
+    ))
 
-      (define properties-snip
-        (new properties-container-snip%
-             (controller (send host get-controller))))
+;; syntax-snip%
+(define syntax-snip%
+  (class* clicky-snip% (readable-snip<%>)
+    (init-field ((stx syntax)))
+    (init-field [controller (new controller%)])
+    (init-field [config (new syntax-snip-config%)])
 
-      (define/override (closed-contents)
-        (list the-summary))
+    (inherit set-snipclass
+             refresh-contents)
 
-      (define/override (open-contents)
-        (list " "
-              the-syntax-snip
-              " "
-              properties-snip))
+    (define the-syntax-snip
+      (new syntax-value-snip%
+           (syntax stx)
+           (controller controller)
+           (config config)))
+    (define the-summary
+      (let* ([t (new text%)]
+             [es (new editor-snip% (editor t) (with-border? #f))])
+        (send es set-margin 0 0 0 0)
+        (send es set-inset 0 0 0 0)
+        (send t insert (format "~s" stx))
+        es))
 
-      ;; Snip methods
-      (define/override (copy)
-        (new syntax-snip% (syntax stx)))
-      (define/override (write stream)
-        (send stream put
-              (string->bytes/utf-8
-               (format "~s" (marshall-syntax stx)))))
-      (define/public (read-special src line col pos)
-        (send the-syntax-snip read-special src line col pos))
+    (define properties-snip
+      (new properties-container-snip%
+           (controller controller)))
 
-      (send config listen-props-shown?
-            (lambda (?) (refresh-contents)))
+    (define/override (closed-contents)
+      (list the-summary))
 
-      (super-new)
-      (set-snipclass snip-class)))
+    (define/override (open-contents)
+      (list " "
+            the-syntax-snip
+            " "
+            properties-snip))
 
+    ;; Snip methods
+    (define/override (copy)
+      (new syntax-snip% (syntax stx)))
+    (define/override (write stream)
+      (send stream put
+            (string->bytes/utf-8
+             (format "~s" (marshall-syntax stx)))))
+    (define/public (read-special src line col pos)
+      (send the-syntax-snip read-special src line col pos))
 
-  (define properties-container-snip%
-    (class clicky-snip%
-      (init controller)
+    (send config listen-props-shown?
+          (lambda (?) (refresh-contents)))
 
-      (define properties-snip
-        (new properties-snip% (controller controller)))
+    (super-new)
+    (set-snipclass snip-class)
+    ))
 
-      (define/override (open-contents)
-        (list #;(show-properties-icon)
-              properties-snip))
+(define properties-container-snip%
+  (class clicky-snip%
+    (init controller)
 
-      (define/override (closed-contents)
-        (list (show-properties-icon)))
+    (define properties-snip
+      (new properties-snip% (controller controller)))
 
-      (super-new (open-style '())
-                 (closed-style '()))))
+    (define/override (open-contents)
+      (list #;(show-properties-icon)
+            properties-snip))
 
-  (define style:normal (make-object style-delta% 'change-normal))
-  (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
-    (let ([s (make-object style-delta% 'change-normal)])
-      (send s set-delta-foreground "darkgreen")
-      s))
-  (define style:bold
-    (let ([s (make-object style-delta% 'change-normal)])
-      (send s set-delta 'change-bold)
-      s))
+    (define/override (closed-contents)
+      (list (show-properties-icon)))
 
-  (define (show-icon)
-    (make-object image-snip%
-      (build-path (collection-path "icons") "turn-up.png")))
-  (define (hide-icon)
-    (make-object image-snip%
-      (build-path (collection-path "icons") "turn-down.png")))
+    (super-new (open-style '())
+               (closed-style '()))))
 
-  (define (show-properties-icon)
-    (make-object image-snip%
-      (build-path (collection-path "icons") "syncheck.png")))
+(define style:normal (make-object style-delta% 'change-normal))
+(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
+  (let ([s (make-object style-delta% 'change-normal)])
+    (send s set-delta-foreground "darkgreen")
+    s))
+(define style:bold
+  (let ([s (make-object style-delta% 'change-normal)])
+    (send s set-delta 'change-bold)
+    s))
 
-  ;; marshall-syntax : syntax -> printable
-  (define (marshall-syntax stx)
-    (unless (syntax? stx)
-      (error 'marshall-syntax "not syntax: ~s\n" stx))
-    `(syntax
-      (source ,(marshall-object (syntax-source stx)))
-      (source-module ,(marshall-object (syntax-source-module stx)))
-      (position ,(syntax-position stx))
-      (line ,(syntax-line stx))
-      (column ,(syntax-column stx))
-      (span ,(syntax-span stx))
-      (original? ,(syntax-original? stx))
-      (properties 
-       ,@(map (λ (x) `(,x ,(marshall-object (syntax-property stx x))))
-              (syntax-property-symbol-keys stx)))
-      (contents
-       ,(marshall-object (syntax-e stx)))))
+(define (show-icon)
+  (make-object image-snip%
+    (build-path (collection-path "icons") "turn-up.png")))
+(define (hide-icon)
+  (make-object image-snip%
+    (build-path (collection-path "icons") "turn-down.png")))
 
-  ;; marshall-object : any -> printable
-  ;; really only intended for use with marshall-syntax
-  (define (marshall-object obj)
-    (cond
-      [(syntax? obj) (marshall-syntax obj)]
-      [(pair? obj) 
-       `(pair ,(cons (marshall-object (car obj))
-                     (marshall-object (cdr obj))))]
-      [(or (symbol? obj)
-           (char? obj)
-           (number? obj)
-           (string? obj)
-           (boolean? obj)
-           (null? obj))
-       `(other ,obj)]
-      [else (string->symbol (format "unknown-object: ~s" obj))]))
+(define (show-properties-icon)
+  (make-object image-snip%
+    (build-path (collection-path "icons") "syncheck.png")))
 
-  ;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
-  (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 ())))
+;; marshall-syntax : syntax -> printable
+(define (marshall-syntax stx)
+  (unless (syntax? stx)
+    (error 'marshall-syntax "not syntax: ~s\n" stx))
+  `(syntax
+    (source ,(marshall-object (syntax-source stx)))
+    (source-module ,(marshall-object (syntax-source-module stx)))
+    (position ,(syntax-position stx))
+    (line ,(syntax-line stx))
+    (column ,(syntax-column stx))
+    (span ,(syntax-span stx))
+    (original? ,(syntax-original? stx))
+    (properties 
+     ,@(map (λ (x) `(,x ,(marshall-object (syntax-property stx x))))
+            (syntax-property-symbol-keys stx)))
+    (contents
+     ,(marshall-object (syntax-e stx)))))
 
-  (define snip-class (make-object syntax-snipclass%))
-  (send snip-class set-version 2)
-  (send snip-class set-classname
-        (format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser")))
-  (send (get-the-snip-class-list) add snip-class)
+;; marshall-object : any -> printable
+;; really only intended for use with marshall-syntax
+(define (marshall-object obj)
+  (cond
+    [(syntax? obj) (marshall-syntax obj)]
+    [(pair? obj) 
+     `(pair ,(cons (marshall-object (car obj))
+                   (marshall-object (cdr obj))))]
+    [(or (symbol? obj)
+         (char? obj)
+         (number? obj)
+         (string? obj)
+         (boolean? obj)
+         (null? obj))
+     `(other ,obj)]
+    [else (string->symbol (format "unknown-object: ~s" obj))]))
 
-  (define (unmarshall-syntax stx)
-    (match stx
-      [`(syntax
-         (source ,src)
-         (source-module ,source-module) ;; marshalling
-         (position ,pos)
-         (line ,line)
-         (column ,col)
-         (span ,span)
-         (original? ,original?)
-         (properties ,@(properties ...))
-         (contents ,contents))
-        (foldl
-         add-properties
-         (datum->syntax-object
-          #'here ;; ack
-          (unmarshall-object contents)
-          (list (unmarshall-object src)
-                line
-                col
-                pos
-                span))
-         properties)]
-      [else #'unknown-syntax-object]))
-  
-  ;; add-properties : syntax any -> syntax
-  (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)
-    (let ([unknown (lambda () (string->symbol (format "unknown: ~s" obj)))])
-      (if (and (pair? obj)
-               (symbol? (car obj)))
-          (case (car obj)
-            [(pair) 
-             (if (pair? (cdr obj))
-                 (let ([raw-obj (cadr obj)])
-                   (if (pair? raw-obj)
-                       (cons (unmarshall-object (car raw-obj))
-                             (unmarshall-object (cdr raw-obj)))
-                       (unknown)))
-                 (unknown))]
-            [(other) 
-             (if (pair? (cdr obj))
-                 (cadr obj)
-                 (unknown))]
-            [(syntax) (unmarshall-syntax obj)]
-            [else (unknown)])
-          (unknown))))
+;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
+(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%))
+(send snip-class set-version 2)
+(send snip-class set-classname
+      (format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser")))
+(send (get-the-snip-class-list) add snip-class)
+
+(define (unmarshall-syntax stx)
+  (match stx
+    [`(syntax
+       (source ,src)
+       (source-module ,source-module) ;; marshalling
+       (position ,pos)
+       (line ,line)
+       (column ,col)
+       (span ,span)
+       (original? ,original?)
+       (properties . ,properties)
+       (contents ,contents))
+      (foldl
+       add-properties
+       (datum->syntax
+        #'here ;; ack
+        (unmarshall-object contents)
+        (list (unmarshall-object src)
+              line
+              col
+              pos
+              span))
+       properties)]
+    [else #'unknown-syntax-object]))
+
+;; add-properties : syntax any -> syntax
+(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)
+  (let ([unknown (lambda () (string->symbol (format "unknown: ~s" obj)))])
+    (if (and (pair? obj)
+             (symbol? (car obj)))
+        (case (car obj)
+          [(pair) 
+           (if (pair? (cdr obj))
+               (let ([raw-obj (cadr obj)])
+                 (if (pair? raw-obj)
+                     (cons (unmarshall-object (car raw-obj))
+                           (unmarshall-object (cdr raw-obj)))
+                     (unknown)))
+               (unknown))]
+          [(other) 
+           (if (pair? (cdr obj))
+               (cadr obj)
+               (unknown))]
+          [(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
-      (lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]
-                      hi2-color [hi2-stxs null])
-        (define (get-binder id)
+    (define/public (add-syntax stx
+                               #:binder-table [alpha-table #f]
+                               #:shift-table [shift-table #f]
+                               #: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))
-          (error 'syntax-widget%::add-syntax "no highlight color specified"))
-        (let ([display (internal-add-syntax stx)]
-              [definite-table (make-hash-table)])
-          (when (and hi2-color (pair? hi2-stxs))
-            (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)
-          (when alpha-table
-            (let ([range (send display get-range)]
-                  [start (send display get-start-position)])
-              (define (adjust n) (+ start n))
-              (for-each
-               (lambda (id)
-                 #; ;; DISABLED
-                 (match (identifier-binding id)
-                   [(list src-mod src-name nom-mod nom-name _)
-                    (for-each (lambda (id-r)
-                                (send -text add-billboard
-                                      (adjust (car id-r))
-                                      (adjust (cdr id-r))
-                                      (string-append "from "
-                                                     (mpi->string src-mod))
-                                      (if (hash-table-get definite-table id #f)
-                                          "blue"
-                                          "purple")))
-                              (send range get-ranges id))]
-                   [_ (void)])
+        (if shift-table
+            (cons binder (hash-ref shift-table binder null))
+            (list binder)))
+      (let ([display (internal-add-syntax stx)]
+            [definite-table (make-hasheq)])
+        (for-each (lambda (hi-stxs hi-color)
+                    (send display highlight-syntaxes hi-stxs hi-color))
+                  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)])
+            (let* ([binders0
+                    (module-identifier-mapping-map alpha-table (lambda (k v) k))]
+                   [binders
+                    (apply append (map get-binders binders0))])
+              (send display underline-syntaxes binders))
+            (for ([id (send range get-identifier-list)])
+              (define definite? (hash-ref definite-table id #f))
+              (when #f ;; DISABLED
+                (add-binding-billboard start range id definite?))
+              (for ([binder (get-binders id)])
+                (for ([binder-r (send range get-ranges binder)])
+                  (for ([id-r (send range get-ranges id)])
+                    (add-binding-arrow start binder-r id-r definite?)))))))
+        display))
 
-                 (let ([binder (get-binder id)])
-                   (when binder
-                     (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))
-                                              (adjust (cdr binder-r))
-                                              (adjust (car id-r))
-                                              (adjust (cdr id-r))
-                                              "blue")
-                                        (send -text add-question-arrow
-                                              (adjust (car binder-r))
-                                              (adjust (cdr binder-r))
-                                              (adjust (car id-r))
-                                              (adjust (cdr id-r))
-                                              "purple")))
-                                  (send range get-ranges id)))
-                      (send range get-ranges binder)))))
-               (send range get-identifier-list))))
-          display)))
+    (define/private (add-binding-arrow start binder-r id-r definite?)
+      (if definite?
+          (send -text add-arrow
+                (+ start (car binder-r))
+                (+ start (cdr binder-r))
+                (+ start (car id-r))
+                (+ start (cdr id-r))
+                "blue")
+          (send -text add-question-arrow
+                (+ start (car binder-r))
+                (+ start (cdr binder-r))
+                (+ start (car id-r))
+                (+ start (cdr id-r))
+                "purple")))
+
+    (define/private (add-binding-billboard start range id definite?)
+      (match (identifier-binding id)
+        [(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 definites #f)
-    (define error #f)
+    (define raw-steps-estx #f) ;; #f if raw-steps-exn is exn
+    (define raw-steps-exn #f) ;; #f if raw-steps-estx is syntax
+    (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-error error]
+      [get-raw-steps-definites raw-steps-definites]
+      [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! error #f)
+      (set! raw-steps-exn #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! definites definites*)))))))
+                (set! raw-steps-exn error*)
+                (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)]
-            [(exn? error)
-             (add-error error)]
-            [raw-steps-oops
-             (add-internal-error "steps" raw-steps-oops #f)]
-            [else
-             (error 'term-record::display-final-term
-                    "internal error")]))
+             (send displayer add-syntax raw-steps-estx
+                   #:binders binders
+                   #:shift-table shift-table
+                   #:definites raw-steps-definites)]
+            [(exn? raw-steps-exn)
+             (send displayer add-error raw-steps-exn)]
+            [else (display-oops #f)]))
 
     ;; display-step : -> void
     (define/public (display-step)
@@ -292,191 +294,25 @@
       (cond [steps
              (let ([step (cursor:next steps)])
                (if step
-                   (add-step step binders)
-                   (add-final raw-steps-estx error binders definites)))]
-            [raw-steps-oops
-             (add-internal-error "steps" raw-steps-oops (wderiv-e1 deriv))]
+                   (send displayer add-step step
+                         #:binders binders
+                         #:shift-table shift-table)
+                   (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)]))
-
-    (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"))
-
-
+             (error 'term-record::display-oops "internal error")]))
     ))

collects/macro-debugger/view/warning.ss

@@ -1,131 +1,130 @@
 
-(module warning mzscheme
-  (require mzlib/class
-           mred
-           framework)
-  (provide warnings%
-           stepper-warnings%)
-  
-  ;; warnings%
-  (define warnings%
-    (class object%
-      (init parent)
-      (super-new)
+#lang scheme/base
+(require scheme/class
+         mred
+         framework)
+(provide warnings%
+         stepper-warnings%)
 
-      (define super-panel
-        (new vertical-panel%
-             (parent parent)
-             (stretchable-height #f)))
-      (define main-panel
-        (new horizontal-panel%
-             (parent super-panel)
-             (style '(deleted border))))
-      (define label (new message% (parent main-panel) (label "Warnings")))
-      (define text (new text:hide-caret/selection% (auto-wrap #t)))
-      (define ec
-        (new editor-canvas%
-             (parent main-panel)
-             (editor text)
-             (style '(auto-vscroll auto-hscroll))
-             (line-count 3)))
-      (define dismiss
-        (new button%
-             (parent main-panel)
-             (label "Hide")
-             (stretchable-height #t)
-             (callback (lambda _ (show #f)))))
-      (send text set-autowrap-bitmap #f)
-      (send text lock #t)
-      
-      (define/public (get-text) text)
-      
-      (define/public (show ?)
-        (send super-panel change-children
-              (lambda _
-                (if ?
-                    (list main-panel)
-                    null))))
-      
-      ;; Warning management
-      (define keys null)
-      
-      ;; clear : -> void
-      (define/public (clear)
-        (set! keys null)
-        (send* text
-          (lock #f)
-          (erase)
-          (lock #t))
-        (show #f))
-      
-      ;; add : symbol string ... -> void
-      (define/public (add key . strs)
-        (unless (memq key keys)
-          (send text lock #f)
-          (for-each (lambda (s) (send text insert s)) strs)
-          (send text insert "\n\n")
-          (send text scroll-to-position 0)
-          (send text lock #t)
-          (show #t)))
-      
-      ))
-  
-  (define stepper-warnings%
-    (class warnings%
-      (super-new)
-      (inherit add)
-      
-      (define/private (add-nonlinearity-warning)
-        (add
-         'nonlinearity
-         "An opaque macro duplicated one of its subterms. "
-         "Macro hiding requires opaque macros to use their subterms linearly. "
-         "The macro stepper is showing the expansion of that macro use."))
-      (define/private (add-localactions-warning)
-        (add
-         'localactions
-         "An opaque macro called local-expand, syntax-local-lift-expression, "
-         "etc. Macro hiding cannot currently handle local actions. "
-         "The macro stepper is showing the expansion of that macro use."))
-      (define/private (add-lifts-warning)
-        (add
-         'lifts
-         "A transparent macro called syntax-local-lift-expression or "
-         "syntax-local-lift-module-end-declaration. "
-         "The macro stepper is only hiding macro after the "
-         "lifts are caught."))
+;; warnings%
+(define warnings%
+  (class object%
+    (init parent)
+    (super-new)
 
-      (define/private (add-lift/let-warning)
-        (add
-         'lift/let
-         "Lifts occurred during the expansion of phase 1 or higher code. "
-         "The macro stepper is showing some expansions that should be hidden."))
+    (define super-panel
+      (new vertical-panel%
+           (parent parent)
+           (stretchable-height #f)))
+    (define main-panel
+      (new horizontal-panel%
+           (parent super-panel)
+           (style '(deleted border))))
+    (define label (new message% (parent main-panel) (label "Warnings")))
+    (define text (new text:hide-caret/selection% (auto-wrap #t)))
+    (define ec
+      (new editor-canvas%
+           (parent main-panel)
+           (editor text)
+           (style '(auto-vscroll auto-hscroll))
+           (line-count 3)))
+    (define dismiss
+      (new button%
+           (parent main-panel)
+           (label "Hide")
+           (stretchable-height #t)
+           (callback (lambda _ (show #f)))))
+    (send text set-autowrap-bitmap #f)
+    (send text lock #t)
+    
+    (define/public (get-text) text)
+    
+    (define/public (show ?)
+      (send super-panel change-children
+            (lambda _
+              (if ?
+                  (list main-panel)
+                  null))))
+    
+    ;; Warning management
+    (define keys null)
+    
+    ;; clear : -> void
+    (define/public (clear)
+      (set! keys null)
+      (send* text
+        (lock #f)
+        (erase)
+        (lock #t))
+      (show #f))
+    
+    ;; add : symbol string ... -> void
+    (define/public (add key . strs)
+      (unless (memq key keys)
+        (send text lock #f)
+        (for-each (lambda (s) (send text insert s)) strs)
+        (send text insert "\n\n")
+        (send text scroll-to-position 0)
+        (send text lock #t)
+        (show #t)))
+    
+    ))
 
-      (define/private (add-hidden-lift-site-warning)
-        (add
-         'hidden-lift-site
-         "An opaque macro contained the target of a lifted declaration."
-         "The macro stepper is showing the expansion of that macro use."))
+(define stepper-warnings%
+  (class warnings%
+    (super-new)
+    (inherit add)
+    
+    (define/private (add-nonlinearity-warning)
+      (add
+       'nonlinearity
+       "An opaque macro duplicated one of its subterms. "
+       "Macro hiding requires opaque macros to use their subterms linearly. "
+       "The macro stepper is showing the expansion of that macro use."))
+    (define/private (add-localactions-warning)
+      (add
+       'localactions
+       "An opaque macro called local-expand, syntax-local-lift-expression, "
+       "etc. Macro hiding cannot currently handle local actions. "
+       "The macro stepper is showing the expansion of that macro use."))
+    (define/private (add-lifts-warning)
+      (add
+       'lifts
+       "A transparent macro called syntax-local-lift-expression or "
+       "syntax-local-lift-module-end-declaration. "
+       "The macro stepper is only hiding macro after the "
+       "lifts are caught."))
 
-      (define/private (add-hidden-lift-site/continuing-warning)
-        (add
-         'hidden-lift-site/continuing
-         "The target of a lifted declaration was a hidden #%module-begin context. "
-         "The macro stepper is omitting the lifted declaration."))
-      
-      (define/public (add-warning tag args)
-        (case tag
-          ((nonlinearity)
-           (add-nonlinearity-warning))
-          ((localactions)
-           (add-localactions-warning))
-          ((lifts)
-           (add-lifts-warning))
-          ((lift/let)
-           (add-lift/let-warning))
-          ((hidden-lift-site)
-           (add-hidden-lift-site-warning))
-          ((hidden-lift-site/continuing)
-           (add-hidden-lift-site/continuing-warning))))
-      ))
-  )
+    (define/private (add-lift/let-warning)
+      (add
+       'lift/let
+       "Lifts occurred during the expansion of phase 1 or higher code. "
+       "The macro stepper is showing some expansions that should be hidden."))
+
+    (define/private (add-hidden-lift-site-warning)
+      (add
+       'hidden-lift-site
+       "An opaque macro contained the target of a lifted declaration."
+       "The macro stepper is showing the expansion of that macro use."))
+
+    (define/private (add-hidden-lift-site/continuing-warning)
+      (add
+       'hidden-lift-site/continuing
+       "The target of a lifted declaration was a hidden #%module-begin context. "
+       "The macro stepper is omitting the lifted declaration."))
+    
+    (define/public (add-warning tag args)
+      (case tag
+        ((nonlinearity)
+         (add-nonlinearity-warning))
+        ((localactions)
+         (add-localactions-warning))
+        ((lifts)
+         (add-lifts-warning))
+        ((lift/let)
+         (add-lift/let-warning))
+        ((hidden-lift-site)
+         (add-hidden-lift-site-warning))
+        ((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)
 
@@ -102,33 +106,31 @@
          [suffix-re (bytes-append #"(?:$|" sep-re #")")])
     (lambda (path)
       (if (byte-regexp? path)
-          path
-          (let* ([path (path->bytes (simplify-path* path))]
-                 [path (regexp-quote (regexp-replace last-sep path #""))])
-            (byte-regexp (bytes-append #"^" path suffix-re)))))))
+        path
+        (let* ([path (path->bytes (simplify-path* path))]
+               [path (regexp-quote (regexp-replace last-sep path #""))])
+          (byte-regexp (bytes-append #"^" path suffix-re)))))))
 
 (define sandbox-path-permissions
   (make-parameter '()
-                  (lambda (new)
-                    (map (lambda (perm) (cons (car perm) (map path->bregexp (cdr perm))))
-                         new))))
+    (lambda (new)
+      (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])
-                         (cond [(null? order)
+         (let ([needed (car (or (for/or ([p (in-list permission-order)])
+                                  (memq p modes))
                                 (error 'default-sandbox-guard
-                                       "unknown access modes: ~e" modes)]
-                               [(memq (car order) modes) (car order)]
-                               [else (loop (cdr order))]))]
+                                       "unknown access modes: ~e" modes)))]
                [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
-                           (add-between (map symbol->string modes) "+"))
+                    (string-append* (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 _)
-  (error 'exit "sandboxed code cannot exit"))
+;; this is never really used (see where it's used in the evaluator)
+(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!)
-  (when uncovered!
-    (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)))))
+  (parameterize ([current-code-inspector orig-code-inspector])
+    (when uncovered!
+      (eval `(,#'#%require scheme/private/sandbox-coverage))))
   (let ([ns (syntax-case* program (module) literal-identifier=?
               [(module mod . body)
                (identifier? #'mod)
                (let ([mod #'mod])
-                 (eval `(,#'require (quote ,mod)))
-                 (module->namespace `(quote ,(syntax-e mod))))]
+                 (lambda ()
+                   (eval `(,#'require (quote ,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
-               (begin (channel-put input-ch expr)
-                      (let loop ()
-                        (with-handlers ([(lambda (e)
-                                           (and (sandbox-propagate-breaks)
-                                                (exn:break? e)))
-                                         (lambda (e)
-                                           (user-break)
-                                           (loop))])
-                          (sync user-done-evt result-ch))))
-               eof)])
-      (cond [(eof-object? r) (error 'evaluator "terminated~a"
-                                    (if (custodian-box-value memory-cust-box)
-                                      "" " (memory exceeded)"))]
-            [(eq? (car r) 'exn) (raise (cdr r))]
-            [else (apply values (cdr r))])))
+    ;; the thread will usually be running, but it might be killed outside of
+    ;; the sandboxed environment, for example, if you do something like
+    ;; (kill-thread (ev '(current-thread))) when there are no per-expression
+    ;; limits (since then you get a different thread, which is already dead).
+    (when (and user-thread (thread-dead? user-thread))
+      (terminated! #t))
+    (cond
+      [terminated? => raise]
+      [(not user-thread) (error 'sandbox "internal error (user-thread is #f)")]
+      [else
+       (channel-put input-ch expr)
+       (let ([r (let loop ()
+                  (with-handlers ([(if (sandbox-propagate-breaks)
+                                     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))]))]))
   (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)]
-    [exit-handler (sandbox-exit-handler)]
+    [current-security-guard
+     (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)))
-   (set! user-done-evt (handle-evt user-thread (lambda (_) (user-kill) eof)))
+   (let ([t (bg-run->thread (run-in-bg user-process))])
+     (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
-default forbids all filesystem I/O except for things in
-@scheme[sandbox-path-permissions], and it uses
+@scheme[(current-security-guard)] for sandboxed evaluations.  It can
+be either a security guard, or a function to construct one.  The
+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
-you need to catch errors that happen when the sandbox is created.
+fail if the limits are strict enough.  For example,
+@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
-evaluator, and the default parameter value is @scheme[make-inspector].}
+for sandboxed evaluation.  The procedure is called when initializing
+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
-evaluator, and the default parameter value is @scheme[current-logger].}
+for sandboxed evaluation.  The procedure is called when initializing
+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"
-   x =err> "terminated"
-   ,eof =err> "terminated"
+   ,eof =err> "terminated .eof.$"
+   123  =err> "terminated .eof.$"
+   ,eof =err> "terminated .eof.$"
+
+   ;; 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"
-   y =err> "terminated"
-   ,eof =err> "terminated"
+   x =err> "terminated .evaluator-killed.$"
+   y =err> "terminated .evaluator-killed.$"
+   ,eof =err> "terminated .evaluator-killed.$"
    --top--
    (let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)])
      ;; o1 -> i1 -ev-> o2 -> i2
@@ -401,54 +419,58 @@
    (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--
-   (set! ev (parameterize ([sandbox-eval-limits '(2 5)]
-                           [sandbox-memory-limit 100])
-              (make-evaluator 'scheme/base)))
-   --eval--
-   (define a '())
-   (define b 1)
-   (for ([i (in-range 20)])
-     (set! a (cons (make-bytes 500000) a))
-     (collect-garbage))
-   =err> "out of memory"
-   b => 1
+   (when (custodian-memory-accounting-available?)
+     (t --top--
+        (set! ev (parameterize ([sandbox-eval-limits '(2 5)]
+                                [sandbox-memory-limit 100])
+                   (make-evaluator 'scheme/base)))
+        --eval--
+        (define a '())
+        (define b 1)
+        (for ([i (in-range 20)])
+          (set! a (cons (make-bytes 500000) a))
+          (collect-garbage))
+        =err> "out of memory"
+        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_reader(scheme_module_variable_type, read_variable);
+  scheme_install_type_writer(scheme_module_variable_type, write_module_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,92 +4951,54 @@ static Scheme_Object *read_toplevel(Scheme_Object *obj)
 }
 
 static Scheme_Object *write_variable(Scheme_Object *obj)
-  /* WARNING: phase-0 module variables and #%kernel references
-     are handled in print.c, instead */
+  /* #%kernel references are handled in print.c, instead */
 {
-  if (SAME_TYPE(scheme_variable_type, SCHEME_TYPE(obj))) {
-    Scheme_Object *sym;
-    Scheme_Env *home;
-    Scheme_Module *m;
+  Scheme_Object *sym;
+  Scheme_Env *home;
+  Scheme_Module *m;
     
-    sym = (Scheme_Object *)(SCHEME_VAR_BUCKET(obj))->key;
+  sym = (Scheme_Object *)(SCHEME_VAR_BUCKET(obj))->key;
     
-    home = ((Scheme_Bucket_With_Home *)obj)->home;
-    m = home->module;
+  home = ((Scheme_Bucket_With_Home *)obj)->home;
+  m = home->module;
     
-    /* If we get a writeable variable (instead of a module variable),
-       it must be a reference to a module referenced directly by its
-       a symbolic name (i.e., no path). */
+  /* If we get a writeable variable (instead of a module variable),
+     it must be a reference to a module referenced directly by its
+     a symbolic name (i.e., no path). */
     
-    if (m) {
-      sym = scheme_make_pair(m->modname, sym);
-      if (home->mod_phase)
-	sym = scheme_make_pair(scheme_make_integer(home->mod_phase), sym);
-    }
-
-    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));
+  if (m) {
+    sym = scheme_make_pair(m->modname, sym);
+    if (home->mod_phase)
+      sym = scheme_make_pair(scheme_make_integer(home->mod_phase), sym);
   }
+
+  return sym;
 }
 
 static Scheme_Object *read_variable(Scheme_Object *obj)
-  /* WARNING: phase-0 module variables and #%kernel references
-     are handled in read.c, instead */
+  /* #%kernel references are handled in read.c, instead */
 {
   Scheme_Env *env;
 
   env = scheme_get_env(NULL);
 
-  if (!SCHEME_SYMBOLP(obj)) {
-    /* 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;
-    }
-  }
+  if (!SCHEME_SYMBOLP(obj)) return NULL;
 
   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);
-      rp->delay_refcount++;
+      struct Scheme_Load_Delay *d;
+      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,
+                                                    src_modidx,
+                                                    dest_modidx),
+				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;
+    }
 
-    naya = scheme_jit_expr(orig);
-    if (!SAME_OBJ(orig, naya))
+    if (jit)
+      naya = scheme_jit_expr(orig);
+    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))
-	  naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i]);
+        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);
+      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;
+  
+  rp = scheme_prefix_eval_clone(m->prefix);
 
-  l1 = jit_vector(m->body, 0);
-  l2 = jit_vector(m->et_body, 1);
+  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))
+  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)
-	   && !((Module_Variable *)obj)->mod_phase)
+  else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_module_variable_type))
     {
       Scheme_Object *idx;
 
@@ -2378,7 +2377,11 @@ 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);
-	print_compact_number(pp, mv->pos);
+        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, *first = NULL, *last = NULL;
+  Scheme_Object *v;
 
 #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,30 +4529,22 @@ 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);
-	  cdr = read_compact(port, 0);
-	  v = scheme_make_pair(car, cdr);
-	} else
-	  v = read_compact_list(l, 0, 0, port);
-      } else {
-	need_car = l;
-	continue;
-      }
+      if (l == 1) {
+        Scheme_Object *car, *cdr;
+        car = read_compact(port, 0);
+        cdr = read_compact(port, 0);
+        v = scheme_make_pair(car, cdr);
+      } else
+        v = read_compact_list(l, 0, 0, port);
       break;
     case CPT_VECTOR:
       {
@@ -4761,7 +4752,12 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
 	mv->modidx = mod;
 	mv->insp = port->insp;
 	mv->sym = var;
-	mv->pos = pos;
+        if (pos == -2) {
+          mv->mod_phase = 1;
+          pos = read_compact_number(port);
+          mv->pos = pos;
+        } else
+          mv->pos = pos;
 
 	v = (Scheme_Object *)mv;
       }
@@ -4887,21 +4883,15 @@ 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);
-	    cdr = (ppr
-		   ? scheme_null
-		   : read_compact(port, 0));
-	    v = scheme_make_pair(car, cdr);
-	  } else
-	    v = read_compact_list(l, ppr, /* use_stack */ 0, port);
-	} else {
-	  proper = ppr;
-	  need_car = l;
-	  continue;
-	}
+      	if (l == 1) {
+          Scheme_Object *car, *cdr;
+          car = read_compact(port, 0);
+          cdr = (ppr
+                 ? scheme_null
+                 : read_compact(port, 0));
+          v = scheme_make_pair(car, cdr);
+        } else
+          v = read_compact_list(l, ppr, /* use_stack */ 0, port);
       }
       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;
-  struct Scheme_Load_Delay *delay_info;
+  Scheme_Object *delay_info_rpair; /* (rcons refcount Scheme_Load_Delay*) */
 } 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;
-  if (!rp->delay_refcount)
-    rp->delay_info = NULL;
+  c = SCHEME_INT_VAL(SCHEME_CAR(rp->delay_info_rpair));
+  --c;
+  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;
+
+  orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1];
+  rp = scheme_prefix_eval_clone(orig_rp);
   
-  if (SAME_OBJ(naya, expr))
+  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'
-     symbol is arbitrary; the top-level/prefix support handles a symbol
-     as a "toplevel" specially. */
-  return scheme_register_toplevel_in_prefix(begin_symbol, env, NULL, 0);
+     used to "link" to the right environment at run time. The #f as
+     a toplevel is handled in the prefix linker specially. */
+  return scheme_register_toplevel_in_prefix(scheme_false, 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
- PRODUCTVERSION 4,1,3,5
+ FILEVERSION 4,1,3,6
+ 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
- PRODUCTVERSION 4,1,3,5
+ FILEVERSION 4,1,3,6
+ 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
- PRODUCTVERSION 4,1,3,5
+ FILEVERSION 4,1,3,6
+ 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
- PRODUCTVERSION 4,1,3,5
+ FILEVERSION 4,1,3,6
+ 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"