macro-debugger:

fixed local-expand not within macro transformation
  removed dead forms (eg require-for-syntax)
  fixed module-level begin-splicing highlighting

svn: r17581

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

@@ -32,6 +32,7 @@
 (define-struct (mrule base) (me1 locals me2 ?2 etx next) #:transparent)
 
 ;; A LocalAction is one of:
+(define-struct local-exn (exn) #:transparent)
 (define-struct (local-expansion node) (for-stx? me1 inner lifted me2 opaque)
   #:transparent)
 (define-struct local-lift (expr ids) #:transparent)
@@ -44,15 +45,15 @@
 (define-struct (prule base) () #:transparent)
 (define-struct (p:variable prule) () #:transparent)
 
-;;   (make-p:module <Base> ?exn ?stx stx ?Deriv ?stx ?exn Deriv ?stx)
+;;   (make-p:module <Base> (listof LocalAction) ?stx stx ?Deriv ?stx ?exn Deriv ?stx)
 ;;   (make-p:#%module-begin <Base> Stx ModulePass1 ModulePass2 ?exn)
-(define-struct (p:module prule) (?2 tag rename check tag2 ?3 body shift)
+(define-struct (p:module prule) (locals tag rename check tag2 ?3 body shift)
   #:transparent)
 (define-struct (p:#%module-begin prule) (me pass1 pass2 ?2) #:transparent)
 
-;;   (make-p:define-syntaxes <Base> DerivLL)
+;;   (make-p:define-syntaxes <Base> DerivLL (listof LocalAction))
 ;;   (make-p:define-values <Base> Deriv)
-(define-struct (p:define-syntaxes prule) (rhs ?2) #:transparent)
+(define-struct (p:define-syntaxes prule) (rhs locals) #:transparent)
 (define-struct (p:define-values prule) (rhs) #:transparent)
 
 ;;   (make-p:#%expression <Base> Deriv ?Stx)
@@ -89,15 +90,15 @@
 ;;   (make-p:provide <Base> (listof Deriv) ?exn)
 (define-struct (p:provide prule) (inners ?2) #:transparent)
 
+;;   (make-p:require <Base> (listof LocalAction))
+(define-struct (p:require prule) (locals) #:transparent)
+
 ;;   (make-p:stop <Base>)
 ;;   (make-p:unknown <Base>)
 ;;   (make-p:#%top <Base> Stx)
 ;;   (make-p:#%datum <Base> Stx)
 ;;   (make-p:quote <Base>)
 ;;   (make-p:quote-syntax <Base>)
-;;   (make-p:require <Base>)
-;;   (make-p:require-for-syntax <Base>)
-;;   (make-p:require-for-template <Base>)
 ;;   (make-p:#%variable-reference <Base>)
 (define-struct (p::STOP prule) () #:transparent)
 (define-struct (p:stop p::STOP) () #:transparent)
@@ -106,9 +107,6 @@
 (define-struct (p:#%datum p::STOP) () #:transparent)
 (define-struct (p:quote p::STOP) () #:transparent)
 (define-struct (p:quote-syntax p::STOP) () #:transparent)
-(define-struct (p:require p::STOP) () #:transparent)
-(define-struct (p:require-for-syntax p::STOP) () #:transparent)
-(define-struct (p:require-for-template p::STOP) () #:transparent)
 (define-struct (p:#%variable-reference p::STOP) () #:transparent)
 
 ;; A LDeriv is
@@ -133,8 +131,8 @@
 (define-struct (b:defstx brule) (head ?1 rename ?2 bindrhs) #:transparent)
 
 ;; A BindSyntaxes is
-;;   (make-bind-syntaxes DerivLL ?exn)
+;;   (make-bind-syntaxes DerivLL (listof LocalAction))
-(define-struct bind-syntaxes (rhs ?1) #:transparent)
+(define-struct bind-syntaxes (rhs locals) #:transparent)
 
 ;; A CaseLambdaClause is
 ;;   (make-clc ?exn CaseLambdaRename BDeriv)
@@ -165,9 +163,7 @@
 ;; A ModPrim is a PRule in:
 ;;   (make-p:define-values <Base> #:transparent)
 ;;   (make-p:define-syntaxes <Base> Deriv)
-;;   (make-p:require <Base>)
+;;   (make-p:require <Base> (listof LocalAction))
-;;   (make-p:require-for-syntax <Base>)
-;;   (make-p:require-for-template <Base>)
 ;;   (make-p:provide <Base>)
 ;;   #f
 

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

@@ -18,14 +18,6 @@
 
 ;; PARSER
 
-(define-struct (exn:eval exn) (deriv))
-(define empty-cms
-  (call-with-continuation-prompt (lambda () (current-continuation-marks))))
-(define (create-eval-exn deriv)
-  (make-exn:eval "exception during evaluation"
-                 empty-cms
-                 deriv))
-
 (define-production-splitter production/I values values)
 
 (define-syntax (productions/I stx)
@@ -119,14 +111,9 @@
         (make lift/let-deriv initial final $1 $2 $3))])
 
     ;; Evaluation
-    ;; Answer = ?exn
+    ;; Answer = (listof LocalAction)
     (Eval
-     [() #f]
+     [((? LocalActions)) $1])
-     [(!!) $1]
-     [(start EE/Interrupted) (create-eval-exn $2)]
-     [(start EE (? Eval)) $3]
-     [(start CheckImmediateMacro/Interrupted) (create-eval-exn $2)]
-     [(start CheckImmediateMacro (? Eval)) $3])
 
     ;; Expansion of an expression to primitive form
     (CheckImmediateMacro
@@ -177,9 +164,9 @@
     (MacroStep
      (#:args e1 rs next)
      [(enter-macro ! macro-pre-transform (? LocalActions)
-                   ! macro-post-transform ! exit-macro)
+                   macro-post-transform ! exit-macro)
       (make mrule e1 (and next (wderiv-e2 next)) rs $2
-            $3 $4 $6 (or $5 $7) $8 next)])
+            $3 $4 $5 $6 $7 next)])
 
     ;; Keyword resolution
     (Resolves
@@ -191,10 +178,10 @@
     (LocalActions
      (#:skipped null)
      [() null]
-     [((? LocalAction) (? LocalActions)) (cons $1 $2)]
+     [((? LocalAction) (? LocalActions)) (cons $1 $2)])
-     [((? NotReallyLocalAction) (? LocalActions)) $2])
 
     (LocalAction
+     [(!!) (make local-exn $1)]
      [(enter-local OptPhaseUp
        local-pre (? LocalExpand/Inner) OptLifted local-post
        OptOpaqueExpr exit-local)
@@ -210,11 +197,16 @@
      [(local-bind ! rename-list)
       (make local-bind $1 $2 $3 #f)]
      [(local-bind rename-list (? BindSyntaxes))
-      (make local-bind $1 #f $2 $3)])
+      (make local-bind $1 #f $2 $3)]
+     ;; -- Not really local actions, but can occur during evaluation
+     ;; called 'expand' (not 'local-expand') within transformer
+     [(start (? EE)) #f]
+     [(start (? CheckImmediateMacro)) #f])
 
     (LocalExpand/Inner
      [(start (? EE)) $2]
      [((? CheckImmediateMacro)) $1])
+
     (OptLifted
      [(lift-loop) $1]
      [() #f])
@@ -225,11 +217,6 @@
      [(phase-up) #t]
      [() #f])
 
-    (NotReallyLocalAction
-     ;; called 'expand' (not 'local-expand') within transformer
-     [(start (? EE)) #f]
-     [(start (? CheckImmediateMacro)) #f])
-
     (Prim
      (#:args e1 e2 rs)
      [((? PrimModule)) ($1 e1 e2 rs)]
@@ -255,8 +242,6 @@
      [((? PrimQuote)) ($1 e1 e2 rs)]
      [((? PrimQuoteSyntax)) ($1 e1 e2 rs)]
      [((? PrimRequire)) ($1 e1 e2 rs)]
-     [((? PrimRequireForSyntax)) ($1 e1 e2 rs)]
-     [((? PrimRequireForTemplate)) ($1 e1 e2 rs)]
      [((? PrimProvide)) ($1 e1 e2 rs)]
      [((? PrimVarRef)) ($1 e1 e2 rs)])
 
@@ -303,11 +288,7 @@
                   phase-up (? EE/LetLifts) (? Eval) exit-prim)
       (make p:define-syntaxes $1 $7 null $3 $5 $6)]
      [(enter-prim prim-require (? Eval) exit-prim)
-      (make p:require $1 $4 null $3)]
+      (make p:require $1 $4 null #f $3)]
-     [(enter-prim prim-require-for-syntax (? Eval) exit-prim)
-      (make p:require-for-syntax $1 $4 null $3)]
-     [(enter-prim prim-require-for-template (? Eval) exit-prim)
-      (make p:require-for-template $1 $4 null $3)]
      [()
       (make p:stop e1 e1 null #f)])
 
@@ -464,17 +445,7 @@
     (PrimRequire
      (#:args e1 e2 rs)
      [(prim-require (? Eval))
-      (make p:require e1 e2 rs $2)])
+      (make p:require e1 e2 rs #f $2)])
-
-    (PrimRequireForSyntax
-     (#:args e1 e2 rs)
-     [(prim-require-for-syntax (? Eval))
-      (make p:require-for-syntax e1 e2 rs $2)])
-
-    (PrimRequireForTemplate
-     (#:args e1 e2 rs)
-     [(prim-require-for-template (? Eval))
-      (make p:require-for-template e1 e2 rs $2)])
 
     (PrimProvide 
      (#:args e1 e2 rs)

collects/macro-debugger/model/reductions.ss

@@ -64,11 +64,11 @@
         [#:when (or (not (identifier? e1))
                     (not (bound-identifier=? e1 e2)))
                 [#:walk e2 'resolve-variable]])]
-    [(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
+    [(Wrap p:module (e1 e2 rs ?1 locals tag rename check tag2 ?3 body shift))
      (R [#:hide-check rs]
         [! ?1]
         [#:pattern (?module ?name ?language . ?body-parts)]
-        [! ?2]
+        [LocalActions ?body-parts locals]
         [#:when tag
                 [#:in-hole ?body-parts
                            [#:walk (list tag) 'tag-module-begin]]]
@@ -96,12 +96,12 @@
         [#:do (DEBUG (printf "** module begin pass 2\n"))]
         [ModulePass ?forms pass2]
         [! ?1])]
-    [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2))
+    [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs locals))
      (R [! ?1]
         [#:pattern (?define-syntaxes ?vars ?rhs)]
         [#:binders #'?vars]
         [Expr/PhaseUp ?rhs rhs]
-        [! ?2])]
+        [LocalActions ?rhs locals])]
     [(Wrap p:define-values (e1 e2 rs ?1 rhs))
      (R [! ?1]
         [#:pattern (?define-values ?vars ?rhs)]
@@ -224,6 +224,11 @@
           [#:step 'provide]
           [#:set-syntax e2]))]
 
+    [(Wrap p:require (e1 e2 rs ?1 locals))
+     (R [! ?1]
+        [#:pattern ?form]
+        [LocalActions ?form locals])]
+
     [(Wrap p:stop (e1 e2 rs ?1))
      (R [! ?1])]
 
@@ -367,6 +372,9 @@
 
 (define (LocalAction local)
   (match/count local
+    [(struct local-exn (exn))
+     (R [! exn])]
+
     [(struct local-expansion (e1 e2 for-stx? me1 inner #f me2 opaque))
      (R [#:parameterize ((phase (if for-stx? (add1 (phase)) (phase))))
          [#:set-syntax e1]
@@ -544,11 +552,11 @@
 ;; BindSyntaxes : BindSyntaxes -> RST
 (define (BindSyntaxes bindrhs)
   (match bindrhs
-    [(Wrap bind-syntaxes (rhs ?1))
+    [(Wrap bind-syntaxes (rhs locals))
      (R [#:set-syntax (node-z1 rhs)] ;; set syntax; could be in local-bind
         [#:pattern ?form]
         [Expr/PhaseUp ?form rhs]
-        [! ?1])]))
+        [LocalActions ?form locals])]))
 
 ;; ModulePass : (list-of MBRule) -> RST
 (define (ModulePass mbrules)
@@ -574,8 +582,8 @@
         [! ?1]
         [#:let begin-form #'?firstB]
         [#:let rest-forms #'?rest]
-        [#:pattern ?forms]
         [#:left-foot (list #'?firstB)]
+        [#:pattern ?forms]
         [#:set-syntax (append (stx->list (stx-cdr begin-form)) rest-forms)]
         [#:step 'splice-module (stx->list (stx-cdr begin-form))]
         [#:rename ?forms tail]