suzanne.soy/macro-debugger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Macro stepper: added env/renaming tracking

Browse Source 
svn: r5669

original commit: 0a194c3eae0582026112b294e05fe32565af0b71
This commit is contained in:
Ryan Culpepper 2007-02-23 08:01:33 +00:00
parent 41538c81f5
commit a169d49e04
4 changed files with 107 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
collects/macro-debugger/model/deriv-util.ss
View File

@ -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, <list, append, null> 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))]))
)

3
collects/macro-debugger/model/reductions-engine.ss
View File

@ -95,10 +95,11 @@
#'(let-values ([(form2-var foci1-var foci2-var description-var)
(with-syntax ([p f])
(values form2 foci1 foci2 description))])
(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** form2-var p . more))))]
[(R** f p [#:walk form2 description] . more)
#'(let-values ([(form2-var description-var)
(with-syntax ([p f])

1
collects/macro-debugger/model/reductions.ss
View File

@ -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)

26
collects/macro-debugger/model/steps.ss
View File

@ -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)
@ -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)))