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
This commit is contained in:
Ryan Culpepper
parent
413119739d
commit
64cef9c489
|
|
@ -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]))
|
||||
)
|
||||
|
||||
(define (foci x)
|
||||
(if (list? x)
|
||||
x
|
||||
(list x)))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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))]))]
|
||||
|
|
|
|||
|
|
@ -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?])))
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user