commit 64cef9c489bdef9aea734934b49e1070e12b9d87
parent 413119739dd91c6f5110ed0c2b42c1c2b893da43
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 25 Jan 2007 00:32:29 +0000
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
Diffstat:
6 files changed, 135 insertions(+), 87 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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)
