From 3bed74dc961e790c77169aed1103648cb75c99e0 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 10 Sep 2009 01:51:29 +0000 Subject: [PATCH] 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 | 6 +- collects/macro-debugger/model/deriv-parser.ss | 4 + collects/macro-debugger/model/deriv-tokens.ss | 17 ++- .../macro-debugger/model/reductions-engine.ss | 2 +- collects/macro-debugger/model/reductions.ss | 123 ++++++++++++------ collects/macro-debugger/model/trace.ss | 50 ++++--- collects/macro-debugger/view/prefs.ss | 8 +- 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 index de974b9..03cff48 100644 --- a/collects/macro-debugger/model/deriv-c.ss +++ b/collects/macro-debugger/model/deriv-c.ss @@ -31,11 +31,13 @@ ;; (make-mrule ?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 index 8751731..e4c9a99 100644 --- 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 index 084dafd..a584faf 100644 --- 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 index 6bcb278..72227e3 100644 --- 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 index 82affc7..c7b5146 100644 --- 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 index b9339aa..cc1be54 100644 --- 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 index 5d9f1b9..2986b19 100644 --- 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)