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

Changes to macro stepper (internal):

Browse Source 
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
This commit is contained in:
Ryan Culpepper 2007-01-25 00:32:29 +00:00
parent 413119739d
commit 64cef9c489
6 changed files with 135 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3,15 +3,24 @@
(require "deriv.ss"
"stx-util.ss"
"steps.ss")
(provide (all-defined)
(all-from "steps.ss"))
(provide (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 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
@ -35,14 +44,13 @@
(syntax-rules ()
[(with-new-local-context e . body)
(parameterize ([big-context
(cons (cons (current-derivation) (cons (list e) (E e)))
(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)
@ -168,29 +176,25 @@
;; -----------------------------------
;; 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)))
(make-step (current-derivation) (big-context) type (context)
(foci e1) (foci e2) e1 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))
;; 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]))
(define (foci x)
(if (list? x)
x
(list x)))
)

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

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

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

@ -1,19 +1,40 @@
(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 protostep (deriv lctx type ctx) #f)
(define-struct (step protostep) (redex contractum e1 e2) #f)
(define-struct (misstep protostep) (redex e1 exn) #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.
@ -60,4 +81,39 @@
(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?])))
)
)

24
collects/macro-debugger/model/stx-util.ss
View File

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

10
collects/macro-debugger/model/trace.ss
View File

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

6
collects/macro-debugger/stepper-text.ss
View File

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