commit 3bed74dc961e790c77169aed1103648cb75c99e0
parent 9b166eea01e1a0fea4b2c4534350edf9c07096c8
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 10 Sep 2009 01:51:29 +0000
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
Diffstat:
7 files changed, 139 insertions(+), 71 deletions(-)
diff --git a/collects/macro-debugger/model/deriv-c.ss b/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
diff --git a/collects/macro-debugger/model/deriv-parser.ss b/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))
diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss
@@ -30,18 +30,21 @@
... ; .
EOF ; .
syntax-error ; exn
- lift-loop ; syntax
- lift/let-loop ; syntax
- module-lift-loop ; syntaxes
- module-lift-end-loop ; syntaxes
- lift ; (cons syntax id)
+ lift-loop ; syntax = new form (let or begin; let if for_stx)
+ lift/let-loop ; syntax = new let form
+ module-lift-loop ; syntaxes = def-lifts, in reverse order lifted (???)
+ module-lift-end-loop ; syntaxes = statement-lifts ++ provide-lifts, in order lifted
+ 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)
diff --git a/collects/macro-debugger/model/reductions-engine.ss b/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)))]
diff --git a/collects/macro-debugger/model/reductions.ss b/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 lifted-def-stxs (cdr mid-stxs)]
- [#:let main-stx (car mid-stxs)]
- [#:parameterize ((available-lift-stxs lifted-def-stxs)
+ [#:let avail (cdr (reverse (stx->list (stx-cdr lifted-stx))))]
+ [#:parameterize ((available-lift-stxs avail)
(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
- `(,begin-stx ,@(visible-lift-stxs) ,#'?form)
- lifted-stx
- lifted-stx)
+ [#:walk (reform-begin-lifts lifted-stx
+ (visible-lift-stxs)
+ #'?form)
'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 lift-stxs (take-lift/let-stxs lifted-stx first-e2)]
- [#:parameterize ((available-lift-stxs lift-stxs)
+ [#:let avail lifted-stx]
+ [#:parameterize ((available-lift-stxs avail)
(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)]
- [#:let lift-stxs (cdr (reverse (stx->list (stx-cdr lifted))))]
+ (R [#:let avail
+ (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
- `(,begin-stx ,@visible-lifts ,#'?form)
- lifted lifted)]
+ [#:set-syntax (recombine visible-lifts #'?form)]
[#: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))
- (lift-error 'local-lift "out of lifts!"))
- (when (pair? (available-lift-stxs))
- (let ([lift-d (car (available-lift-stxs))]
- [lift-stx (car (available-lift-stxs))])
- (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))])]
+ (R [#:do (take-lift!)]
+ [#:reductions (list (walk expr ids '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)))
diff --git a/collects/macro-debugger/model/trace.ss b/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 (add! x)
- (set! events (cons x events)))
- (parameterize ((current-expand-observe
- (let ([c 0])
- (lambda (sig val)
- (set! c (add1 c))
- (add! (cons sig val))))))
- (let ([result
- (with-handlers ([(lambda (exn) #t)
- (lambda (exn)
- (add! (cons 'error exn))
- exn)])
- (expander sexpr))])
- (add! (cons 'EOF #f))
- (values result
- (reverse events))))))
+ (define events null)
+ (define counter 0)
+ (define (add! x y)
+ (set! events (cons (cons x y) events)))
+ (define add!/check
+ (let ([limit (trace-macro-limit)]
+ [handler (trace-limit-handler)])
+ (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! 'error exn)
+ exn)])
+ (expander sexpr))])
+ (add! 'EOF #f)
+ (values result
+ (reverse events)))))
diff --git a/collects/macro-debugger/view/prefs.ss b/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)
