macro-debugger:

fixed scheme end of lifts issue (needs C fix too)
  added step limit to help catch nonterminating expansions

svn: r15950

original commit: 7c2a7c9ef9c3cd85d9e436239aa7d241e3e31944

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

@@ -31,11 +31,13 @@
 ;;   (make-mrule <Base(Stx)> ?Stx (listof LocalAction) ?exn ?Stx ?Deriv)
 (define-struct (mrule base) (me1 locals me2 ?2 etx next) #:transparent)
 
-;; A LocalAction is one of ???
+;; A LocalAction is one of:
 (define-struct (local-expansion node) (for-stx? me1 inner lifted me2 opaque)
   #:transparent)
-(define-struct local-lift (expr id) #:transparent)
+(define-struct local-lift (expr ids) #:transparent)
 (define-struct local-lift-end (decl) #:transparent)
+(define-struct local-lift-require (req expr mexpr) #:transparent)
+(define-struct local-lift-provide (prov) #:transparent)
 (define-struct local-bind (names ?1 renames bindrhs) #:transparent)
 
 ;; A PrimDeriv is one of

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

@@ -171,6 +171,10 @@
       (make local-lift (cdr $1) (car $1))]
      [(lift-statement)
       (make local-lift-end $1)]
+     [(lift-require)
+      (make local-lift-require (car $1) (cadr $1) (cddr $1))]
+     [(lift-provide)
+      (make local-lift-provide $1)]
      [(local-bind ! rename-list)
       (make local-bind $1 $2 $3 #f)]
      [(local-bind rename-list (? BindSyntaxes))

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

@@ -30,18 +30,21 @@
    ...                  ; .
    EOF                  ; .
    syntax-error         ; exn
-   lift-loop            ; syntax
+   lift-loop            ; syntax = new form (let or begin; let if for_stx)
-   lift/let-loop        ; syntax
+   lift/let-loop        ; syntax = new let form
-   module-lift-loop     ; syntaxes
+   module-lift-loop     ; syntaxes = def-lifts, in reverse order lifted (???)
-   module-lift-end-loop ; syntaxes
+   module-lift-end-loop ; syntaxes = statement-lifts ++ provide-lifts, in order lifted
-   lift                 ; (cons syntax id)
+   lift                 ; (cons (listof id) syntax)
    lift-statement       ; syntax
+   lift-require         ; (cons syntax (cons syntax syntax))
+   lift-provide         ; syntax
+
    enter-local          ; syntax
    local-pre            ; syntax
    local-post           ; syntax
    exit-local           ; syntax
 
-   local-bind           ; (list-of identifier)
+   local-bind           ; (listof identifier)
    enter-bind           ; .
    exit-bind            ; .
    opaque               ; opaque-syntax
@@ -155,6 +158,8 @@
     (147 . ,token-rename-list)
     (148 . ,token-rename-one)
     (149 . prim-varref)
+    (150 . ,token-lift-require)
+    (151 . ,token-lift-provide)
     ))
 
 (define (tokenize sig-n val pos)

collects/macro-debugger/model/reductions-engine.ss

@@ -324,7 +324,7 @@
                          #t))]
 
     [(R** f v p s ws [#:with-visible-form clause ...] . more)
-     #'(let ([k (RP p [#:set-syntax f] . more)])
+     #'(let ([k (RP p #| [#:set-syntax f] |# . more)])
          (if (visibility)
              (R** v v p s ws clause ... => k)
              (k f v s ws)))]

collects/macro-debugger/model/reductions.ss

@@ -270,23 +270,19 @@
     [(Wrap lift-deriv (e1 e2 first lifted-stx second))
      (R [#:pattern ?form]
         ;; lifted-stx has form (begin lift-n ... lift-1 orig-expr)
-        [#:let mid-stxs (reverse (stx->list (stx-cdr lifted-stx)))]
+        [#:let avail (cdr (reverse (stx->list (stx-cdr lifted-stx))))]
-        [#:let lifted-def-stxs (cdr mid-stxs)]
+        [#:parameterize ((available-lift-stxs avail)
-        [#:let main-stx (car mid-stxs)]
-        [#:parameterize ((available-lift-stxs lifted-def-stxs)
                          (visible-lift-stxs null))
           [#:pass1]
           [Expr ?form first]
           [#:do (when (pair? (available-lift-stxs))
                   (lift-error 'lift-deriv "available lifts left over"))]
-          [#:let begin-stx (stx-car lifted-stx)]
           [#:with-visible-form
            ;; If no lifts visible, then don't show begin-wrapping
            [#:when (pair? (visible-lift-stxs))
-                   [#:walk (datum->syntax lifted-stx
+                   [#:walk (reform-begin-lifts lifted-stx
-                                          `(,begin-stx ,@(visible-lift-stxs) ,#'?form)
+                                               (visible-lift-stxs)
-                                          lifted-stx
+                                               #'?form)
-                                          lifted-stx)
                            'capture-lifts]]]
           [#:pass2]
           [#:set-syntax lifted-stx]
@@ -298,9 +294,8 @@
         ;; (let-values ((last-v last-lifted))
         ;;   ...
         ;;     (let-values ((first-v first-lifted)) orig-expr))
-        [#:let first-e2 (wderiv-e2 first)]
+        [#:let avail lifted-stx]
-        [#:let lift-stxs (take-lift/let-stxs lifted-stx first-e2)]
+        [#:parameterize ((available-lift-stxs avail)
-        [#:parameterize ((available-lift-stxs lift-stxs)
                          (visible-lift-stxs null))
           [#:pass1]
           [Expr ?form first]
@@ -309,7 +304,7 @@
           [#:let visible-lifts (visible-lift-stxs)]
           [#:with-visible-form
            [#:left-foot]
-           [#:set-syntax (reconstruct-lift/let-stx visible-lifts #'?form)]
+           [#:set-syntax (reform-let-lifts lifted-stx visible-lifts #'?form)]
            [#:step 'capture-lifts]]
           [#:pass2]
           [#:set-syntax lifted-stx]
@@ -319,18 +314,6 @@
     [#f
      (R)]))
 
-(define (take-lift/let-stxs lifted-stx base)
-  (let loop ([lifted-stx lifted-stx] [acc null])
-    (if (eq? lifted-stx base)
-        acc
-        (with-syntax ([(?let ?binding ?inner) lifted-stx])
-          (loop #'?inner (cons (list #'?let #'?binding) acc))))))
-(define (reconstruct-lift/let-stx lifts base)
-  (if (null? lifts)
-      base
-      (datum->syntax base
-                     `(,@(car lifts) ,(reconstruct-lift/let-stx (cdr lifts) base)))))
-
 ;; Expr/PhaseUp : Deriv -> RST
 (define (Expr/PhaseUp d)
   (R [#:parameterize ((phase (add1 (phase))))
@@ -378,11 +361,19 @@
          [#:rename/mark ?form me2 e2]
          [#:do (when opaque
                  (hash-set! opaque-table (syntax-e opaque) e2))]])]
+
     [(struct local-expansion (e1 e2 for-stx? me1 inner lifted me2 opaque))
-     (R [#:let begin-stx (stx-car lifted)]
+     (R [#:let avail
-        [#:let lift-stxs (cdr (reverse (stx->list (stx-cdr lifted))))]
+               (if for-stx?
+                   lifted
+                   (cdr (reverse (stx->list (stx-cdr lifted)))))]
+        [#:let recombine
+               (lambda (lifts form)
+                 (if for-stx?
+                     (reform-let-lifts lifted lifts form)
+                     (reform-begin-lifts lifted lifts form)))]
         [#:parameterize ((phase (if for-stx? (add1 (phase)) (phase)))
-                         (available-lift-stxs lift-stxs)
+                         (available-lift-stxs avail)
                          (visible-lift-stxs null))
          [#:set-syntax e1]
          [#:pattern ?form]
@@ -390,33 +381,35 @@
          [#:pass1]
          [Expr ?form inner]
          [#:do (when (pair? (available-lift-stxs))
-                 (lift-error 'local-expand/capture-lifts "available lifts left over"))]
+                 (lift-error 'local-expand/capture-lifts
+                             "available lifts left over"))]
          [#:let visible-lifts (visible-lift-stxs)]
          [#:with-visible-form
           [#:left-foot]
-          [#:set-syntax (datum->syntax lifted
+          [#:set-syntax (recombine visible-lifts #'?form)]
-                                       `(,begin-stx ,@visible-lifts ,#'?form)
-                                       lifted lifted)]
           [#:step 'splice-lifts visible-lifts]]
          [#:pass2]
          [#:set-syntax lifted]
          [#:rename/mark ?form me2 e2]
          [#:do (when opaque
                  (hash-set! opaque-table (syntax-e opaque) e2))]])]
-    [(struct local-lift (expr id))
+
+    [(struct local-lift (expr ids))
      ;; FIXME: add action
-     (R [#:do (unless (pair? (available-lift-stxs))
+     (R [#:do (take-lift!)]
-                (lift-error 'local-lift "out of lifts!"))
+        [#:reductions (list (walk expr ids 'local-lift))])]
-              (when (pair? (available-lift-stxs))
+
-                (let ([lift-d (car (available-lift-stxs))]
-                      [lift-stx (car (available-lift-stxs))])
-                  (when (visibility)
-                    (visible-lift-stxs (cons lift-stx (visible-lift-stxs))))
-                  (available-lift-stxs (cdr (available-lift-stxs)))))]
-        [#:reductions (list (walk expr id 'local-lift))])]
     [(struct local-lift-end (decl))
      ;; (walk/mono decl 'module-lift)
      (R)]
+    [(struct local-lift-require (req expr mexpr))
+     ;; lift require
+     (R [#:set-syntax expr]
+        [#:pattern ?form]
+        [#:rename/mark ?form expr mexpr])]
+    [(struct local-lift-provide (prov))
+     ;; lift provide
+     (R)]
     [(struct local-bind (names ?1 renames bindrhs))
      [R [! ?1]
         ;; FIXME: use renames
@@ -561,9 +554,9 @@
      (R [#:pattern (?firstB . ?rest)]
         [#:pass1]
         [Expr ?firstB head]
+        [#:pass2]
         [#:rename ?firstB rename]
         [! ?1]
-        [#:pass2]
         [#:let begin-form #'?firstB]
         [#:let rest-forms #'?rest]
         [#:pattern ?forms]
@@ -609,10 +602,54 @@
         [Expr ?firstC head]
         [ModulePass ?rest rest])]))
 
+;; Lifts
+
+(define (take-lift!)
+  (define avail (available-lift-stxs))
+  (cond [(list? avail)
+         (unless (pair? avail)
+           (lift-error 'local-lift "out of lifts (begin)!"))
+         (when (pair? avail)
+           (let ([lift-stx (car avail)])
+             (available-lift-stxs (cdr avail))
+             (when (visibility)
+               (visible-lift-stxs
+                (cons lift-stx (visible-lift-stxs))))))]
+        [else
+         (syntax-case avail ()
+           [(?let-values ?lift ?rest)
+            (eq? (syntax-e #'?let-values) 'let-values)
+            (begin (available-lift-stxs #'?rest)
+                   (when (visibility)
+                     (visible-lift-stxs
+                      (cons (datum->syntax avail (list #'?let-values #'?lift)
+                                           avail avail)
+                            (visible-lift-stxs)))))]
+           [_
+            (lift-error 'local-lift "out of lifts (let)!")])]))
+
+(define (reform-begin-lifts orig-lifted lifts body)
+  (define begin-kw (stx-car orig-lifted))
+  (datum->syntax orig-lifted
+                 `(,begin-kw ,@lifts ,body)
+                 orig-lifted
+                 orig-lifted))
+
+(define (reform-let-lifts orig-lifted lifts body)
+  (if (null? lifts)
+      body
+      (reform-let-lifts orig-lifted
+                        (cdr lifts)
+                        (with-syntax ([(?let-values ?lift) (car lifts)])
+                          (datum->syntax (car lifts)
+                                         `(,#'?let-values ,#'?lift ,body)
+                                         (car lifts)
+                                         (car lifts))))))
 
 ;; lift-error
 (define (lift-error sym . args)
   (apply fprintf (current-error-port) args)
+  (newline (current-error-port))
   (when #f
     (apply error sym args)))
 

collects/macro-debugger/model/trace.ss

@@ -11,7 +11,10 @@
          trace/result
          trace-verbose?
          events->token-generator
-         current-expand-observe)
+         current-expand-observe
+
+         trace-macro-limit
+         trace-limit-handler)
 
 (define current-expand-observe
   (dynamic-require ''#%expobs 'current-expand-observe))
@@ -52,22 +55,33 @@
         (set! pos (add1 pos))
         t))))
 
+(define trace-macro-limit (make-parameter #f))
+(define trace-limit-handler (make-parameter #f))
+
 ;; expand/events : stx (stx -> stx) -> stx/exn (list-of event)
 (define (expand/events sexpr expander)
-  (let ([events null])
+  (define events null)
-    (define (add! x)
+  (define counter 0)
-      (set! events (cons x events)))
+  (define (add! x y)
-    (parameterize ((current-expand-observe
+    (set! events (cons (cons x y) events)))
-                    (let ([c 0])
+  (define add!/check
-                      (lambda (sig val)
+    (let ([limit (trace-macro-limit)]
-                        (set! c (add1 c))
+          [handler (trace-limit-handler)])
-                        (add! (cons sig val))))))
+      (if (and limit handler (exact-positive-integer? limit))
+          (lambda (x y)
+            (add! x y)
+            (when (= x 8) ;; enter-macro
+              (set! counter (add1 counter))
+              (when (= counter limit)
+                (set! limit (handler counter)))))
+          add!)))
+  (parameterize ((current-expand-observe add!/check))
     (let ([result
            (with-handlers ([(lambda (exn) #t)
                             (lambda (exn)
-                                (add! (cons 'error exn))
+                              (add! 'error exn)
                               exn)])
              (expander sexpr))])
-        (add! (cons 'EOF #f))
+      (add! 'EOF #f)
       (values result
-                (reverse events))))))
+              (reverse events)))))

collects/macro-debugger/view/prefs.ss

@@ -6,7 +6,8 @@
          "../syntax-browser/prefs.ss"
          "../util/notify.ss"
          "../util/misc.ss")
-(provide macro-stepper-config-base%
+(provide pref:macro-step-limit
+         macro-stepper-config-base%
          macro-stepper-config/prefs%
          macro-stepper-config/prefs/readonly%)
 
@@ -28,6 +29,9 @@
 (preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?)
 (preferences:set-default 'MacroStepper:SplitContext? #f boolean?)
 
+(preferences:set-default 'MacroStepper:MacroStepLimit 40000
+                         (lambda (x) (or (eq? x #f) (exact-positive-integer? x))))
+
 (pref:get/set pref:width MacroStepper:Frame:Width)
 (pref:get/set pref:height MacroStepper:Frame:Height)
 (pref:get/set pref:props-shown? MacroStepper:PropertiesShown?)
@@ -45,6 +49,8 @@
 (pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
 (pref:get/set pref:split-context? MacroStepper:SplitContext?)
 
+(pref:get/set pref:macro-step-limit MacroStepper:MacroStepLimit)
+
 (define macro-stepper-config-base%
   (class* syntax-prefs-base% (config<%>)
     (notify-methods macro-hiding-mode)