Macro stepper:
improved interaction of hiding and lifting (outside of modules, mostly) only mzscheme's top-interaction is stripped off automatically now svn: r5754
This commit is contained in:
Ryan Culpepper
parent
eb8e3c7d18
commit
64f062f5a5
|
|
@ -157,7 +157,7 @@
|
|||
[(enter-local local-pre (? EE) local-post exit-local)
|
||||
(make-local-expansion $1 $5 $2 $4 $3)]
|
||||
[(lift)
|
||||
(make-local-lift (car $1) (cdr $1))]
|
||||
(make-local-lift (cdr $1) (car $1))]
|
||||
[(lift-statement)
|
||||
(make-local-lift-end $1)]
|
||||
[(phase-up (? EE/LetLifts))
|
||||
|
|
|
|||
|
|
@ -173,7 +173,7 @@
|
|||
[(AnyQ mrule (_ _ tx next))
|
||||
(join (loop tx) (loop next))]
|
||||
[(AnyQ lift-deriv (_ _ first lift second))
|
||||
(join (loop first) (loop lift) (loop second))]
|
||||
(join (loop first) (loop second))]
|
||||
[(AnyQ transformation (_ _ _ _ _ locals _))
|
||||
(loops locals)]
|
||||
[(struct local-expansion (_ _ _ _ deriv))
|
||||
|
|
@ -259,8 +259,8 @@
|
|||
(pred e1)]
|
||||
[_ #f])
|
||||
(match-lambda
|
||||
;; FIXME: Why?
|
||||
[(AnyQ p:module (_ _ _ _ _)) #t]
|
||||
[(AnyQ lift-deriv (_ _ _ _ _)) #t]
|
||||
[_ #f])
|
||||
d))
|
||||
|
||||
|
|
|
|||
|
|
@ -29,6 +29,55 @@
|
|||
(define (warn tag message) ((current-hiding-warning-handler) tag message))
|
||||
|
||||
|
||||
;; current-unvisited-lifts : (paramter-of Derivation)
|
||||
;; The derivs for the lifts yet to be seen in the processing
|
||||
;; of the first part of the current lift-deriv.
|
||||
(define current-unvisited-lifts (make-parameter null))
|
||||
|
||||
;; current-unhidden-lifts : (parameter-of Derivation)
|
||||
;; The derivs for those lifts that occur within unhidden macros.
|
||||
;; Derivs are moved from the current-unvisited-lifts to this list.
|
||||
(define current-unhidden-lifts (make-parameter null))
|
||||
|
||||
;; add-unhidden-lift : Derivation -> void
|
||||
(define (add-unhidden-lift d)
|
||||
(current-unhidden-lifts (cons d (current-unhidden-lifts))))
|
||||
|
||||
;; extract/remove-unvisted-lift : identifier -> Derivation
|
||||
(define (extract/remove-unvisited-lift id)
|
||||
(define (get-defined-id d)
|
||||
(match d
|
||||
[(AnyQ deriv (e1 e2))
|
||||
(with-syntax ([(?define-values (?id) ?expr) e1])
|
||||
#'?id)]))
|
||||
;; The Wrong Way
|
||||
(let ([unvisited (current-unvisited-lifts)])
|
||||
(unless (pair? unvisited)
|
||||
(error 'hide:extract/remove-unvisited-lift
|
||||
"out of lifts!"))
|
||||
(let ([lift (car unvisited)])
|
||||
(current-unvisited-lifts (cdr unvisited))
|
||||
lift))
|
||||
;; The Right Way
|
||||
;; FIXME: Doesn't work inside of modules. Why not?
|
||||
#;
|
||||
(let loop ([lifts (current-unvisited-lifts)]
|
||||
[prefix null])
|
||||
(cond [(null? lifts)
|
||||
#;(fprintf (current-error-port)
|
||||
"hide:extract/remove-unvisited-lift: couldn't find lift for ~s~n"
|
||||
id)
|
||||
(raise (make-localactions))]
|
||||
[(bound-identifier=? id (get-defined-id (car lifts)))
|
||||
(let ([lift (car lifts)])
|
||||
(current-unvisited-lifts
|
||||
(let loop ([prefix prefix] [lifts (cdr lifts)])
|
||||
(if (null? prefix)
|
||||
lifts
|
||||
(loop (cdr prefix) (cons (car prefix) lifts)))))
|
||||
lift)]
|
||||
[else
|
||||
(loop (cdr lifts) (cons (car lifts) prefix))])))
|
||||
|
||||
;
|
||||
;
|
||||
|
|
@ -67,6 +116,7 @@
|
|||
;; Benefits of 1:
|
||||
;; Preserves order of expansion, even if macro reorders (so effects happen right)
|
||||
;; May be easier to deal with marking/renaming
|
||||
;; Easier to deal with lifting (lifts get seen in correct order)
|
||||
;; Gives finer control over handling of blocks (joining pass1 and pass2 expansions)
|
||||
;; Drawbacks of 1:
|
||||
;; Need to process results more to find final syntax & nonlinear subterms
|
||||
|
|
@ -274,7 +324,7 @@
|
|||
[(AnyQ mrule (e1 e2 tx next))
|
||||
(let ([show-k
|
||||
(lambda ()
|
||||
(recv #;[(tx) (for-transformation tx)]
|
||||
(recv [(tx) (for-transformation tx)]
|
||||
[(next e2) (for-deriv next)]
|
||||
(values (rewrap d (make-mrule e1 e2 tx next))
|
||||
e2)))])
|
||||
|
|
@ -296,113 +346,88 @@
|
|||
|
||||
;; Lift
|
||||
;; Shaky invariant:
|
||||
;; Only normal lifts occur in first... no end-module-decl lifts.
|
||||
;; Only lift-exprs occur in first... no lift-end-module-decls
|
||||
;; They occur in reverse order.
|
||||
;; PROBLEM: Hiding process may disturb order lifts are seen.
|
||||
[(IntQ lift-deriv (e1 e2 first lifted-stx second) tag)
|
||||
;; Option 1: Give up on first, hide on second
|
||||
#;
|
||||
(begin (warn 'lifts "lifts are unimplemented")
|
||||
(let-values ([(second e2) (for-deriv second)])
|
||||
(values (rewrap d (make-lift-deriv e1 e2 first lifted-stx second))
|
||||
e2)))
|
||||
;; Option 2: Hide first, show *all* lifted expressions,
|
||||
;; and hide second (lifted defs only; replace last expr with first-e2)
|
||||
(let* ([second-derivs
|
||||
(match second
|
||||
[(IntQ p:begin (_ _ _ (IntQ lderiv (_ _ inners))))
|
||||
(reverse inners)])]
|
||||
[lift-stxs
|
||||
(with-syntax ([(?begin form ...) lifted-stx])
|
||||
(cdr (reverse (syntax->list #'(form ...)))))]
|
||||
[lift-derivs
|
||||
[lift-derivs/0
|
||||
;; If interrupted, then main-expr deriv will not be in list
|
||||
;; second-derivs are already reversed
|
||||
(if tag second-derivs (cdr second-derivs))]
|
||||
[begin-stx (stx-car lifted-stx)])
|
||||
(let-values ([(first-d first-e2) (for-deriv first)])
|
||||
(define lifted-stx*
|
||||
(datum->syntax-object lifted-stx
|
||||
`(,begin-stx ,@(reverse lift-stxs) ,first-e2)
|
||||
lifted-stx
|
||||
lifted-stx))
|
||||
(define main-deriv (make-p:stop first-e2 first-e2 null))
|
||||
(define inner-derivs
|
||||
(reverse
|
||||
;; If interrupted, then main-expr deriv will not be in list
|
||||
(if tag lift-derivs (cons main-deriv lift-derivs))))
|
||||
(define lderiv*
|
||||
(rewrap second
|
||||
(make-lderiv (map lift/deriv-e1 inner-derivs)
|
||||
(and (not tag)
|
||||
(map lift/deriv-e2 inner-derivs))
|
||||
inner-derivs)))
|
||||
(define-values (lderiv** es2**) (for-lderiv lderiv*))
|
||||
(define e2*
|
||||
(and es2**
|
||||
(datum->syntax-object e2 `(,begin-stx ,@es2**) e2 e2)))
|
||||
(define second*
|
||||
(rewrap second (make-p:begin lifted-stx* e2* null lderiv**)))
|
||||
(values (rewrap d (make-lift-deriv e1 e2* first-d lifted-stx* second*))
|
||||
e2*)))
|
||||
#;
|
||||
;; Option3: Hide first, retaining transparent lifts and inlining opaque lifts
|
||||
;; Hide second, only on retained lifts
|
||||
;; Problem: lift order may be damaged by other hiding processes
|
||||
(let* ([second-derivs
|
||||
(match second
|
||||
[(IntQ p:begin (_ _ _ (IntQ lderiv (_ _ inners))))
|
||||
(reverse inners)])]
|
||||
[lift-stxs
|
||||
(with-syntax ([(?begin form ...) lifted-stx])
|
||||
(cdr (reverse (syntax->list #'(form ...)))))]
|
||||
[lift-derivs (cdr second-derivs)]
|
||||
[begin-stx (stx-car lifted-stx)])
|
||||
(let-values ([(first-d first-e2 retained-lifts)
|
||||
(parameterize ((lifts-available (map cons lift-stxs lift-derivs))
|
||||
(lifts-retained null))
|
||||
(let-values ([(first-d first-e2) (for-deriv first)])
|
||||
(unless (null? (lifts-available))
|
||||
(printf "hide: lift-deriv: unused lift derivs!~n"))
|
||||
(values first-d first-e2 (lifts-retained))))])
|
||||
;; If all the lifts were hidden, then remove lift-deriv node
|
||||
;; Otherwise, recreate with the retained lifts
|
||||
(if (null? retained-lifts)
|
||||
(values first-d first-e2)
|
||||
(let ()
|
||||
(define retained-stxs (map car retained-lifts))
|
||||
(define retained-derivs (map cdr retained-lifts))
|
||||
(define lifted-stx*
|
||||
(datum->syntax-object lifted-stx
|
||||
`(,begin-stx ,@retained-stxs ,first-e2)
|
||||
lifted-stx
|
||||
lifted-stx))
|
||||
(define main-deriv (make-p:stop first-e2 first-e2 null))
|
||||
(define inner-derivs
|
||||
(if tag retained-derivs (append retained-derivs main-deriv)))
|
||||
(define lderiv*
|
||||
(rewrap second
|
||||
(make-lderiv (map lift/deriv-e1 inner-derivs)
|
||||
(map lift/deriv-e2 inner-derivs)
|
||||
inner-derivs)))
|
||||
(define-values (ld*-d ld*-es2) (for-lderiv lderiv*))
|
||||
(define e2*
|
||||
(and ld*-es2
|
||||
(datum->syntax-object e2 `(,begin-stx ,@ld*-es2) e2 e2)))
|
||||
(define second*
|
||||
(rewrap second (make-p:begin lifted-stx* e2* null ld*-d)))
|
||||
(values (make-lift-deriv e1 e2* first-d lifted-stx* second*)
|
||||
e2*)))))]
|
||||
|
||||
(define-values (first-d first-e2 lift-derivs)
|
||||
;; Note: lift-derivs are back in reverse order from current-unvisited-lifts
|
||||
(parameterize ((current-unvisited-lifts lift-derivs/0)
|
||||
(current-unhidden-lifts null))
|
||||
#;(printf "setting current-unvisited-lifts: ~s~n" (length lift-derivs/0))
|
||||
(let-values ([(d e2) (for-deriv first)])
|
||||
(when (pair? (current-unvisited-lifts))
|
||||
(error 'hide:lift-deriv "missed ~s lift-expressions: ~s"
|
||||
(length (current-unvisited-lifts))
|
||||
(current-unvisited-lifts)))
|
||||
(values d e2 (current-unhidden-lifts)))))
|
||||
(define lift-stxs (map lift/deriv-e1 lift-derivs))
|
||||
(define main-deriv (make-p:stop first-e2 first-e2 null))
|
||||
;; If no lifted syntaxes remain, then simplify:
|
||||
(if (null? lift-derivs)
|
||||
(values first-d first-e2)
|
||||
(let ()
|
||||
(define lifted-stx*
|
||||
(datum->syntax-object lifted-stx
|
||||
`(,begin-stx ,@lift-stxs ,first-e2)
|
||||
lifted-stx
|
||||
lifted-stx))
|
||||
(define inner-derivs
|
||||
;; If interrupted, then main-expr deriv will not be in list
|
||||
(if tag lift-derivs (append lift-derivs (list main-deriv))))
|
||||
(define lderiv*
|
||||
(rewrap second
|
||||
(make-lderiv (map lift/deriv-e1 inner-derivs)
|
||||
(and (not tag)
|
||||
(map lift/deriv-e2 inner-derivs))
|
||||
inner-derivs)))
|
||||
(define-values (lderiv** es2**) (for-lderiv lderiv*))
|
||||
(define e2*
|
||||
(and es2**
|
||||
(datum->syntax-object e2 `(,begin-stx ,@es2**) e2 e2)))
|
||||
(define second*
|
||||
(rewrap second (make-p:begin lifted-stx* e2* null lderiv**)))
|
||||
(values (rewrap d (make-lift-deriv e1 e2* first-d lifted-stx* second*))
|
||||
e2*))))]
|
||||
|
||||
;; Errors
|
||||
|
||||
[#f (values #f #f)]))
|
||||
|
||||
;; for-transformation : Transformation -> Transformation???
|
||||
#;
|
||||
(define (for-transformation tx)
|
||||
(match tx
|
||||
[(IntQ transformation (e1 e2 rs me1 me2 locals _seq))
|
||||
(error 'unimplemented "hide: for-transformation")]))
|
||||
[(AnyQ transformation (e1 e2 rs me1 me2 locals _seq))
|
||||
(let ([locals (map for-local-action (or locals null))])
|
||||
(rewrap tx (make-transformation e1 e2 rs me1 me2 locals _seq)))]))
|
||||
|
||||
;; for-local-action : LocalAction -> LocalAction
|
||||
(define (for-local-action la)
|
||||
(match la
|
||||
[(struct local-expansion (e1 e2 me1 me2 deriv))
|
||||
(let-values ([(deriv e2) (for-deriv deriv)])
|
||||
(make-local-expansion e1 e2 me1 me2 deriv))]
|
||||
[(struct local-lift (expr id))
|
||||
(add-unhidden-lift (extract/remove-unvisited-lift id))
|
||||
la]
|
||||
[(struct local-lift-end (decl))
|
||||
;;(printf "hide:for-local-action: local-lift-end unimplemented~n")
|
||||
la]
|
||||
[(struct local-bind (deriv))
|
||||
(let-values ([(deriv e2) (for-deriv deriv)])
|
||||
(make-local-bind deriv))]))
|
||||
|
||||
;; for-rename : Rename -> (values Rename syntax)
|
||||
(define (for-rename rename)
|
||||
(values rename rename))
|
||||
|
|
@ -504,7 +529,8 @@
|
|||
(define (create-synth-deriv e1 subterm-derivs)
|
||||
(define (error? x)
|
||||
(and (s:subterm? x)
|
||||
(or (interrupted-wrap? (s:subterm-deriv x)) (error-wrap? (s:subterm-deriv x)))))
|
||||
(or (interrupted-wrap? (s:subterm-deriv x))
|
||||
(error-wrap? (s:subterm-deriv x)))))
|
||||
(let ([errors
|
||||
(map s:subterm-deriv (filter error? subterm-derivs))]
|
||||
[subterms (filter (lambda (x) (not (error? x))) subterm-derivs)])
|
||||
|
|
@ -520,23 +546,30 @@
|
|||
(define (subterm-derivations d)
|
||||
|
||||
;; for-deriv : Derivation -> (list-of Subterm)
|
||||
;; FIXME: finish
|
||||
(define (for-deriv d)
|
||||
(let ([path (check-visible d)])
|
||||
(if path
|
||||
(let-values ([(d _) (hide d)])
|
||||
(list (make-s:subterm path d)))
|
||||
(for-unlucky-deriv/record-error d))))
|
||||
|
||||
;; check-visible : Derivation -> Path/#f
|
||||
(define (check-visible d)
|
||||
(match d
|
||||
[(AnyQ deriv (e1 e2))
|
||||
(let ([paths (table-get (subterms-table) e1)])
|
||||
(cond [(null? paths)
|
||||
(for-unlucky-deriv/record-error d)]
|
||||
(cond [(null? paths) #f]
|
||||
[(null? (cdr paths))
|
||||
(let-values ([(d _) (hide d)])
|
||||
(list (make-s:subterm (car paths) d)))]
|
||||
(car paths)]
|
||||
[else
|
||||
;; More than one path to the same(eq?) syntax object
|
||||
;; Not good.
|
||||
;; FIXME: Better to delay check to here, or check whole table first?
|
||||
;; FIXME
|
||||
(raise (make-nonlinearity "nonlinearity in original term" paths))]))]
|
||||
[#f null]))
|
||||
(raise
|
||||
(make-nonlinearity
|
||||
"nonlinearity in original term" paths))]))]
|
||||
[#f #f]))
|
||||
|
||||
;; for-unluck-deriv/record-error -> (list-of Subterm)
|
||||
;; Guarantee: (deriv-e1 deriv) is not in subterms table
|
||||
|
|
@ -643,27 +676,25 @@
|
|||
[(AnyQ mrule (e1 e2 (and ew (struct error-wrap (_ _ _))) next))
|
||||
(list (make-s:subterm #f ew))]
|
||||
|
||||
|
||||
|
||||
[(AnyQ lift-deriv (e1 e2 first lifted-stx next))
|
||||
#;(printf "encountered lift-deriv in seek mode!~n")
|
||||
(raise (make-localactions))
|
||||
(>>Seek (for-deriv first)
|
||||
(for-deriv next))]
|
||||
|
||||
|
||||
;; Errors
|
||||
|
||||
; [(struct error-wrap (exn tag (? deriv? inner)))
|
||||
; (append (for-deriv inner)
|
||||
; (list (make-s:subterm #f (make-error-wrap exn tag #f))))]
|
||||
[#f null]
|
||||
))
|
||||
|
||||
;; for-transformation : Transformation -> (values (list-of Subterm) Table)
|
||||
(define (for-transformation tx)
|
||||
(match tx
|
||||
[(struct transformation (e1 e2 rs me1 me2 locals _seq))
|
||||
[(IntQ transformation (e1 e2 rs me1 me2 locals _seq))
|
||||
;; FIXME: We'll need to use e1/e2/me1/me2 to synth locals, perhaps
|
||||
;; FIXME: and we'll also need to account for *that* marking, too...
|
||||
(unless (null? locals)
|
||||
(raise (make-localactions)))
|
||||
(for-each for-local-action (or locals null))
|
||||
;(let* ([table-at-end #f]
|
||||
; [subterms
|
||||
; (>>Seek [#:rename (do-rename e1 me1)]
|
||||
|
|
@ -674,25 +705,30 @@
|
|||
; (values subterms table-at-end))
|
||||
(let-values ([(rename-subterms1 table1) (do-rename e1 me1)])
|
||||
(parameterize ((subterms-table table1))
|
||||
(let (#;[sss (map for-local locals)])
|
||||
(let () ;; [sss (map for-local locals)]
|
||||
(let-values ([(rename-subterms2 table2) (do-rename me2 e2)])
|
||||
;; FIXME: Including these seems to produce evil results
|
||||
;; ie, parts of the hidden macro use appear as marked
|
||||
;; when they shouldn't
|
||||
(values (append #;rename-subterms1
|
||||
#;(apply append sss)
|
||||
#;rename-subterms2)
|
||||
table2)))))]))
|
||||
(values null ;; (append rename-subterms1 (apply append sss) rename-subterms2)
|
||||
table2)))))]
|
||||
[(ErrW transformation (e1 e2 rs me1 me2 locals _seq))
|
||||
(for-each for-local-action (or locals null))
|
||||
(values null #f)]))
|
||||
|
||||
;; for-local : LocalAction -> (list-of Subterm)
|
||||
#;
|
||||
(define (for-local local)
|
||||
;; for-local-action : LocalAction -> (list-of Subterm)
|
||||
(define (for-local-action local)
|
||||
(match local
|
||||
[(IntQ local-expansion (e1 e2 me1 me2 deriv))
|
||||
(error 'unimplemented "seek: for-local")]
|
||||
;; Also need to handle local-bind
|
||||
;; ...
|
||||
[else null]))
|
||||
[(struct local-expansion (e1 e2 me1 me2 deriv))
|
||||
(raise (make-localactions))]
|
||||
[(struct local-lift (expr id))
|
||||
;; FIXME: seek in the lifted deriv, transplant subterm expansions *here*
|
||||
(extract/remove-unvisited-lift id)]
|
||||
[(struct local-lift-end (decl))
|
||||
;; FIXME!!!
|
||||
(void)]
|
||||
[(struct local-bind (deriv))
|
||||
(raise (make-localactions))]))
|
||||
|
||||
;; for-lderiv : ListDerivation -> (list-of Subterm)
|
||||
(define (for-lderiv ld)
|
||||
|
|
|
|||
|
|
@ -37,13 +37,13 @@
|
|||
(define (reductions d)
|
||||
(parameterize ((current-definites null)
|
||||
(current-frontier null))
|
||||
(add-frontier (list (lift/deriv-e1 d)))
|
||||
(when d (add-frontier (list (lift/deriv-e1 d))))
|
||||
(reductions* d)))
|
||||
|
||||
(define (reductions+definites d)
|
||||
(parameterize ((current-definites null)
|
||||
(current-frontier null))
|
||||
(add-frontier (list (lift/deriv-e1 d)))
|
||||
(when d (add-frontier (list (lift/deriv-e1 d))))
|
||||
(let ([rs (reductions* d)])
|
||||
(values rs (current-definites)))))
|
||||
|
||||
|
|
@ -129,13 +129,13 @@
|
|||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?begin . LDERIV)]
|
||||
[#:frontier (stx->list #'LDERIV)]
|
||||
[#:frontier (stx->list* #'LDERIV)]
|
||||
[List LDERIV lderiv])]
|
||||
[(AnyQ p:begin0 (e1 e2 rs first lderiv) exni)
|
||||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?begin0 FIRST . LDERIV)]
|
||||
[#:frontier (cons #'FIRST (stx->list #'LDERIV))]
|
||||
[#:frontier (cons #'FIRST (stx->list* #'LDERIV))]
|
||||
[Expr FIRST first]
|
||||
[List LDERIV lderiv])]
|
||||
[(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni)
|
||||
|
|
@ -143,7 +143,7 @@
|
|||
(R tagged-stx
|
||||
[! exni]
|
||||
[#:pattern (?#%app . LDERIV)]
|
||||
[#:frontier (stx->list #'LDERIV)]
|
||||
[#:frontier (stx->list* #'LDERIV)]
|
||||
[List LDERIV lderiv])])
|
||||
(if (eq? tagged-stx e1)
|
||||
tail
|
||||
|
|
@ -153,7 +153,7 @@
|
|||
[! exni]
|
||||
[#:bind (?formals* . ?body*) renames]
|
||||
[#:pattern (?lambda ?formals . ?body)]
|
||||
[#:frontier (stx->list #'?body)]
|
||||
[#:frontier (stx->list* #'?body)]
|
||||
[#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*))
|
||||
#'?formals #'?formals*
|
||||
'rename-lambda]
|
||||
|
|
@ -173,7 +173,7 @@
|
|||
[Block (?body ...) (map cdr renames+bodies)])
|
||||
(with-syntax ([(?case-lambda [?formals . ?body] ...) e1]
|
||||
[((?formals* . ?body*) ...) (map car renames+bodies)])
|
||||
(add-frontier (apply append (map stx->list (syntax->list #'(?body ...)))))
|
||||
(add-frontier (apply append (map stx->list* (syntax->list #'(?body ...)))))
|
||||
(let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))])
|
||||
(rename-frontier #'(?formals ...) #'(?formals* ...))
|
||||
(cons (walk/foci (syntax->list #'(?formals ...))
|
||||
|
|
@ -187,7 +187,7 @@
|
|||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
|
||||
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list #'?body))]
|
||||
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
|
||||
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
|
||||
[#:rename
|
||||
(syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))
|
||||
|
|
@ -200,7 +200,7 @@
|
|||
(R e1
|
||||
[! exni]
|
||||
[#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
|
||||
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list #'?body))]
|
||||
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
|
||||
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
|
||||
[#:rename
|
||||
(syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))
|
||||
|
|
@ -216,7 +216,7 @@
|
|||
[#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
|
||||
[#:frontier (append (syntax->list #'(?srhs ...))
|
||||
(syntax->list #'(?vrhs ...))
|
||||
(stx->list #'?body))]
|
||||
(stx->list* #'?body))]
|
||||
[#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames]
|
||||
[#:rename
|
||||
(syntax/skeleton e1
|
||||
|
|
@ -338,7 +338,7 @@
|
|||
(blaze-frontier e1)
|
||||
;;(printf "frontier for mrule: ~s~n" (current-frontier))
|
||||
(append (reductions-transformation transformation)
|
||||
(begin (add-frontier (list (lift/deriv-e1 next)))
|
||||
(begin (when next (add-frontier (list (lift/deriv-e1 next))))
|
||||
(reductions* next)))]
|
||||
|
||||
;; Lifts
|
||||
|
|
@ -427,7 +427,7 @@
|
|||
[(AnyQ lderiv (pass2-es1 _ _))
|
||||
(list (walk stxs1 pass2-es1 'block->letrec))])
|
||||
null)
|
||||
(begin (add-frontier (stx->list (lift/lderiv-es1 pass2)))
|
||||
(begin (add-frontier (stx->list* (lift/lderiv-es1 pass2)))
|
||||
(list-reductions pass2))))]
|
||||
[#f null]))
|
||||
|
||||
|
|
@ -590,5 +590,16 @@
|
|||
(set! final-stxs (reverse prefix))
|
||||
null]))])
|
||||
(values reductions final-stxs)))
|
||||
|
||||
|
||||
(define (stx->list* stx)
|
||||
(cond [(pair? stx)
|
||||
(cons (car stx) (stx->list* (cdr stx)))]
|
||||
[(null? stx)
|
||||
null]
|
||||
[(syntax? stx)
|
||||
(let ([x (syntax-e stx)])
|
||||
(if (pair? x)
|
||||
(cons (car x) (stx->list* (cdr x)))
|
||||
(list stx)))]
|
||||
[else null]))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -3,12 +3,14 @@
|
|||
(require (lib "class.ss")
|
||||
(lib "list.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "tool.ss" "drscheme")
|
||||
(lib "bitmap-label.ss" "mrlib")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
"model/trace.ss"
|
||||
"model/deriv-c.ss"
|
||||
"model/deriv-util.ss"
|
||||
(prefix view: "view/interfaces.ss")
|
||||
(prefix view: "view/gui.ss")
|
||||
|
|
@ -180,10 +182,46 @@
|
|||
(set! debugging? saved-debugging?)
|
||||
(when eo (current-expand-observe eo)))))))))
|
||||
|
||||
;; show-deriv/orig-parts
|
||||
;; Strip off mzscheme's #%top-interaction
|
||||
;; Careful: the #%top-interaction node may be inside of a lift-deriv
|
||||
(define/private (show-deriv/orig-parts deriv stepper-promise)
|
||||
(for-each (lambda (d) (show-deriv d stepper-promise))
|
||||
(find-derivs/syntax (lambda (stx) (and (syntax? stx) (syntax-source stx)))
|
||||
deriv)))
|
||||
;; adjust-deriv/lift : Derivation -> (list-of Derivation)
|
||||
(define (adjust-deriv/lift deriv)
|
||||
(match deriv
|
||||
[(IntQ lift-deriv (e1 e2 first lifted-stx second))
|
||||
(let ([first (adjust-deriv/top first)])
|
||||
(and first
|
||||
(let ([e1 (lift/deriv-e1 first)])
|
||||
(rewrap deriv
|
||||
(make-lift-deriv e1 e2 first lifted-stx second)))))]
|
||||
[else (adjust-deriv/top deriv)]))
|
||||
;; adjust-deriv/top : Derivation -> Derivation
|
||||
(define (adjust-deriv/top deriv)
|
||||
(if (syntax-source (lift/deriv-e1 deriv))
|
||||
deriv
|
||||
;; It's not original...
|
||||
;; Strip out mzscheme's top-interactions
|
||||
;; Keep anything that is a non-mzscheme top-interaction
|
||||
;; Drop everything else (not original program)
|
||||
(match deriv
|
||||
[(IntQ mrule (e1 e2 tx next))
|
||||
(match tx
|
||||
[(AnyQ transformation (e1 e2 rs me1 me2 locals seq))
|
||||
(cond [(ormap (lambda (x)
|
||||
(module-identifier=? x #'#%top-interaction))
|
||||
rs)
|
||||
;; Just mzscheme's top-interaction; strip it out
|
||||
(adjust-deriv/top next)]
|
||||
[(equal? (map syntax-e rs) '(#%top-interaction))
|
||||
;; A *different* top interaction; keep it
|
||||
deriv]
|
||||
[else
|
||||
;; Not original and not tagged with top-interaction
|
||||
#f])])]
|
||||
[else #f])))
|
||||
(let ([deriv* (adjust-deriv/lift deriv)])
|
||||
(when deriv* (show-deriv deriv* stepper-promise))))
|
||||
|
||||
(define/private (show-deriv deriv stepper-promise)
|
||||
(parameterize ([current-eventspace drscheme-eventspace])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user