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

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

@ -3,15 +3,24 @@
(require "deriv.ss" (require "deriv.ss"
"stx-util.ss" "stx-util.ss"
"steps.ss") "steps.ss")
(provide (all-defined) (provide (all-from "steps.ss"))
(all-from "steps.ss"))
;; A Context is (syntax -> syntax) (provide context
;; A BigContext is (list-of (cons Derivation (cons Syntaxes Syntax))) big-context
;; local expansion contexts: deriv, foci, term current-derivation
with-context
with-derivation
with-new-local-context
CC
R
revappend)
(provide walk
walk/foci
stumble
stumble/E)
;; context: parameter of Context ;; context: parameter of Context
(define context (make-parameter (lambda (x) x))) (define context (make-parameter null))
;; big-context: parameter of BigContext ;; big-context: parameter of BigContext
(define big-context (make-parameter null)) (define big-context (make-parameter null))
@ -22,8 +31,8 @@
(define-syntax with-context (define-syntax with-context
(syntax-rules () (syntax-rules ()
[(with-context f . body) [(with-context f . body)
(let ([E (context)]) (let ([c (context)])
(parameterize ([context (lambda (x) (E (f x)))]) (parameterize ([context (cons f c)])
. body))])) . body))]))
(define-syntax with-derivation (define-syntax with-derivation
@ -35,14 +44,13 @@
(syntax-rules () (syntax-rules ()
[(with-new-local-context e . body) [(with-new-local-context e . body)
(parameterize ([big-context (parameterize ([big-context
(cons (cons (current-derivation) (cons (list e) (E e))) (cons (cons (current-derivation)
(cons (list e)
(context)))
(big-context))] (big-context))]
[context (lambda (x) x)]) [context null])
. body)])) . body)]))
;; E : syntax -> syntax
(define (E stx) ((context) stx))
;; ----------------------------------- ;; -----------------------------------
;; CC ;; CC
@ -83,13 +91,13 @@
#'(let-values ([(form2-var foci1-var foci2-var description-var) #'(let-values ([(form2-var foci1-var foci2-var description-var)
(with-syntax ([p f]) (with-syntax ([p f])
(values form2 foci1 foci2 description))]) (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** form2-var p . more)))]
[(R** f p [#:rename form2 foci1 foci2 description] . more) [(R** f p [#:rename form2 foci1 foci2 description] . more)
#'(let-values ([(form2-var foci1-var foci2-var description-var) #'(let-values ([(form2-var foci1-var foci2-var description-var)
(with-syntax ([p f]) (with-syntax ([p f])
(values form2 foci1 foci2 description))]) (values form2 foci1 foci2 description))])
(cons (walk/foci/E foci1-var foci2-var (cons (walk/foci foci1-var foci2-var
f form2-var f form2-var
description-var) description-var)
(R** form2-var p . more)))] (R** form2-var p . more)))]
@ -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. ;; Lifts a local step into a term step.
(define (walk e1 e2 type) (define (walk e1 e2 type)
(make-step (current-derivation) (big-context) type (make-step (current-derivation) (big-context) type (context)
e1 e2 (E e1) (E e2))) (foci e1) (foci e2) e1 e2))
;; walk/foci/E : syntax(s) syntax(s) syntax syntax StepType -> Reduction ;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction
(define (walk/foci/E focus1 focus2 e1 e2 type) (define (walk/foci foci1 foci2 Ee1 Ee2 type)
(walk/foci focus1 focus2 (E e1) (E e2) type)) (make-step (current-derivation) (big-context) type (context)
(foci foci1) (foci foci2) Ee1 Ee2))
;; 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))
;; stumble : syntax exception -> Reduction ;; stumble : syntax exception -> Reduction
(define (stumble stx exn) (define (stumble stx exn)
(make-misstep (current-derivation) (big-context) 'error (make-misstep (current-derivation) (big-context) 'error (context)
stx (E stx) exn)) stx stx exn))
;; stumble/E : syntax(s) syntax exn -> Reduction ;; stumble/E : syntax(s) syntax exn -> Reduction
(define (stumble/E focus Ee1 exn) (define (stumble/E focus Ee1 exn)
(make-misstep (current-derivation) (big-context) 'error (make-misstep (current-derivation) (big-context) 'error (context)
focus Ee1 exn)) focus Ee1 exn))
;; ------------------------------------ ;; ------------------------------------
@ -198,4 +202,9 @@
(define (revappend a b) (define (revappend a b)
(cond [(pair? a) (revappend (cdr a) (cons (car a) b))] (cond [(pair? a) (revappend (cdr a) (cons (car a) b))]
[(null? a) b])) [(null? a) b]))
(define (foci x)
(if (list? x)
x
(list x)))
) )

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

@ -140,7 +140,7 @@
(with-syntax ([(?case-lambda [?formals . ?body] ...) e1] (with-syntax ([(?case-lambda [?formals . ?body] ...) e1]
[((?formals* . ?body*) ...) (map car renames+bodies)]) [((?formals* . ?body*) ...) (map car renames+bodies)])
(let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))]) (let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))])
(cons (walk/foci/E (syntax->list #'(?formals ...)) (cons (walk/foci (syntax->list #'(?formals ...))
(syntax->list #'(?formals* ...)) (syntax->list #'(?formals* ...))
e1 mid 'rename-case-lambda) e1 mid 'rename-case-lambda)
(R mid (CASE-LAMBDA [FORMALS . BODY] ...) (R mid (CASE-LAMBDA [FORMALS . BODY] ...)
@ -391,9 +391,9 @@
(stx-take tail (stx-take tail
(- (stx-improper-length tail) (- (stx-improper-length tail)
(stx-improper-length (stx-cdr suffix)))) (stx-improper-length (stx-cdr suffix))))
(E (revappend prefix (revappend prefix
(cons (deriv-e2 head) (stx-cdr suffix)))) (cons (deriv-e2 head) (stx-cdr suffix)))
(E (revappend prefix tail)) (revappend prefix tail)
'splice-block)) 'splice-block))
(cons (with-context (lambda (x) (cons (with-context (lambda (x)
(revappend prefix (cons x (stx-cdr suffix)))) (revappend prefix (cons x (stx-cdr suffix))))
@ -403,7 +403,7 @@
;; FIXME ;; FIXME
(error 'unimplemented)] (error 'unimplemented)]
[(struct error-wrap (exn tag _inner)) [(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))]))] (revappend prefix suffix))]))]
[(null? brules) [(null? brules)
(values (apply append (reverse rss)) (values (apply append (reverse rss))
@ -447,8 +447,8 @@
(stx-take stxs (stx-take stxs
(- (stx-improper-length stxs) (- (stx-improper-length stxs)
(stx-improper-length suffix-tail))) (stx-improper-length suffix-tail)))
(E (revappend prefix (cons head-e2 suffix-tail))) (revappend prefix (cons head-e2 suffix-tail))
(E (revappend prefix stxs)) (revappend prefix stxs)
'splice-module) 'splice-module)
(loop next stxs prefix))))] (loop next stxs prefix))))]
[(struct mod:lift (head stxs)) [(struct mod:lift (head stxs))
@ -459,8 +459,8 @@
(let ([new-suffix (append stxs (cons head-e2 suffix-tail))]) (let ([new-suffix (append stxs (cons head-e2 suffix-tail))])
(cons (walk/foci null (cons (walk/foci null
stxs stxs
(E (revappend prefix (cons head-e2 suffix-tail))) (revappend prefix (cons head-e2 suffix-tail))
(E (revappend prefix new-suffix)) (revappend prefix new-suffix)
'splice-lifts) 'splice-lifts)
(loop next (loop next
new-suffix new-suffix
@ -470,8 +470,8 @@
(if (pair? tail) (if (pair? tail)
(list (walk/foci null (list (walk/foci null
tail tail
(E (revappend prefix suffix)) (revappend prefix suffix)
(E (revappend prefix tail)) (revappend prefix tail)
'splice-module-lifts)) 'splice-module-lifts))
null) null)
(loop next tail prefix))]))] (loop next tail prefix))]))]

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

@ -1,19 +1,40 @@
(module steps mzscheme (module steps mzscheme
(provide (all-defined)) (require "deriv.ss")
;; A ReductionSequence is a (list-of Reduction) ;; 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 ;; A Reduction is one of
;; - (make-step ... Syntaxes Syntaxes Syntax Syntax) ;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
;; - (make-misstep ... Syntax Syntax Exception) ;; - (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 (step protostep) (foci1 foci2 e1 e2) #f)
(define-struct (misstep protostep) (redex e1 exn) #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. ;; A StepType is a simple in the following alist.
@ -60,4 +81,39 @@
(define (rewrite-step? x) (define (rewrite-step? x)
(and (step? x) (not (rename-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) (provide (all-defined)
(all-from (lib "stx.ss" "syntax"))) (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) (define (d->so template datum)
(let ([template (and (syntax? template) #f)]) (if (syntax? template)
(datum->syntax-object template datum template template))) (datum->syntax-object template datum template template)
datum))
(define-syntax (syntax-copier stx) (define-syntax (syntax-copier stx)
(syntax-case stx () (syntax-case stx ()
@ -40,6 +31,7 @@
[(syntax/restamp (pa (... ...)) new-expr old-expr) [(syntax/restamp (pa (... ...)) new-expr old-expr)
#`(let ([new-parts (stx->list new-expr)] #`(let ([new-parts (stx->list new-expr)]
[old-parts (stx->list old-expr)]) [old-parts (stx->list old-expr)])
#;
(unless (= (length new-parts) (length old-parts)) (unless (= (length new-parts) (length old-parts))
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx)) (printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
(printf "pattern : ~s~n" (syntax-object->datum #'(pa (... ...)))) (printf "pattern : ~s~n" (syntax-object->datum #'(pa (... ...))))
@ -50,14 +42,6 @@
(map (lambda (new old) (syntax/restamp pa new old)) (map (lambda (new old) (syntax/restamp pa new old))
new-parts new-parts
old-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) [(syntax/restamp (pa . pb) new-expr old-expr)
#'(let ([na (stx-car new-expr)] #'(let ([na (stx-car new-expr)]
[nb (stx-cdr new-expr)] [nb (stx-cdr new-expr)]

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

@ -23,12 +23,12 @@
;; trace : syntax -> Derivation ;; trace : syntax -> Derivation
(define (trace stx) (define (trace stx)
(let-values ([(result tracer) (expand+tracer stx)]) (let-values ([(result tracer) (expand+tracer stx expand)])
(parse-derivation tracer))) (parse-derivation tracer)))
;; trace/result : syntax -> (values syntax/exn Derivation) ;; trace/result : syntax -> (values syntax/exn Derivation)
(define (trace/result stx) (define (trace/result stx)
(let-values ([(result tracer) (expand+tracer stx)]) (let-values ([(result tracer) (expand+tracer stx expand)])
(values result (values result
(parse-derivation tracer)))) (parse-derivation tracer))))
@ -36,8 +36,8 @@
(define (trace+reductions stx) (define (trace+reductions stx)
(reductions (trace stx))) (reductions (trace stx)))
;; expand+tracer : syntax/sexpr -> (values syntax/exn (-> event)) ;; expand+tracer : syntax/sexpr (syntax -> A) -> (values A/exn (-> event))
(define (expand+tracer sexpr) (define (expand+tracer sexpr expander)
(let* ([s (make-semaphore 1)] (let* ([s (make-semaphore 1)]
[head (cons #f #f)] [head (cons #f #f)]
[tail head] [tail head]
@ -64,7 +64,7 @@
(lambda (exn) (lambda (exn)
(add! (cons 'error exn)) (add! (cons 'error exn))
exn)]) exn)])
(expand sexpr))]) (expander sexpr))])
(add! (cons 'EOF pos)) (add! (cons 'EOF pos))
(values result (values result
(lambda () (lambda ()

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

@ -64,15 +64,15 @@
(cond [(step? step) (cond [(step? step)
(display (step-type->string (protostep-type step))) (display (step-type->string (protostep-type step)))
(newline) (newline)
(show-term (step-e1 step) partition) (show-term (step-term1 step) partition)
(display " ==>") (display " ==>")
(newline) (newline)
(show-term (step-e2 step) partition) (show-term (step-term2 step) partition)
(newline)] (newline)]
[(misstep? step) [(misstep? step)
(display (exn-message (misstep-exn step))) (display (exn-message (misstep-exn step)))
(newline) (newline)
(show-term (misstep-e1 step) partition)])) (show-term (misstep-term1 step) partition)]))
(define (show-term stx partition) (define (show-term stx partition)
(define-values (datum flat=>stx stx=>flat) (define-values (datum flat=>stx stx=>flat)