Macro stepper: started tracking definite uses, added definite arrows
svn: r5700 original commit: 75a0a02355816860e9e1ed4e8cf064d5d3c9299d
This commit is contained in:
Ryan Culpepper
parent
a7a568ad42
commit
bdbee3601c
|
|
@ -8,6 +8,8 @@
|
|||
(provide context
|
||||
big-context
|
||||
current-derivation
|
||||
current-definites
|
||||
learn-definites
|
||||
with-context
|
||||
with-derivation
|
||||
with-new-local-context
|
||||
|
|
@ -28,6 +30,9 @@
|
|||
;; current-derivation : parameter of Derivation
|
||||
(define current-derivation (make-parameter #f))
|
||||
|
||||
;; current-definites : parameter of (list-of identifier)
|
||||
(define current-definites (make-parameter null))
|
||||
|
||||
(define-syntax with-context
|
||||
(syntax-rules ()
|
||||
[(with-context f . body)
|
||||
|
|
@ -49,6 +54,9 @@
|
|||
[context null])
|
||||
. body)]))
|
||||
|
||||
(define (learn-definites ids)
|
||||
(current-definites (append ids (current-definites))))
|
||||
|
||||
;; -----------------------------------
|
||||
|
||||
;; CC
|
||||
|
|
@ -62,7 +70,7 @@
|
|||
;; the threaded reductions engine
|
||||
(define-syntax R
|
||||
(syntax-rules ()
|
||||
[(R form pattern . clauses)
|
||||
[(R form . clauses)
|
||||
(R** #f _ [#:set-syntax form] [#:pattern pattern] . clauses)]))
|
||||
|
||||
(define-syntax (R** stx)
|
||||
|
|
@ -106,6 +114,9 @@
|
|||
(values form2 description))])
|
||||
(cons (walk f form2-var description-var)
|
||||
(R** form2-var p . more)))]
|
||||
[(R** f p [#:learn ids] . more)
|
||||
#'(begin (learn-definites ids)
|
||||
(R** f p . more))]
|
||||
|
||||
;; Conditional
|
||||
[(R** f p [#:if test consequent ...] . more)
|
||||
|
|
@ -178,22 +189,22 @@
|
|||
;; 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 (context)
|
||||
(make-step (current-derivation) (big-context) type (context) (current-definites)
|
||||
(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)
|
||||
(make-step (current-derivation) (big-context) type (context) (current-definites)
|
||||
(foci foci1) (foci foci2) Ee1 Ee2))
|
||||
|
||||
;; stumble : syntax exception -> Reduction
|
||||
(define (stumble stx exn)
|
||||
(make-misstep (current-derivation) (big-context) 'error (context)
|
||||
(make-misstep (current-derivation) (big-context) 'error (context) (current-definites)
|
||||
(foci stx) stx exn))
|
||||
|
||||
;; stumble/E : syntax(s) syntax exn -> Reduction
|
||||
(define (stumble/E focus Ee1 exn)
|
||||
(make-misstep (current-derivation) (big-context) 'error (context)
|
||||
(make-misstep (current-derivation) (big-context) 'error (context) (current-definites)
|
||||
(foci focus) Ee1 exn))
|
||||
|
||||
;; ------------------------------------
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
|
||||
(define-syntax Expr
|
||||
(syntax-id-rules ()
|
||||
[Expr (values reductions deriv-e1 deriv-e2)]))
|
||||
[Expr (values reductions* deriv-e1 deriv-e2)]))
|
||||
(define-syntax List
|
||||
(syntax-id-rules ()
|
||||
[List (values list-reductions lderiv-es1 lderiv-es2)]))
|
||||
|
|
@ -34,6 +34,14 @@
|
|||
|
||||
;; reductions : Derivation -> ReductionSequence
|
||||
(define (reductions d)
|
||||
(parameterize ((current-definites null))
|
||||
(reductions* d)))
|
||||
|
||||
(define (reductions* d)
|
||||
(match d
|
||||
[(AnyQ prule (e1 e2 rs))
|
||||
(and rs (learn-definites rs))]
|
||||
[_ (void)])
|
||||
(match/with-derivation d
|
||||
|
||||
;; Primitives
|
||||
|
|
@ -47,12 +55,12 @@
|
|||
[body-e1 (match body [(AnyQ deriv (body-e1 _)) body-e1])])
|
||||
(cons (walk e1 (ctx body-e1) 'tag-module-begin)
|
||||
(with-context ctx
|
||||
(reductions body)))))]
|
||||
(reductions* body)))))]
|
||||
[(IntQ p:module (e1 e2 rs #t body))
|
||||
(with-syntax ([(?module name language . BODY) e1])
|
||||
(let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))])
|
||||
(with-context ctx
|
||||
(reductions body))))]
|
||||
(reductions* body))))]
|
||||
[(AnyQ p:#%module-begin (e1 e2 rs pass1 pass2))
|
||||
(with-syntax ([(?#%module-begin form ...) e1])
|
||||
(let ([frame (lambda (x) (d->so e1 (cons #'?#%module-begin x)))])
|
||||
|
|
@ -67,57 +75,58 @@
|
|||
(list (stumble (frame final-stxs2) (error-wrap-exn d))))
|
||||
(append reductions1 reductions2))))))]
|
||||
[(AnyQ p:define-syntaxes (e1 e2 rs rhs) exni)
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?define-syntaxes formals RHS)]
|
||||
[Expr RHS rhs])]
|
||||
[(AnyQ p:define-values (e1 e2 rs rhs) exni)
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?define-values formals RHS)]
|
||||
[#:if rhs
|
||||
[Expr RHS rhs]])]
|
||||
[(AnyQ p:if (e1 e2 rs full? test then else) exni)
|
||||
(if full?
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?if TEST THEN ELSE)]
|
||||
[Expr TEST test]
|
||||
[Expr THEN then]
|
||||
[Expr ELSE else])
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?if TEST THEN)]
|
||||
[Expr TEST test]
|
||||
[Expr THEN then]))]
|
||||
[(AnyQ p:wcm (e1 e2 rs key mark body) exni)
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?wcm KEY MARK BODY)]
|
||||
[Expr KEY key]
|
||||
[Expr MARK mark]
|
||||
[Expr BODY body])]
|
||||
[(AnyQ p:begin (e1 e2 rs lderiv) exni)
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?begin . LDERIV)]
|
||||
[List LDERIV lderiv])]
|
||||
[(AnyQ p:begin0 (e1 e2 rs first lderiv) exni)
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?begin0 FIRST . LDERIV)]
|
||||
[Expr FIRST first]
|
||||
[List LDERIV lderiv])]
|
||||
[(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni)
|
||||
(let ([tail
|
||||
(R tagged-stx (?#%app . LDERIV)
|
||||
(R tagged-stx
|
||||
[! exni]
|
||||
[#:pattern (?#%app . LDERIV)]
|
||||
[List LDERIV lderiv])])
|
||||
(if (eq? tagged-stx e1)
|
||||
tail
|
||||
(cons (walk e1 tagged-stx 'tag-app) tail)))]
|
||||
[(AnyQ p:lambda (e1 e2 rs renames body) exni)
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:bind (?formals* . ?body*) renames]
|
||||
[#:pattern (?lambda ?formals . ?body)]
|
||||
|
|
@ -127,7 +136,7 @@
|
|||
[Block ?body body])]
|
||||
[(struct p:case-lambda (e1 e2 rs renames+bodies))
|
||||
#;
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?case-lambda [?formals . ?body] ...)]
|
||||
[#:bind [(?formals* . ?body*) ...] (map car renames+bodies)]
|
||||
|
|
@ -144,10 +153,11 @@
|
|||
(syntax->list #'(?formals* ...))
|
||||
e1 mid 'rename-case-lambda)
|
||||
;; FIXME: Missing renames frames here
|
||||
(R mid (CASE-LAMBDA [FORMALS . BODY] ...)
|
||||
(R mid
|
||||
[#:pattern (CASE-LAMBDA [FORMALS . BODY] ...)]
|
||||
[Block (BODY ...) (map cdr renames+bodies)]))))]
|
||||
[(AnyQ p:let-values (e1 e2 rs renames rhss body) exni)
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
|
||||
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
|
||||
|
|
@ -159,7 +169,7 @@
|
|||
[Expr (?rhs ...) rhss]
|
||||
[Block ?body body])]
|
||||
[(AnyQ p:letrec-values (e1 e2 rs renames rhss body) exni)
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
|
||||
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
|
||||
|
|
@ -172,7 +182,7 @@
|
|||
[Block ?body body])]
|
||||
[(AnyQ p:letrec-syntaxes+values
|
||||
(e1 e2 rs srenames srhss vrenames vrhss body) exni)
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
|
||||
[#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs] ...) . ?body*) srenames]
|
||||
|
|
@ -216,18 +226,19 @@
|
|||
|
||||
;; The rest of the automatic primitives
|
||||
[(AnyQ p::STOP (e1 e2 rs) exni)
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni])]
|
||||
|
||||
[(AnyQ p:set!-macro (e1 e2 rs deriv) exni)
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
=> (lambda (mid)
|
||||
(reductions deriv)))]
|
||||
(reductions* deriv)))]
|
||||
[(AnyQ p:set! (e1 e2 rs id-rs rhs) exni)
|
||||
(R e1 _
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (SET! VAR RHS)]
|
||||
[#:learn id-rs]
|
||||
[Expr RHS rhs])]
|
||||
|
||||
;; Synthetic primitives
|
||||
|
|
@ -245,7 +256,7 @@
|
|||
[deriv0 (s:subterm-deriv subterm0)])
|
||||
(let ([ctx (lambda (x) (path-replace term path0 x))])
|
||||
(append (with-context ctx
|
||||
(reductions deriv0))
|
||||
(reductions* deriv0))
|
||||
(loop (and (deriv? deriv0)
|
||||
(path-replace term path0 (deriv-e2 deriv0)))
|
||||
(cdr subterms)))))]
|
||||
|
|
@ -260,21 +271,21 @@
|
|||
|
||||
;; FIXME
|
||||
[(IntQ p:rename (e1 e2 rs rename inner))
|
||||
(reductions inner)]
|
||||
(reductions* inner)]
|
||||
|
||||
;; Error
|
||||
|
||||
;; Macros
|
||||
[(IntQ mrule (e1 e2 transformation next))
|
||||
(append (reductions-transformation transformation)
|
||||
(reductions next))]
|
||||
(reductions* next))]
|
||||
|
||||
;; Lifts
|
||||
|
||||
[(IntQ lift-deriv (e1 e2 first lifted-stx second))
|
||||
(append (reductions first)
|
||||
(append (reductions* first)
|
||||
(list (walk (deriv-e2 first) lifted-stx 'capture-lifts))
|
||||
(reductions second))]
|
||||
(reductions* second))]
|
||||
|
||||
;; Skipped
|
||||
|
||||
|
|
@ -287,13 +298,17 @@
|
|||
(define (reductions-transformation tx)
|
||||
(match tx
|
||||
[(struct transformation (e1 e2 rs me1 me2 locals seq))
|
||||
(learn-definites rs)
|
||||
(append (reductions-locals e1 locals)
|
||||
(list (walk e1 e2 'macro-step)))]
|
||||
[(IntW transformation (e1 e2 rs me1 me2 locals seq) 'locals)
|
||||
(learn-definites rs)
|
||||
(reductions-locals e1 locals)]
|
||||
[(ErrW transformation (e1 e2 rs me1 me2 locals seq) 'bad-transformer exn)
|
||||
(learn-definites rs)
|
||||
(list (stumble e1 exn))]
|
||||
[(ErrW transformation (e1 e2 rs me1 me2 locals seq) 'transform exn)
|
||||
(learn-definites rs)
|
||||
(append (reductions-locals e1 locals)
|
||||
(list (stumble e1 exn)))]))
|
||||
|
||||
|
|
@ -306,13 +321,13 @@
|
|||
(define (reductions-local local)
|
||||
(match/with-derivation local
|
||||
[(struct local-expansion (e1 e2 me1 me2 deriv))
|
||||
(reductions deriv)]
|
||||
(reductions* deriv)]
|
||||
[(struct local-lift (expr id))
|
||||
(list (walk expr id 'local-lift))]
|
||||
[(struct local-lift-end (decl))
|
||||
(list (walk decl decl 'module-lift))]
|
||||
[(struct local-bind (deriv))
|
||||
(reductions deriv)]))
|
||||
(reductions* deriv)]))
|
||||
|
||||
;; list-reductions : ListDerivation -> ReductionSequence
|
||||
(define (list-reductions ld)
|
||||
|
|
@ -322,7 +337,7 @@
|
|||
(cond [(pair? derivs)
|
||||
(append
|
||||
(with-context (lambda (x) (cons x (stx-cdr suffix)))
|
||||
(reductions (car derivs)))
|
||||
(reductions* (car derivs)))
|
||||
(with-context (lambda (x) (cons (deriv-e2 (car derivs)) x))
|
||||
(loop (cdr derivs) (stx-cdr suffix))))]
|
||||
[(null? derivs)
|
||||
|
|
@ -362,17 +377,17 @@
|
|||
(let ([estx (deriv-e2 head)])
|
||||
(loop next (stx-cdr suffix) (cons estx prefix)
|
||||
(cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
|
||||
(reductions head))
|
||||
(reductions* head))
|
||||
rss)))]
|
||||
[(IntW b:expr (renames head) tag)
|
||||
(loop next #f #f
|
||||
(cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
|
||||
(reductions head))
|
||||
(reductions* head))
|
||||
rss))]
|
||||
[(struct b:defvals (renames head))
|
||||
(let ([head-rs
|
||||
(with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
|
||||
(reductions head))])
|
||||
(reductions* head))])
|
||||
(loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix)
|
||||
(cons head-rs rss)))]
|
||||
[(AnyQ b:defstx (renames head rhs))
|
||||
|
|
@ -386,8 +401,8 @@
|
|||
(loop next (stx-cdr suffix) (cons estx2 prefix)
|
||||
(with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
|
||||
(cons (with-context (CC ?rhs estx (?ds ?vars ?rhs))
|
||||
(reductions rhs))
|
||||
(cons (reductions head)
|
||||
(reductions* rhs))
|
||||
(cons (reductions* head)
|
||||
rss)))))]
|
||||
[(struct b:splice (renames head tail))
|
||||
(loop next tail prefix
|
||||
|
|
@ -401,7 +416,7 @@
|
|||
'splice-block))
|
||||
(cons (with-context (lambda (x)
|
||||
(revappend prefix (cons x (stx-cdr suffix))))
|
||||
(reductions head))
|
||||
(reductions* head))
|
||||
rss)))]
|
||||
[(struct b:begin (renames head derivs))
|
||||
;; FIXME
|
||||
|
|
@ -430,24 +445,24 @@
|
|||
[(struct mod:skip ())
|
||||
(loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))]
|
||||
[(struct mod:cons (head))
|
||||
(append (with-context the-context (append (reductions head)))
|
||||
(append (with-context the-context (append (reductions* head)))
|
||||
(let ([estx (and (deriv? head) (deriv-e2 head))])
|
||||
(loop next (stx-cdr suffix) (cons estx prefix))))]
|
||||
[(AnyQ mod:prim (head prim))
|
||||
(append (with-context the-context
|
||||
(append (reductions head)
|
||||
(reductions prim)))
|
||||
(append (reductions* head)
|
||||
(reductions* prim)))
|
||||
(let ([estx
|
||||
(if prim
|
||||
(lift/deriv-e2 prim)
|
||||
(and (deriv? head) (deriv-e2 head)))])
|
||||
(loop next (stx-cdr suffix) (cons estx prefix))))]
|
||||
[(ErrW mod:splice (head stxs) exn)
|
||||
(append (with-context the-context (reductions head))
|
||||
(append (with-context the-context (reductions* head))
|
||||
(list (stumble (deriv-e2 head) exn)))]
|
||||
[(struct mod:splice (head stxs))
|
||||
(append
|
||||
(with-context the-context (reductions head))
|
||||
(with-context the-context (reductions* head))
|
||||
(let ([suffix-tail (stx-cdr suffix)]
|
||||
[head-e2 (deriv-e2 head)])
|
||||
(cons (walk/foci head-e2
|
||||
|
|
@ -460,7 +475,7 @@
|
|||
(loop next stxs prefix))))]
|
||||
[(struct mod:lift (head stxs))
|
||||
(append
|
||||
(with-context the-context (reductions head))
|
||||
(with-context the-context (reductions* head))
|
||||
(let ([suffix-tail (stx-cdr suffix)]
|
||||
[head-e2 (deriv-e2 head)])
|
||||
(let ([new-suffix (append stxs (cons head-e2 suffix-tail))])
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
|
||||
;; A ReductionSequence is a (list-of Reduction)
|
||||
|
||||
;; A ProtoStep is (make-protostep Derivation BigContext StepType Context)
|
||||
;; A ProtoStep is (make-protostep Derivation BigContext StepType Context Definites)
|
||||
|
||||
;; A Context is a list of Frames
|
||||
;; A Frame is either:
|
||||
|
|
@ -14,6 +14,8 @@
|
|||
;; - 'phase-up
|
||||
(define-struct renames (old new))
|
||||
|
||||
;; A Definite is a (list-of identifier)
|
||||
|
||||
;; A BigContext is (list-of BigFrame)
|
||||
;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax)
|
||||
(define-struct bigframe (deriv ctx foci e))
|
||||
|
|
@ -22,7 +24,7 @@
|
|||
;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
|
||||
;; - (make-misstep ... Syntax Syntax Exception)
|
||||
|
||||
(define-struct protostep (deriv lctx type ctx) #f)
|
||||
(define-struct protostep (deriv lctx type ctx definites) #f)
|
||||
|
||||
(define-struct (step protostep) (foci1 foci2 e1 e2) #f)
|
||||
(define-struct (misstep protostep) (foci1 e1 exn) #f)
|
||||
|
|
|
|||
|
|
@ -57,7 +57,8 @@
|
|||
|
||||
(define text:arrows<%>
|
||||
(interface (text:mouse-drawings<%>)
|
||||
add-arrow))
|
||||
add-arrow
|
||||
add-question-arrow))
|
||||
|
||||
(define text:drawings-mixin
|
||||
(mixin (text:basic<%>) (text:drawings<%>)
|
||||
|
|
@ -138,6 +139,12 @@
|
|||
(send the-font-list find-or-create-font size 'default 'normal 'bold)))
|
||||
|
||||
(define/public (add-arrow from1 from2 to1 to2 color)
|
||||
(internal-add-arrow from1 from2 to1 to2 color #f))
|
||||
|
||||
(define/public (add-question-arrow from1 from2 to1 to2 color)
|
||||
(internal-add-arrow from1 from2 to1 to2 color #t))
|
||||
|
||||
(define/private (internal-add-arrow from1 from2 to1 to2 color question?)
|
||||
(unless (and (= from1 to1) (= from2 to2))
|
||||
(let ([draw
|
||||
(lambda (text dc left top right bottom dx dy)
|
||||
|
|
@ -158,12 +165,13 @@
|
|||
(send dc set-brush arrow-brush)
|
||||
(draw-arrow dc startx starty endx endy dx dy)
|
||||
#;(send dc set-text-mode 'solid)
|
||||
(when question?
|
||||
(send dc set-font (?-font dc))
|
||||
(send dc set-text-foreground
|
||||
(send the-color-database find-color color))
|
||||
(send dc draw-text "?"
|
||||
(+ (+ startx dx) fw)
|
||||
(- (+ starty dy) fh)))))))])
|
||||
(- (+ starty dy) fh))))))))])
|
||||
(add-mouse-drawing from1 from2 draw)
|
||||
(add-mouse-drawing to1 to2 draw))))
|
||||
|
||||
|
|
|
|||
|
|
@ -96,10 +96,12 @@
|
|||
(send -text insert text)))
|
||||
|
||||
(define/public add-syntax
|
||||
(lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table)
|
||||
(lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null])
|
||||
(when (and (pair? hi-stxs) (not hi-color))
|
||||
(error 'syntax-widget%::add-syntax "no highlight color specified"))
|
||||
(let ([colorer (internal-add-syntax stx hi-stxs hi-color)])
|
||||
(let ([colorer (internal-add-syntax stx hi-stxs hi-color)]
|
||||
[definite-table (make-hash-table)])
|
||||
(for-each (lambda (x) (hash-table-put! definite-table x #t)) definites)
|
||||
(when alpha-table
|
||||
(let ([range (send colorer get-range)])
|
||||
(for-each (lambda (id)
|
||||
|
|
@ -111,10 +113,15 @@
|
|||
(for-each
|
||||
(lambda (binder-r)
|
||||
(for-each (lambda (id-r)
|
||||
(if (hash-table-get definite-table id #f)
|
||||
(send -text add-arrow
|
||||
(car id-r) (cdr id-r)
|
||||
(car binder-r) (cdr binder-r)
|
||||
"purple"))
|
||||
"blue")
|
||||
(send -text add-question-arrow
|
||||
(car id-r) (cdr id-r)
|
||||
(car binder-r) (cdr binder-r)
|
||||
"purple")))
|
||||
(send range get-ranges id)))
|
||||
(send range get-ranges binder)))))
|
||||
(send colorer get-identifier-list))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user