From 64cef9c489bdef9aea734934b49e1070e12b9d87 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 original commit: 9774e0926db4f657d6ef66d422de0ab10182903e --- .../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 +- 6 files changed, 135 insertions(+), 86 deletions(-) diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss index fd6dd93..d916720 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 2ac6e99..21894c0 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 b10d204..80906ad 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 1c34aaf..d642dd3 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 3d12d62..5868fad 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 e712721..2ea35fc 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)