macro-stepper: made syntax display faster, esp for early terms
calculate arrows etc wrt known binders instead of all binders svn: r16416
This commit is contained in:
Ryan Culpepper
parent
266b154dfc
commit
e273dae9b1
|
|
@ -37,6 +37,7 @@
|
|||
[marking-table (parameter/c (or/c hash? false/c))]
|
||||
[current-binders (parameter/c (listof identifier?))]
|
||||
[current-definites (parameter/c (listof identifier?))]
|
||||
[current-binders (parameter/c (listof identifier?))]
|
||||
[current-frontier (parameter/c (listof syntax?))]
|
||||
[sequence-number (parameter/c (or/c false/c exact-nonnegative-integer?))]
|
||||
[phase (parameter/c exact-nonnegative-integer?)]
|
||||
|
|
@ -48,6 +49,7 @@
|
|||
[block-value-bindings (parameter/c (listof syntaxish?))]
|
||||
[block-expressions (parameter/c syntaxish?)]
|
||||
|
||||
[learn-binders ((listof identifier?) . -> . any)]
|
||||
[learn-definites ((listof identifier?) . -> . any)]
|
||||
|
||||
[add-frontier ((listof syntax?) . -> . any)]
|
||||
|
|
@ -82,7 +84,6 @@
|
|||
(define marking-table (make-parameter #f))
|
||||
|
||||
;; current-binders : parameterof (listof identifier)
|
||||
;; FIXME: not yet used
|
||||
(define current-binders (make-parameter null))
|
||||
|
||||
;; current-definites : parameter of (list-of identifier)
|
||||
|
|
@ -160,6 +161,10 @@
|
|||
(current-definites
|
||||
(append ids (current-definites))))
|
||||
|
||||
(define (learn-binders ids)
|
||||
(current-binders
|
||||
(append ids (current-binders))))
|
||||
|
||||
(define (get-frontier) (or (current-frontier) null))
|
||||
|
||||
(define (add-frontier stxs)
|
||||
|
|
@ -322,8 +327,8 @@
|
|||
|
||||
(define (current-state-with e fs)
|
||||
(make state e (foci fs) (context) (big-context)
|
||||
(current-binders) (current-definites) (current-frontier)
|
||||
(sequence-number)))
|
||||
(current-binders) (current-definites)
|
||||
(current-frontier) (sequence-number)))
|
||||
|
||||
(define (walk e1 e2 type
|
||||
#:foci1 [foci1 e1]
|
||||
|
|
|
|||
|
|
@ -253,6 +253,12 @@
|
|||
(check-same-stx 'rename/no-step real-from from))
|
||||
(R** f v p s ws [#:rename pvar to] . more))]
|
||||
|
||||
;; Add to definite binders
|
||||
[(R** f v p s ws [#:binders ids] . more)
|
||||
#:declare ids (expr/c #'(listof identifier))
|
||||
#'(begin (learn-binders (flatten-identifiers (with-syntax1 ([p f]) ids)))
|
||||
(R** f v p s ws . more))]
|
||||
|
||||
;; Add to definite uses
|
||||
[(R** f v p s ws [#:learn ids] . more)
|
||||
#:declare ids (expr/c #'(listof identifier?))
|
||||
|
|
@ -550,3 +556,15 @@
|
|||
(cons (wrongness (stx-car a) (stx-car b))
|
||||
(wrongness (stx-cdr a) (stx-cdr b)))]
|
||||
[else (stx->datum a)]))
|
||||
|
||||
|
||||
;; flatten-identifiers : syntaxlike -> (list-of identifier)
|
||||
(define (flatten-identifiers stx)
|
||||
(syntax-case stx ()
|
||||
[id (identifier? #'id) (list #'id)]
|
||||
[() null]
|
||||
[(x . y) (append (flatten-identifiers #'x) (flatten-identifiers #'y))]
|
||||
[else (error 'flatten-identifers "neither syntax list nor identifier: ~s"
|
||||
(if (syntax? stx)
|
||||
(syntax->datum stx)
|
||||
stx))]))
|
||||
|
|
|
|||
|
|
@ -13,20 +13,21 @@
|
|||
|
||||
;; reductions : WDeriv -> ReductionSequence
|
||||
(define (reductions d)
|
||||
(let-values ([(steps definites estx exn) (reductions+ d)])
|
||||
(let-values ([(steps binders definites estx exn) (reductions+ d)])
|
||||
steps))
|
||||
|
||||
;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
|
||||
(define (reductions+ d)
|
||||
(parameterize ((current-definites null)
|
||||
(current-binders null)
|
||||
(current-frontier null)
|
||||
(hides-flags (list (box #f)))
|
||||
(sequence-number 0))
|
||||
(RScase ((Expr d) (wderiv-e1 d) (wderiv-e1 d) #f null)
|
||||
(lambda (steps stx vstx s)
|
||||
(values (reverse steps) (current-definites) vstx #f))
|
||||
(values (reverse steps) (current-binders) (current-definites) vstx #f))
|
||||
(lambda (steps exn)
|
||||
(values (reverse steps) (current-definites) #f exn)))))
|
||||
(values (reverse steps) (current-binders) (current-definites) #f exn)))))
|
||||
|
||||
;; Syntax
|
||||
|
||||
|
|
@ -97,17 +98,16 @@
|
|||
[! ?1])]
|
||||
[(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2))
|
||||
(R [! ?1]
|
||||
[#:pattern (?define-syntaxes formals ?rhs)]
|
||||
[#:pattern (?define-syntaxes ?vars ?rhs)]
|
||||
[#:binders #'?vars]
|
||||
[Expr/PhaseUp ?rhs rhs]
|
||||
[! ?2])]
|
||||
[(Wrap p:define-values (e1 e2 rs ?1 rhs))
|
||||
(R [! ?1]
|
||||
[#:pattern (?define-values ?formals ?rhs)]
|
||||
[#:pattern (?define-values ?vars ?rhs)]
|
||||
[#:binders #'?vars]
|
||||
[#:when rhs
|
||||
[Expr ?rhs rhs]]
|
||||
[#:when (not rhs)
|
||||
[#:do (DEBUG (printf "=== end (dvrhs) ===\n"))]
|
||||
[#:do (DEBUG (printf "===\n"))]])]
|
||||
[Expr ?rhs rhs]])]
|
||||
[(Wrap p:#%expression (e1 e2 rs ?1 inner #f))
|
||||
(R [! ?1]
|
||||
[#:pattern (?expr-kw ?inner)]
|
||||
|
|
@ -156,6 +156,7 @@
|
|||
[(Wrap p:lambda (e1 e2 rs ?1 renames body))
|
||||
(R [! ?1]
|
||||
[#:pattern (?lambda ?formals . ?body)]
|
||||
[#:binders #'?formals]
|
||||
[#:rename (?formals . ?body) renames 'rename-lambda]
|
||||
[Block ?body body])]
|
||||
[(Wrap p:case-lambda (e1 e2 rs ?1 clauses))
|
||||
|
|
@ -166,12 +167,14 @@
|
|||
(R [! ?1]
|
||||
[#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
|
||||
[#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-let-values]
|
||||
[#:binders #'(?vars ...)]
|
||||
[Expr (?rhs ...) rhss]
|
||||
[Block ?body body])]
|
||||
[(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body))
|
||||
(R [! ?1]
|
||||
[#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
|
||||
[#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values]
|
||||
[#:binders #'(?vars ...)]
|
||||
[Expr (?rhs ...) rhss]
|
||||
[Block ?body body])]
|
||||
[(Wrap p:letrec-syntaxes+values
|
||||
|
|
@ -182,10 +185,12 @@
|
|||
[#:rename (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body)
|
||||
srenames
|
||||
'rename-lsv]
|
||||
[#:binders #'(?svars ... ?vvars ...)]
|
||||
[BindSyntaxes (?srhs ...) srhss]
|
||||
;; If vrenames is #f, no var bindings to rename
|
||||
[#:when vrenames
|
||||
[#:rename (((?vvars ?vrhs) ...) . ?body) vrenames 'rename-lsv]]
|
||||
[#:rename (((?vvars ?vrhs) ...) . ?body) vrenames 'rename-lsv]
|
||||
[#:binders #'(?vvars ...)]]
|
||||
[Expr (?vrhs ...) vrhss]
|
||||
[Block ?body body]
|
||||
[#:pass2]
|
||||
|
|
@ -328,6 +333,7 @@
|
|||
(R [! ?1]
|
||||
[#:pattern ((?formals . ?body) . ?rest)]
|
||||
[#:rename (?formals . ?body) rename 'rename-case-lambda]
|
||||
[#:binders #'?formals]
|
||||
[Block ?body body]
|
||||
[CaseLambdaClauses ?rest rest])]))
|
||||
|
||||
|
|
@ -393,6 +399,7 @@
|
|||
[(struct local-lift (expr ids))
|
||||
;; FIXME: add action
|
||||
(R [#:do (take-lift!)]
|
||||
[#:binders ids]
|
||||
[#:reductions (list (walk expr ids 'local-lift))])]
|
||||
|
||||
[(struct local-lift-end (decl))
|
||||
|
|
@ -409,6 +416,7 @@
|
|||
[(struct local-bind (names ?1 renames bindrhs))
|
||||
[R [! ?1]
|
||||
;; FIXME: use renames
|
||||
[#:binders names]
|
||||
[#:when bindrhs => (BindSyntaxes bindrhs)]]]))
|
||||
|
||||
;; List : ListDerivation -> RST
|
||||
|
|
@ -489,11 +497,12 @@
|
|||
[Expr ?first head]
|
||||
[! ?1]
|
||||
[#:pass2]
|
||||
[#:pattern ((?define-values . ?clause) . ?rest)]
|
||||
[#:rename ?clause rename]
|
||||
[#:pattern ((?define-values ?vars . ?body) . ?rest)]
|
||||
[#:rename (?vars . ?body) rename]
|
||||
[#:binders #'?vars]
|
||||
[! ?2]
|
||||
[#:do (block-value-bindings
|
||||
(cons #'?clause (block-value-bindings)))]
|
||||
(cons (cons #'?vars #'?body) (block-value-bindings)))]
|
||||
[#:pattern (?first . ?rest)]
|
||||
[BlockPass ?rest rest])]
|
||||
[(cons (Wrap b:defstx (renames head ?1 rename ?2 bindrhs)) rest)
|
||||
|
|
@ -503,11 +512,12 @@
|
|||
[Expr ?first head]
|
||||
[! ?1]
|
||||
[#:pass2]
|
||||
[#:pattern ((?define-syntaxes . ?clause) . ?rest)]
|
||||
[#:rename ?clause rename]
|
||||
[#:pattern ((?define-syntaxes ?vars . ?body) . ?rest)]
|
||||
[#:rename (?vars . ?body) rename]
|
||||
[#:binders #'?vars]
|
||||
[! ?2]
|
||||
[#:do (block-syntax-bindings
|
||||
(cons #'?clause (block-syntax-bindings)))]
|
||||
(cons (cons #'?vars #'?body) (block-syntax-bindings)))]
|
||||
[#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
|
||||
[BindSyntaxes ?rhs bindrhs]
|
||||
[#:pattern (?first . ?rest)]
|
||||
|
|
@ -519,7 +529,6 @@
|
|||
[#:do (block-expressions #'(?first . ?rest))]
|
||||
;; rest better be empty
|
||||
[BlockPass ?rest rest])]
|
||||
|
||||
))
|
||||
|
||||
;; BindSyntaxes : BindSyntaxes -> RST
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
framework/framework
|
||||
scheme/list
|
||||
scheme/match
|
||||
syntax/boundmap
|
||||
syntax/id-table
|
||||
macro-debugger/util/class-iop
|
||||
"interfaces.ss"
|
||||
"controller.ss"
|
||||
|
|
@ -107,18 +107,12 @@
|
|||
(send -text change-style clickback-style a b)))))
|
||||
|
||||
(define/public (add-syntax stx
|
||||
#:binder-table [alpha-table #f]
|
||||
#:binders [binders null]
|
||||
#:shift-table [shift-table #f]
|
||||
#:definites [definites null]
|
||||
#:hi-colors [hi-colors null]
|
||||
#:hi-stxss [hi-stxss null]
|
||||
#:substitutions [substitutions null])
|
||||
(define (get-binders id)
|
||||
(define binder
|
||||
(module-identifier-mapping-get alpha-table id (lambda () #f)))
|
||||
(if shift-table
|
||||
(cons binder (hash-ref shift-table binder null))
|
||||
(list binder)))
|
||||
(let ([display (internal-add-syntax stx)]
|
||||
[definite-table (make-hasheq)])
|
||||
(let ([range (send: display display<%> get-range)]
|
||||
|
|
@ -141,22 +135,32 @@
|
|||
(when shift-table
|
||||
(for ([shifted-definite (hash-ref shift-table definite null)])
|
||||
(hash-set! definite-table shifted-definite #t))))
|
||||
(when alpha-table
|
||||
(let ([range (send: display display<%> get-range)]
|
||||
[start (send: display display<%> get-start-position)])
|
||||
(let* ([binders0
|
||||
(module-identifier-mapping-map alpha-table (lambda (k v) k))]
|
||||
[binders
|
||||
(apply append (map get-binders binders0))])
|
||||
(send: display display<%> underline-syntaxes binders))
|
||||
(for ([id (send: range range<%> get-identifier-list)])
|
||||
(define definite? (hash-ref definite-table id #f))
|
||||
(when #f ;; DISABLED
|
||||
(add-binding-billboard start range id definite?))
|
||||
(for ([binder (get-binders id)])
|
||||
(for ([binder-r (send: range range<%> get-ranges binder)])
|
||||
(for ([id-r (send: range range<%> get-ranges id)])
|
||||
(add-binding-arrow start binder-r id-r definite?)))))))
|
||||
(let ([binder-table (make-free-id-table)])
|
||||
(define range (send: display display<%> get-range))
|
||||
(define start (send: display display<%> get-start-position))
|
||||
(define (get-binders id)
|
||||
(let ([binder (free-id-table-ref binder-table id #f)])
|
||||
(cond [(not binder) null]
|
||||
[shift-table (cons binder (get-shifted binder))]
|
||||
[else (list binder)])))
|
||||
(define (get-shifted id)
|
||||
(hash-ref shift-table id null))
|
||||
;; Populate table
|
||||
(for ([binder binders])
|
||||
(free-id-table-set! binder-table binder binder))
|
||||
;; Underline binders (and shifted binders)
|
||||
(send: display display<%> underline-syntaxes
|
||||
(append (apply append (map get-shifted binders))
|
||||
binders))
|
||||
;; Make arrows (& billboards, when enabled)
|
||||
(for ([id (send: range range<%> get-identifier-list)])
|
||||
(define definite? (hash-ref definite-table id #f))
|
||||
(when #f ;; DISABLED
|
||||
(add-binding-billboard start range id definite?))
|
||||
(for ([binder (get-binders id)])
|
||||
(for ([binder-r (send: range range<%> get-ranges binder)])
|
||||
(for ([id-r (send: range range<%> get-ranges id)])
|
||||
(add-binding-arrow start binder-r id-r definite?))))))
|
||||
(void)))
|
||||
|
||||
(define/private (add-binding-arrow start binder-r id-r definite?)
|
||||
|
|
|
|||
|
|
@ -81,42 +81,41 @@
|
|||
(add-text "\n")))
|
||||
|
||||
(define/public (add-step step
|
||||
#:binders binders
|
||||
#:shift-table [shift-table #f])
|
||||
(cond [(step? step)
|
||||
(show-step step binders shift-table)]
|
||||
(show-step step shift-table)]
|
||||
[(misstep? step)
|
||||
(show-misstep step binders shift-table)]
|
||||
(show-misstep step shift-table)]
|
||||
[(prestep? step)
|
||||
(show-prestep step binders shift-table)]
|
||||
(show-prestep step shift-table)]
|
||||
[(poststep? step)
|
||||
(show-poststep step binders shift-table)]))
|
||||
(show-poststep step shift-table)]))
|
||||
|
||||
(define/public (add-syntax stx
|
||||
#:binders [binders #f]
|
||||
#:shift-table [shift-table #f]
|
||||
#:definites [definites null])
|
||||
#:binders [binders null]
|
||||
#:definites [definites null]
|
||||
#:shift-table [shift-table #f])
|
||||
(send: sbview sb:syntax-browser<%> add-syntax stx
|
||||
#:binder-table binders
|
||||
#:shift-table shift-table
|
||||
#:definites definites))
|
||||
#:binders binders
|
||||
#:definites definites
|
||||
#:shift-table shift-table))
|
||||
|
||||
(define/public (add-final stx error
|
||||
#:binders binders
|
||||
#:shift-table [shift-table #f]
|
||||
#:definites definites)
|
||||
#:definites definites
|
||||
#:shift-table [shift-table #f])
|
||||
(when stx
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(add-text "Expansion finished\n")
|
||||
(add-syntax stx
|
||||
#:binder-table binders
|
||||
#:shift-table shift-table
|
||||
#:definites definites)))
|
||||
#:binders binders
|
||||
#:definites definites
|
||||
#:shift-table shift-table)))
|
||||
(when error
|
||||
(add-error error)))
|
||||
|
||||
;; show-lctx : Step -> void
|
||||
(define/private (show-lctx step binders shift-table)
|
||||
(define/private (show-lctx step shift-table)
|
||||
(define state (protostep-s1 step))
|
||||
(define lctx (state-lctx state))
|
||||
(when (pair? lctx)
|
||||
|
|
@ -126,7 +125,7 @@
|
|||
"while executing macro transformer in:\n")
|
||||
(insert-syntax/redex (bigframe-term bf)
|
||||
(bigframe-foci bf)
|
||||
binders
|
||||
(state-binders state)
|
||||
shift-table
|
||||
(state-uses state)
|
||||
(state-frontier state)))))
|
||||
|
|
@ -141,15 +140,15 @@
|
|||
(step-type->string (protostep-type step))))
|
||||
|
||||
;; show-step : Step -> void
|
||||
(define/private (show-step step binders shift-table)
|
||||
(define/private (show-step step shift-table)
|
||||
(let-values ([(common-context state1 state2)
|
||||
(factor-common-context (protostep-s1 step)
|
||||
(step-s2 step))])
|
||||
(show-state/redex state1 binders shift-table)
|
||||
(show-state/redex state1 shift-table)
|
||||
(separator step)
|
||||
(show-state/contractum state2 binders shift-table)
|
||||
(show-common-context common-context state1 binders shift-table)
|
||||
(show-lctx step binders shift-table)))
|
||||
(show-state/contractum state2 shift-table)
|
||||
(show-common-context common-context state1 shift-table)
|
||||
(show-lctx step shift-table)))
|
||||
|
||||
(define/private (factor-common-context state1 state2)
|
||||
(if (send: config config<%> get-split-context?)
|
||||
|
|
@ -173,7 +172,7 @@
|
|||
(make-state e2 foci2 ctx2z lctx2 binders2 uses2 frontier2 seq2))
|
||||
(values common-ctx state1z state2z))
|
||||
|
||||
(define/private (show-common-context ctx state1 binders shift-table)
|
||||
(define/private (show-common-context ctx state1 shift-table)
|
||||
(match-define
|
||||
(struct state (_ _ _ _ _ uses1 frontier1 _)) state1)
|
||||
(when (pair? ctx)
|
||||
|
|
@ -182,43 +181,43 @@
|
|||
(send*: sbview sb:syntax-browser<%>
|
||||
(add-text "\nin context:\n")
|
||||
(add-syntax the-syntax
|
||||
#:binder-table binders
|
||||
#:shift-table shift-table
|
||||
#:definites uses1
|
||||
#:binders (state-binders state1)
|
||||
#:shift-table shift-table
|
||||
#:substitutions (list (cons hole-stx "[ HOLE ]")))))))
|
||||
|
||||
(define/private (show-state/redex state binders shift-table)
|
||||
(define/private (show-state/redex state shift-table)
|
||||
(insert-syntax/redex (state-term state)
|
||||
(state-foci state)
|
||||
binders
|
||||
(state-binders state)
|
||||
shift-table
|
||||
(state-uses state)
|
||||
(state-frontier state)))
|
||||
|
||||
(define/private (show-state/contractum state binders shift-table)
|
||||
(define/private (show-state/contractum state shift-table)
|
||||
(insert-syntax/contractum (state-term state)
|
||||
(state-foci state)
|
||||
binders
|
||||
(state-binders state)
|
||||
shift-table
|
||||
(state-uses state)
|
||||
(state-frontier state)))
|
||||
|
||||
;; show-prestep : Step -> void
|
||||
(define/private (show-prestep step binders shift-table)
|
||||
(define/private (show-prestep step shift-table)
|
||||
(separator/small step)
|
||||
(show-state/redex (protostep-s1 step) binders shift-table)
|
||||
(show-lctx step binders shift-table))
|
||||
(show-state/redex (protostep-s1 step) shift-table)
|
||||
(show-lctx step shift-table))
|
||||
|
||||
;; show-poststep : Step -> void
|
||||
(define/private (show-poststep step binders shift-table)
|
||||
(define/private (show-poststep step shift-table)
|
||||
(separator/small step)
|
||||
(show-state/contractum (protostep-s1 step) binders shift-table)
|
||||
(show-lctx step binders shift-table))
|
||||
(show-state/contractum (protostep-s1 step) shift-table)
|
||||
(show-lctx step shift-table))
|
||||
|
||||
;; show-misstep : Step -> void
|
||||
(define/private (show-misstep step binders shift-table)
|
||||
(define/private (show-misstep step shift-table)
|
||||
(define state (protostep-s1 step))
|
||||
(show-state/redex state binders shift-table)
|
||||
(show-state/redex state shift-table)
|
||||
(separator step)
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(add-error-text (exn-message (misstep-exn step)))
|
||||
|
|
@ -226,10 +225,10 @@
|
|||
(when (exn:fail:syntax? (misstep-exn step))
|
||||
(for ([e (exn:fail:syntax-exprs (misstep-exn step))])
|
||||
(send: sbview sb:syntax-browser<%> add-syntax e
|
||||
#:binder-table binders
|
||||
#:shift-table shift-table
|
||||
#:definites (or (state-uses state) null))))
|
||||
(show-lctx step binders shift-table))
|
||||
#:binders (or (state-binders state) null)
|
||||
#:definites (or (state-uses state) null)
|
||||
#:shift-table shift-table)))
|
||||
(show-lctx step shift-table))
|
||||
|
||||
;; insert-syntax/color
|
||||
(define/private (insert-syntax/color stx foci binders shift-table
|
||||
|
|
@ -238,7 +237,7 @@
|
|||
(define highlight-frontier? (send: config config<%> get-highlight-frontier?))
|
||||
(send: sbview sb:syntax-browser<%> add-syntax stx
|
||||
#:definites (or definites null)
|
||||
#:binder-table binders
|
||||
#:binders binders
|
||||
#:shift-table shift-table
|
||||
#:hi-colors (list hi-color
|
||||
"WhiteSmoke")
|
||||
|
|
|
|||
|
|
@ -47,12 +47,12 @@
|
|||
|
||||
(define deriv #f)
|
||||
(define deriv-hidden? #f)
|
||||
(define binders #f)
|
||||
(define shift-table #f)
|
||||
|
||||
(define raw-steps #f)
|
||||
(define raw-steps-estx #f) ;; #f if raw-steps-exn is exn
|
||||
(define raw-steps-exn #f) ;; #f if raw-steps-estx is syntax
|
||||
(define raw-steps-binders #f)
|
||||
(define raw-steps-definites #f)
|
||||
(define raw-steps-oops #f)
|
||||
|
||||
|
|
@ -75,9 +75,9 @@
|
|||
(define-guarded-getters (recache-deriv!)
|
||||
[get-deriv deriv]
|
||||
[get-deriv-hidden? deriv-hidden?]
|
||||
[get-binders binders]
|
||||
[get-shift-table shift-table])
|
||||
(define-guarded-getters (recache-raw-steps!)
|
||||
[get-raw-steps-binders raw-steps-binders]
|
||||
[get-raw-steps-definites raw-steps-definites]
|
||||
[get-raw-steps-exn raw-steps-exn]
|
||||
[get-raw-steps-oops raw-steps-oops])
|
||||
|
|
@ -95,6 +95,7 @@
|
|||
(set! raw-steps #f)
|
||||
(set! raw-steps-estx #f)
|
||||
(set! raw-steps-exn #f)
|
||||
(set! raw-steps-binders #f)
|
||||
(set! raw-steps-definites #f)
|
||||
(set! raw-steps-oops #f))
|
||||
|
||||
|
|
@ -108,7 +109,6 @@
|
|||
(invalidate-synth!)
|
||||
(set! deriv #f)
|
||||
(set! deriv-hidden? #f)
|
||||
(set! binders #f)
|
||||
(set! shift-table #f))
|
||||
|
||||
;; recache! : -> void
|
||||
|
|
@ -141,7 +141,6 @@
|
|||
(module-identifier-mapping-put! alpha-table id id))
|
||||
binder-ids)
|
||||
(set! deriv d)
|
||||
(set! binders alpha-table)
|
||||
(set! shift-table (compute-shift-table d)))))))))
|
||||
|
||||
;; recache-synth! : -> void
|
||||
|
|
@ -158,12 +157,13 @@
|
|||
(with-handlers ([(lambda (e) #t)
|
||||
(lambda (e)
|
||||
(set! raw-steps-oops e))])
|
||||
(let-values ([(raw-steps* definites* estx* error*)
|
||||
(let-values ([(raw-steps* binders* definites* estx* error*)
|
||||
(parameterize ((macro-policy show-macro?))
|
||||
(reductions+ deriv))])
|
||||
(set! raw-steps raw-steps*)
|
||||
(set! raw-steps-estx estx*)
|
||||
(set! raw-steps-exn error*)
|
||||
(set! raw-steps-binders binders*)
|
||||
(set! raw-steps-definites definites*)))))))
|
||||
|
||||
;; recache-steps! : -> void
|
||||
|
|
@ -283,7 +283,7 @@
|
|||
(recache-steps!)
|
||||
(cond [(syntax? raw-steps-estx)
|
||||
(send: displayer step-display<%> add-syntax raw-steps-estx
|
||||
#:binders binders
|
||||
#:binders raw-steps-binders
|
||||
#:shift-table shift-table
|
||||
#:definites raw-steps-definites)]
|
||||
[(exn? raw-steps-exn)
|
||||
|
|
@ -297,10 +297,9 @@
|
|||
(let ([step (cursor:next steps)])
|
||||
(if step
|
||||
(send: displayer step-display<%> add-step step
|
||||
#:binders binders
|
||||
#:shift-table shift-table)
|
||||
(send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn
|
||||
#:binders binders
|
||||
#:binders raw-steps-binders
|
||||
#:shift-table shift-table
|
||||
#:definites raw-steps-definites)))]
|
||||
[else (display-oops #t)]))
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@
|
|||
[else #f]))
|
||||
|
||||
(define (check-hide d policy expect-ok?)
|
||||
(let-values ([(steps defs stx2 exn)
|
||||
(let-values ([(steps binders uses stx2 exn)
|
||||
(parameterize ((macro-policy policy))
|
||||
(reductions+ d))])
|
||||
(check-pred list? steps)
|
||||
|
|
|
|||
|
|
@ -127,7 +127,7 @@
|
|||
|
||||
;; Specialized macro hiding tests
|
||||
(define (stx/hide-policy d policy)
|
||||
(define-values (_steps _uses stx _exn)
|
||||
(define-values (_steps _binders _uses stx _exn)
|
||||
(parameterize ((macro-policy policy))
|
||||
(reductions+ d)))
|
||||
stx)
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@
|
|||
(check-steps deriv policy))))
|
||||
|
||||
(define (check-steps deriv policy)
|
||||
(define-values (steps defs stx exn)
|
||||
(define-values (steps binders uses stx exn)
|
||||
(parameterize ((macro-policy policy)) (reductions+ deriv)))
|
||||
(check-pred syntax? stx)
|
||||
(check-eq? exn #f)
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
(syntax-rules ()
|
||||
[(th form hidden-e2 policy)
|
||||
(test-case (format "~s" 'form)
|
||||
(let-values ([(steps defs stx exn)
|
||||
(let-values ([(steps binders uses stx exn)
|
||||
(parameterize ((macro-policy policy))
|
||||
(reductions+ (trace/k 'form)))])
|
||||
(check-pred syntax? stx)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user