From 9774e0926db4f657d6ef66d422de0ab10182903e Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 25 Jan 2007 00:32:29 +0000 Subject: [PATCH] Changes to macro stepper (internal): refactored context rep in steps to retain frame structure fixed bug in syntax-restamp (bogus template, broke colors) needs revisiting svn: r5450 --- .../macro-debugger/model/reductions-engine.ss | 85 ++++++++++--------- collects/macro-debugger/model/reductions.ss | 26 +++--- collects/macro-debugger/model/steps.ss | 70 +++++++++++++-- collects/macro-debugger/model/stx-util.ss | 24 +----- collects/macro-debugger/model/trace.ss | 10 +-- collects/macro-debugger/stepper-text.ss | 6 +- collects/macro-debugger/view/gui.ss | 67 +++++++-------- 7 files changed, 165 insertions(+), 123 deletions(-) diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss index fd6dd93808..d916720fa8 100644 --- a/collects/macro-debugger/model/reductions-engine.ss +++ b/collects/macro-debugger/model/reductions-engine.ss @@ -3,15 +3,24 @@ (require "deriv.ss" "stx-util.ss" "steps.ss") - (provide (all-defined) - (all-from "steps.ss")) - - ;; A Context is (syntax -> syntax) - ;; A BigContext is (list-of (cons Derivation (cons Syntaxes Syntax))) - ;; local expansion contexts: deriv, foci, term - + (provide (all-from "steps.ss")) + + (provide context + big-context + current-derivation + with-context + with-derivation + with-new-local-context + CC + R + revappend) + (provide walk + walk/foci + stumble + stumble/E) + ;; context: parameter of Context - (define context (make-parameter (lambda (x) x))) + (define context (make-parameter null)) ;; big-context: parameter of BigContext (define big-context (make-parameter null)) @@ -22,8 +31,8 @@ (define-syntax with-context (syntax-rules () [(with-context f . body) - (let ([E (context)]) - (parameterize ([context (lambda (x) (E (f x)))]) + (let ([c (context)]) + (parameterize ([context (cons f c)]) . body))])) (define-syntax with-derivation @@ -34,15 +43,14 @@ (define-syntax with-new-local-context (syntax-rules () [(with-new-local-context e . body) - (parameterize ([big-context - (cons (cons (current-derivation) (cons (list e) (E e))) + (parameterize ([big-context + (cons (cons (current-derivation) + (cons (list e) + (context))) (big-context))] - [context (lambda (x) x)]) + [context null]) . body)])) - ;; E : syntax -> syntax - (define (E stx) ((context) stx)) - ;; ----------------------------------- ;; CC @@ -83,15 +91,15 @@ #'(let-values ([(form2-var foci1-var foci2-var description-var) (with-syntax ([p f]) (values form2 foci1 foci2 description))]) - (cons (walk/foci/E foci1-var foci2-var f form2-var description-var) + (cons (walk/foci foci1-var foci2-var f form2-var description-var) (R** form2-var p . more)))] [(R** f p [#:rename form2 foci1 foci2 description] . more) #'(let-values ([(form2-var foci1-var foci2-var description-var) (with-syntax ([p f]) (values form2 foci1 foci2 description))]) - (cons (walk/foci/E foci1-var foci2-var - f form2-var - description-var) + (cons (walk/foci foci1-var foci2-var + f form2-var + description-var) (R** form2-var p . more)))] [(R** f p [#:walk form2 description] . more) #'(let-values ([(form2-var description-var) @@ -167,30 +175,26 @@ ;; ----------------------------------- - - ;; walk : syntax(s) syntax(s) StepType -> Reduction + + ;; walk : syntax(es) syntax(es) StepType -> Reduction ;; Lifts a local step into a term step. (define (walk e1 e2 type) - (make-step (current-derivation) (big-context) type - e1 e2 (E e1) (E e2))) - - ;; walk/foci/E : syntax(s) syntax(s) syntax syntax StepType -> Reduction - (define (walk/foci/E focus1 focus2 e1 e2 type) - (walk/foci focus1 focus2 (E e1) (E e2) type)) - - ;; walk/foci : syntax(s) syntax(s) syntax syntax StepType -> Reduction - (define (walk/foci focus1 focus2 Ee1 Ee2 type) - (make-step (current-derivation) (big-context) type - focus1 focus2 Ee1 Ee2)) + (make-step (current-derivation) (big-context) type (context) + (foci e1) (foci e2) e1 e2)) + ;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction + (define (walk/foci foci1 foci2 Ee1 Ee2 type) + (make-step (current-derivation) (big-context) type (context) + (foci foci1) (foci foci2) Ee1 Ee2)) + ;; stumble : syntax exception -> Reduction (define (stumble stx exn) - (make-misstep (current-derivation) (big-context) 'error - stx (E stx) exn)) - + (make-misstep (current-derivation) (big-context) 'error (context) + stx stx exn)) + ;; stumble/E : syntax(s) syntax exn -> Reduction (define (stumble/E focus Ee1 exn) - (make-misstep (current-derivation) (big-context) 'error + (make-misstep (current-derivation) (big-context) 'error (context) focus Ee1 exn)) ;; ------------------------------------ @@ -198,4 +202,9 @@ (define (revappend a b) (cond [(pair? a) (revappend (cdr a) (cons (car a) b))] [(null? a) b])) - ) \ No newline at end of file + + (define (foci x) + (if (list? x) + x + (list x))) + ) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 2ac6e99fe7..21894c006e 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -140,9 +140,9 @@ (with-syntax ([(?case-lambda [?formals . ?body] ...) e1] [((?formals* . ?body*) ...) (map car renames+bodies)]) (let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))]) - (cons (walk/foci/E (syntax->list #'(?formals ...)) - (syntax->list #'(?formals* ...)) - e1 mid 'rename-case-lambda) + (cons (walk/foci (syntax->list #'(?formals ...)) + (syntax->list #'(?formals* ...)) + e1 mid 'rename-case-lambda) (R mid (CASE-LAMBDA [FORMALS . BODY] ...) [Block (BODY ...) (map cdr renames+bodies)]))))] [(AnyQ p:let-values (e1 e2 rs renames rhss body) exni) @@ -391,9 +391,9 @@ (stx-take tail (- (stx-improper-length tail) (stx-improper-length (stx-cdr suffix)))) - (E (revappend prefix - (cons (deriv-e2 head) (stx-cdr suffix)))) - (E (revappend prefix tail)) + (revappend prefix + (cons (deriv-e2 head) (stx-cdr suffix))) + (revappend prefix tail) 'splice-block)) (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) @@ -403,7 +403,7 @@ ;; FIXME (error 'unimplemented)] [(struct error-wrap (exn tag _inner)) - (values (list (stumble/E suffix (E (revappend prefix suffix)) exn)) + (values (list (stumble/E suffix (revappend prefix suffix) exn)) (revappend prefix suffix))]))] [(null? brules) (values (apply append (reverse rss)) @@ -447,8 +447,8 @@ (stx-take stxs (- (stx-improper-length stxs) (stx-improper-length suffix-tail))) - (E (revappend prefix (cons head-e2 suffix-tail))) - (E (revappend prefix stxs)) + (revappend prefix (cons head-e2 suffix-tail)) + (revappend prefix stxs) 'splice-module) (loop next stxs prefix))))] [(struct mod:lift (head stxs)) @@ -459,8 +459,8 @@ (let ([new-suffix (append stxs (cons head-e2 suffix-tail))]) (cons (walk/foci null stxs - (E (revappend prefix (cons head-e2 suffix-tail))) - (E (revappend prefix new-suffix)) + (revappend prefix (cons head-e2 suffix-tail)) + (revappend prefix new-suffix) 'splice-lifts) (loop next new-suffix @@ -470,8 +470,8 @@ (if (pair? tail) (list (walk/foci null tail - (E (revappend prefix suffix)) - (E (revappend prefix tail)) + (revappend prefix suffix) + (revappend prefix tail) 'splice-module-lifts)) null) (loop next tail prefix))]))] diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss index b10d204b5c..80906ad514 100644 --- a/collects/macro-debugger/model/steps.ss +++ b/collects/macro-debugger/model/steps.ss @@ -1,20 +1,41 @@ (module steps mzscheme - (provide (all-defined)) + (require "deriv.ss") ;; A ReductionSequence is a (list-of Reduction) - ;; A ProtoStep is (make-protostep Derivation BigContext StepType) + ;; A ProtoStep is (make-protostep Derivation BigContext StepType Context) + + ;; A Context is a list of Frames + ;; A Frame is (syntax -> syntax) + + ;; A BigContext is (list-of (cons Derivation (cons Syntaxes Syntax))) + ;; local expansion contexts: deriv, foci, term ;; A Reduction is one of ;; - (make-step ... Syntaxes Syntaxes Syntax Syntax) ;; - (make-misstep ... Syntax Syntax Exception) - (define-struct protostep (deriv lctx type) #f) - - (define-struct (step protostep) (redex contractum e1 e2) #f) - (define-struct (misstep protostep) (redex e1 exn) #f) + (define-struct protostep (deriv lctx type ctx) #f) + (define-struct (step protostep) (foci1 foci2 e1 e2) #f) + (define-struct (misstep protostep) (foci1 e1 exn) #f) + + ;; context-fill : Context Syntax -> Syntax + (define (context-fill ctx stx) + (let loop ([ctx ctx] [stx stx]) + (if (null? ctx) + stx + (loop (cdr ctx) ((car ctx) stx))))) + + (define (step-term1 s) + (context-fill (protostep-ctx s) (step-e1 s))) + (define (step-term2 s) + (context-fill (protostep-ctx s) (step-e2 s))) + + (define (misstep-term1 s) + (context-fill (protostep-ctx s) (misstep-e1 s))) + ;; A StepType is a simple in the following alist. (define step-type-meanings @@ -59,5 +80,40 @@ (define (rewrite-step? x) (and (step? x) (not (rename-step? x)))) - + + (provide (all-defined)) + + #;(begin + (require (lib "contract.ss")) + (provide rewrite-step? + rename-step?) + (provide/contract + [step-type->string (any/c . -> . string?)] + [step-term1 (step? . -> . syntax?)] + [step-term2 (step? . -> . syntax?)] + [misstep-term1 (misstep? . -> . syntax?)] + [context-fill ((listof procedure?) syntax? . -> . syntax?)] + (struct protostep + ([deriv deriv?] + [lctx list?] + [type (or/c symbol? boolean?)] + [ctx (listof procedure?)])) + (struct (step protostep) + ([deriv deriv?] + [lctx list?] + [type (or/c symbol? boolean?)] + [ctx (listof procedure?)] + [foci1 (listof syntax?)] + [foci2 (listof syntax?)] + [e1 syntax?] + [e2 syntax?])) + (struct (misstep protostep) + ([deriv deriv?] + [lctx list?] + [type (or/c symbol? boolean?)] + [ctx (listof procedure?)] + [foci1 (listof syntax?)] + [e1 syntax?] + [exn exn?]))) ) +) diff --git a/collects/macro-debugger/model/stx-util.ss b/collects/macro-debugger/model/stx-util.ss index 1c34aaf7a2..d642dd328e 100644 --- a/collects/macro-debugger/model/stx-util.ss +++ b/collects/macro-debugger/model/stx-util.ss @@ -5,19 +5,10 @@ (provide (all-defined) (all-from (lib "stx.ss" "syntax"))) - #; - (define-syntax (CC stx) - (syntax-case stx () - [(CC HOLE expr pattern) - #'(lambda (in-the-hole) - (with-syntax ([pattern expr]) - (with-syntax ([HOLE in-the-hole]) - #'pattern)))])) - - (define (d->so template datum) - (let ([template (and (syntax? template) #f)]) - (datum->syntax-object template datum template template))) + (if (syntax? template) + (datum->syntax-object template datum template template) + datum)) (define-syntax (syntax-copier stx) (syntax-case stx () @@ -40,6 +31,7 @@ [(syntax/restamp (pa (... ...)) new-expr old-expr) #`(let ([new-parts (stx->list new-expr)] [old-parts (stx->list old-expr)]) + #; (unless (= (length new-parts) (length old-parts)) (printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) (printf "pattern : ~s~n" (syntax-object->datum #'(pa (... ...)))) @@ -50,14 +42,6 @@ (map (lambda (new old) (syntax/restamp pa new old)) new-parts old-parts)))] - #;[(syntax/restamp (pa ...) new-expr old-expr) - (with-syntax ([(na ...) (generate-temporaries #'(pa ...))] - [(oa ...) (generate-temporaries #'(pa ...))]) - #'(with-syntax ([(na ...) new-expr] - [(oa ...) old-expr]) - (d->so - old-expr - (list (syntax/restamp pa #'na #'oa) ...))))] [(syntax/restamp (pa . pb) new-expr old-expr) #'(let ([na (stx-car new-expr)] [nb (stx-cdr new-expr)] diff --git a/collects/macro-debugger/model/trace.ss b/collects/macro-debugger/model/trace.ss index 3d12d620a7..5868fad4c8 100644 --- a/collects/macro-debugger/model/trace.ss +++ b/collects/macro-debugger/model/trace.ss @@ -23,12 +23,12 @@ ;; trace : syntax -> Derivation (define (trace stx) - (let-values ([(result tracer) (expand+tracer stx)]) + (let-values ([(result tracer) (expand+tracer stx expand)]) (parse-derivation tracer))) ;; trace/result : syntax -> (values syntax/exn Derivation) (define (trace/result stx) - (let-values ([(result tracer) (expand+tracer stx)]) + (let-values ([(result tracer) (expand+tracer stx expand)]) (values result (parse-derivation tracer)))) @@ -36,8 +36,8 @@ (define (trace+reductions stx) (reductions (trace stx))) - ;; expand+tracer : syntax/sexpr -> (values syntax/exn (-> event)) - (define (expand+tracer sexpr) + ;; expand+tracer : syntax/sexpr (syntax -> A) -> (values A/exn (-> event)) + (define (expand+tracer sexpr expander) (let* ([s (make-semaphore 1)] [head (cons #f #f)] [tail head] @@ -64,7 +64,7 @@ (lambda (exn) (add! (cons 'error exn)) exn)]) - (expand sexpr))]) + (expander sexpr))]) (add! (cons 'EOF pos)) (values result (lambda () diff --git a/collects/macro-debugger/stepper-text.ss b/collects/macro-debugger/stepper-text.ss index e712721532..2ea35fca46 100644 --- a/collects/macro-debugger/stepper-text.ss +++ b/collects/macro-debugger/stepper-text.ss @@ -64,15 +64,15 @@ (cond [(step? step) (display (step-type->string (protostep-type step))) (newline) - (show-term (step-e1 step) partition) + (show-term (step-term1 step) partition) (display " ==>") (newline) - (show-term (step-e2 step) partition) + (show-term (step-term2 step) partition) (newline)] [(misstep? step) (display (exn-message (misstep-exn step))) (newline) - (show-term (misstep-e1 step) partition)])) + (show-term (misstep-term1 step) partition)])) (define (show-term stx partition) (define-values (datum flat=>stx stx=>flat) diff --git a/collects/macro-debugger/view/gui.ss b/collects/macro-debugger/view/gui.ss index 4b41153296..5d2f362b07 100644 --- a/collects/macro-debugger/view/gui.ss +++ b/collects/macro-debugger/view/gui.ss @@ -33,9 +33,12 @@ ;; Struct for one-by-one stepping - (define-struct (prestep protostep) (redex e1)) - (define-struct (poststep protostep) (contractum e2)) - + (define-struct (prestep protostep) (foci1 e1)) + (define-struct (poststep protostep) (foci2 e2)) + + (define (prestep-term1 s) (context-fill (protostep-ctx s) (prestep-e1 s))) + (define (poststep-term2 s) (context-fill (protostep-ctx s) (poststep-e2 s))) + ;; Macro Stepper (define view@ @@ -387,7 +390,8 @@ (define/private (update:show-lctx lctx) (when (pair? lctx) (for-each (lambda (bc) - (send sbview add-text "While executing macro transformer in:\n") + (send sbview add-text + "While executing macro transformer in:\n") (insert-syntax/redex (cddr bc) (cadr bc))) lctx) (send sbview add-text "\n"))) @@ -399,34 +403,38 @@ (insert-step-separator (step-type->string (protostep-type step)))) (define/private (update:separator/small step) - (insert-step-separator/small (step-type->string (protostep-type step)))) + (insert-step-separator/small + (step-type->string (protostep-type step)))) (define/private (update:show-step step) (update:show-protostep step) - (insert-syntax/redex (step-e1 step) (foci (step-redex step))) + (insert-syntax/redex (step-term1 step) (step-foci1 step)) (update:separator step) - (insert-syntax/contractum (step-e2 step) (foci (step-contractum step)))) - + (insert-syntax/contractum (step-term2 step) (step-foci2 step))) + (define/private (update:show-prestep step) (update:show-protostep step) (update:separator/small step) - (insert-syntax/redex (prestep-e1 step) (foci (prestep-redex step)))) + (insert-syntax/redex (prestep-term1 step) + (prestep-foci1 step))) (define/private (update:show-poststep step) (update:show-protostep step) (update:separator/small step) - (insert-syntax/contractum (poststep-e2 step) (foci (poststep-contractum step)))) + (insert-syntax/contractum (poststep-term2 step) + (poststep-foci2 step))) (define/private (update:show-misstep step) (update:show-protostep step) - (insert-syntax/redex (misstep-e1 step) (foci (misstep-redex step))) + (insert-syntax/redex (misstep-term1 step) + (misstep-foci1 step)) (update:separator step) (send sbview add-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)) (exn:fail:syntax-exprs (misstep-exn step))))) - + (define/private (update:show-final) (let ([result (lift/deriv-e2 synth-deriv)]) (when result @@ -438,7 +446,8 @@ (define/private (update:show-suffix) (when (pair? derivs) (for-each (lambda (suffix-deriv) - (send sbview add-syntax (lift/deriv-e1 suffix-deriv))) + (send sbview add-syntax + (lift/deriv-e1 suffix-deriv))) (cdr derivs)))) ;; update/save-position : -> void @@ -547,24 +556,8 @@ ;; At end; go to the end when restored (update-saved-position +inf.0)] [(protostep? step) - (update-saved-position (extract-protostep-seq step))])))) - -; ;; save-position : -> void -; (define (save-position) -; (define (steps-loop) -; (let ([step (cursor:current steps)]) -; (cond [(not step) -; ;; At end; go to the end when restored -; +inf.0] -; [(protostep? step) -; (or (extract-protostep-seq step) -; ;; Go one previous, if possible, and try again -; (if (cursor:can-move-previous? steps) -; (begin (cursor:move-previous steps) -; (steps-loop)) -; #f))] -; [else #f]))) -; (update-saved-position (and steps (steps-loop)))) + (update-saved-position + (extract-protostep-seq step))])))) ;; restore-position : number -> void (define (restore-position) @@ -640,13 +633,13 @@ (define/private (reduce:one-by-one rs) (let loop ([rs rs]) (match rs - [(cons (struct step (d l t redex contractum e1 e2)) rs) - (list* (make-prestep d l "Find redex" redex e1) - (make-poststep d l t contractum e2) + [(cons (struct step (d l t c redex contractum e1 e2)) rs) + (list* (make-prestep d l "Find redex" c redex e1) + (make-poststep d l t c contractum e2) (loop rs))] - [(cons (struct misstep (d l t redex e1 exn)) rs) - (list* (make-prestep d l "Find redex" redex e1) - (make-misstep d l t redex e1 exn) + [(cons (struct misstep (d l t c redex e1 exn)) rs) + (list* (make-prestep d l "Find redex" c redex e1) + (make-misstep d l t c redex e1 exn) (loop rs))] ['() null])))