From a169d49e04ff5cd826d90aced7f283305ab8d071 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 23 Feb 2007 08:01:33 +0000 Subject: [PATCH] Macro stepper: added env/renaming tracking svn: r5669 original commit: 0a194c3eae0582026112b294e05fe32565af0b71 --- collects/macro-debugger/model/deriv-util.ss | 79 +++++++++++++++++-- .../macro-debugger/model/reductions-engine.ss | 11 +-- collects/macro-debugger/model/reductions.ss | 1 + collects/macro-debugger/model/steps.ss | 32 ++++++-- 4 files changed, 107 insertions(+), 16 deletions(-) diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss index 3f64c6b..d173cf0 100644 --- a/collects/macro-debugger/model/deriv-util.ss +++ b/collects/macro-debugger/model/deriv-util.ss @@ -19,7 +19,9 @@ find-derivs find-deriv - find-derivs/syntax) + find-derivs/syntax + extract-all-fresh-names + flatten-identifiers) ;; IntW ;; Matches only interrupted wraps @@ -138,20 +140,25 @@ ;; find-derivs : (deriv -> boolean) (deriv -> boolean) deriv -> (list-of deriv) (define (find-derivs pred stop-short d) - (find-deriv/unit+join+zero pred stop-short d list append null)) + (let ([stop (lambda (x) (or (pred x) (stop-short x)))]) + (find-deriv/unit+join+zero pred stop d list append null))) ;; find-deriv : (deriv -> boolean) (deriv -> boolean) deriv -> deriv/#f ;; Finds the first deriv that matches; throws the rest away (define (find-deriv pred stop-short d) - (let/ec return (find-deriv/unit+join+zero pred stop-short d return (lambda _ #f) #f))) + (let ([stop (lambda (x) (or (pred x) (stop-short x)))]) + (let/ec return (find-deriv/unit+join+zero pred stop d return (lambda _ #f) #f)))) ;; find-deriv/unit+join+zero ;; Parameterized over monad operations for combining the results ;; For example, collects the results into a list (define (find-deriv/unit+join+zero pred stop-short d unit join zero) (define (loop d) + (if (pred d) + (join (unit d) (loop-inner d)) + (loop-inner d))) + (define (loop-inner d) (match d - [(? pred d) (unit d)] [(? stop-short d) zero] [(AnyQ mrule (_ _ tx next)) (join (loop tx) (loop next))] @@ -246,4 +253,66 @@ [(AnyQ lift-deriv (_ _ _ _ _)) #t] [_ #f]) d)) - ) + + ;; extract-all-fresh-names : Derivation -> syntaxlike + ;; FIXME: Missing case-lambda + (define (extract-all-fresh-names d) + (define (renaming-node? x) + (or (p:lambda? x) + (p:case-lambda? x) + (p:let-values? x) + (p:letrec-values? x) + (p:letrec-syntaxes+values? x) + (p:rename? x))) + (define (extract-fresh-names d) + (match d + [(struct p:lambda (e1 e2 rs renames body)) + (if renames + (with-syntax ([(?formals . ?body) renames]) + #'?formals) + null)] + [(struct p:let-values (e1 e2 rs renames rhss body)) + (if renames + (with-syntax ([(((?vars ?rhs) ...) . ?body) renames]) + #'(?vars ...)) + null)] + [(struct p:letrec-values (e1 e2 rs renames rhss body)) + (if renames + (with-syntax ([(((?vars ?rhs) ...) . ?body) renames]) + #'(?vars ...)) + null)] + [(struct p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body)) + (cons + (if srenames + (with-syntax ([(((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body) + srenames]) + #'(?svars ... ?vvars ...)) + null) + (if vrenames + (with-syntax ([(((?vvars ?vrhs) ...) . ?body) vrenames]) + #'(?vvars ...)) + null))] + [_ null])) + + (let ([all-renaming-forms + (find-deriv/unit+join+zero + renaming-node? + (lambda (d) #f) + d + list + append + null)]) + (flatten-identifiers (map extract-fresh-names all-renaming-forms)))) + + ;; flatten-identifiers : syntaxlike -> (list-of identifier) + (define (flatten-identifiers stx) + (syntax-case stx () + [id (identifier? #'id) (list #'id)] + [() null] + [(x . y) (append (flatten-identifiers #'x) (flatten-identifiers #'y))] + [else (error 'flatten-identifers "neither syntax list nor identifier: ~s" + (if (syntax? stx) + (syntax-object->datum stx) + stx))])) + +) diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss index b15cf5d..660ffda 100644 --- a/collects/macro-debugger/model/reductions-engine.ss +++ b/collects/macro-debugger/model/reductions-engine.ss @@ -27,7 +27,7 @@ ;; current-derivation : parameter of Derivation (define current-derivation (make-parameter #f)) - + (define-syntax with-context (syntax-rules () [(with-context f . body) @@ -95,10 +95,11 @@ #'(let-values ([(form2-var foci1-var foci2-var description-var) (with-syntax ([p f]) (values form2 foci1 foci2 description))]) - (cons (walk/foci foci1-var foci2-var - f form2-var - description-var) - (R** form2-var p . more)))] + (with-context (make-renames foci1-var foci2-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) (with-syntax ([p f]) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index cd22df2..99063a8 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -143,6 +143,7 @@ (cons (walk/foci (syntax->list #'(?formals ...)) (syntax->list #'(?formals* ...)) e1 mid 'rename-case-lambda) + ;; FIXME: Missing renames frames here (R mid (CASE-LAMBDA [FORMALS . BODY] ...) [Block (BODY ...) (map cdr renames+bodies)]))))] [(AnyQ p:let-values (e1 e2 rs renames rhss body) exni) diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss index 18c3478..b1f6611 100644 --- a/collects/macro-debugger/model/steps.ss +++ b/collects/macro-debugger/model/steps.ss @@ -1,13 +1,18 @@ (module steps mzscheme - (require "deriv.ss") + (require "deriv.ss" + "deriv-util.ss") ;; A ReductionSequence is a (list-of Reduction) ;; A ProtoStep is (make-protostep Derivation BigContext StepType Context) ;; A Context is a list of Frames - ;; A Frame is (syntax -> syntax) + ;; A Frame is either: + ;; - (syntax -> syntax) + ;; - (make-renames syntax syntax) + ;; - 'phase-up + (define-struct renames (old new)) ;; A BigContext is (list-of BigFrame) ;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax) @@ -16,9 +21,9 @@ ;; A Reduction is one of ;; - (make-step ... Syntaxes Syntaxes Syntax Syntax) ;; - (make-misstep ... Syntax Syntax Exception) - + (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) @@ -27,7 +32,22 @@ (let loop ([ctx ctx] [stx stx]) (if (null? ctx) stx - (loop (cdr ctx) ((car ctx) stx))))) + (let ([frame0 (car ctx)]) + (if (procedure? frame0) + (loop (cdr ctx) (frame0 stx)) + (loop (cdr ctx) stx)))))) + + ;; context-env : Context -> (list-of identifier) + (define (context-env ctx) + (let loop ([ctx ctx] [env null]) + (if (null? ctx) + env + (let ([frame0 (car ctx)]) + (if (renames? frame0) + (loop (cdr ctx) + (append (flatten-identifiers (renames-new frame0)) + env)) + (loop (cdr ctx) env)))))) (define (step-term1 s) (context-fill (protostep-ctx s) (step-e1 s))) @@ -39,7 +59,7 @@ (define (bigframe-term bf) (context-fill (bigframe-ctx bf) (bigframe-e bf))) - + ;; A StepType is a simple in the following alist. (define step-type-meanings