suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

macro-stepper: made syntax display faster, esp for early terms

Browse Source 
calculate arrows etc wrt known binders instead of all binders

svn: r16416
This commit is contained in:
Ryan Culpepper 2009-10-22 22:00:49 +00:00
parent 266b154dfc
commit e273dae9b1
10 changed files with 133 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/macro-debugger/model/reductions-config.ss
View File

@ -37,6 +37,7 @@
[marking-table (parameter/c (or/c hash? false/c))] [marking-table (parameter/c (or/c hash? false/c))]
[current-binders (parameter/c (listof identifier?))] [current-binders (parameter/c (listof identifier?))]
[current-definites (parameter/c (listof identifier?))] [current-definites (parameter/c (listof identifier?))]
[current-binders (parameter/c (listof identifier?))]
[current-frontier (parameter/c (listof syntax?))] [current-frontier (parameter/c (listof syntax?))]
[sequence-number (parameter/c (or/c false/c exact-nonnegative-integer?))] [sequence-number (parameter/c (or/c false/c exact-nonnegative-integer?))]
[phase (parameter/c exact-nonnegative-integer?)] [phase (parameter/c exact-nonnegative-integer?)]
@ -48,6 +49,7 @@
[block-value-bindings (parameter/c (listof syntaxish?))] [block-value-bindings (parameter/c (listof syntaxish?))]
[block-expressions (parameter/c syntaxish?)] [block-expressions (parameter/c syntaxish?)]
[learn-binders ((listof identifier?) . -> . any)]
[learn-definites ((listof identifier?) . -> . any)] [learn-definites ((listof identifier?) . -> . any)]
[add-frontier ((listof syntax?) . -> . any)] [add-frontier ((listof syntax?) . -> . any)]
@ -82,7 +84,6 @@
(define marking-table (make-parameter #f)) (define marking-table (make-parameter #f))
;; current-binders : parameterof (listof identifier) ;; current-binders : parameterof (listof identifier)
;; FIXME: not yet used
(define current-binders (make-parameter null)) (define current-binders (make-parameter null))
;; current-definites : parameter of (list-of identifier) ;; current-definites : parameter of (list-of identifier)
@ -160,6 +161,10 @@
(current-definites (current-definites
(append ids (current-definites)))) (append ids (current-definites))))
(define (learn-binders ids)
(current-binders
(append ids (current-binders))))
(define (get-frontier) (or (current-frontier) null)) (define (get-frontier) (or (current-frontier) null))
(define (add-frontier stxs) (define (add-frontier stxs)
@ -322,8 +327,8 @@
(define (current-state-with e fs) (define (current-state-with e fs)
(make state e (foci fs) (context) (big-context) (make state e (foci fs) (context) (big-context)
(current-binders) (current-definites) (current-frontier) (current-binders) (current-definites)
(sequence-number))) (current-frontier) (sequence-number)))
(define (walk e1 e2 type (define (walk e1 e2 type
#:foci1 [foci1 e1] #:foci1 [foci1 e1]

18
collects/macro-debugger/model/reductions-engine.ss
View File

@ -253,6 +253,12 @@
(check-same-stx 'rename/no-step real-from from)) (check-same-stx 'rename/no-step real-from from))
(R** f v p s ws [#:rename pvar to] . more))] (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 ;; Add to definite uses
[(R** f v p s ws [#:learn ids] . more) [(R** f v p s ws [#:learn ids] . more)
#:declare ids (expr/c #'(listof identifier?)) #:declare ids (expr/c #'(listof identifier?))
@ -550,3 +556,15 @@
(cons (wrongness (stx-car a) (stx-car b)) (cons (wrongness (stx-car a) (stx-car b))
(wrongness (stx-cdr a) (stx-cdr b)))] (wrongness (stx-cdr a) (stx-cdr b)))]
[else (stx->datum a)])) [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))]))

43
collects/macro-debugger/model/reductions.ss
View File

@ -13,20 +13,21 @@
;; reductions : WDeriv -> ReductionSequence ;; reductions : WDeriv -> ReductionSequence
(define (reductions d) (define (reductions d)
(let-values ([(steps definites estx exn) (reductions+ d)]) (let-values ([(steps binders definites estx exn) (reductions+ d)])
steps)) steps))
;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn ;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
(define (reductions+ d) (define (reductions+ d)
(parameterize ((current-definites null) (parameterize ((current-definites null)
(current-binders null)
(current-frontier null) (current-frontier null)
(hides-flags (list (box #f))) (hides-flags (list (box #f)))
(sequence-number 0)) (sequence-number 0))
(RScase ((Expr d) (wderiv-e1 d) (wderiv-e1 d) #f null) (RScase ((Expr d) (wderiv-e1 d) (wderiv-e1 d) #f null)
(lambda (steps stx vstx s) (lambda (steps stx vstx s)
(values (reverse steps) (current-definites) vstx #f)) (values (reverse steps) (current-binders) (current-definites) vstx #f))
(lambda (steps exn) (lambda (steps exn)
(values (reverse steps) (current-definites) #f exn))))) (values (reverse steps) (current-binders) (current-definites) #f exn)))))
;; Syntax ;; Syntax
@ -97,17 +98,16 @@
[! ?1])] [! ?1])]
[(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2)) [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2))
(R [! ?1] (R [! ?1]
[#:pattern (?define-syntaxes formals ?rhs)] [#:pattern (?define-syntaxes ?vars ?rhs)]
[#:binders #'?vars]
[Expr/PhaseUp ?rhs rhs] [Expr/PhaseUp ?rhs rhs]
[! ?2])] [! ?2])]
[(Wrap p:define-values (e1 e2 rs ?1 rhs)) [(Wrap p:define-values (e1 e2 rs ?1 rhs))
(R [! ?1] (R [! ?1]
[#:pattern (?define-values ?formals ?rhs)] [#:pattern (?define-values ?vars ?rhs)]
[#:binders #'?vars]
[#:when rhs [#:when rhs
[Expr ?rhs rhs]] [Expr ?rhs rhs]])]
[#:when (not rhs)
[#:do (DEBUG (printf "=== end (dvrhs) ===\n"))]
[#:do (DEBUG (printf "===\n"))]])]
[(Wrap p:#%expression (e1 e2 rs ?1 inner #f)) [(Wrap p:#%expression (e1 e2 rs ?1 inner #f))
(R [! ?1] (R [! ?1]
[#:pattern (?expr-kw ?inner)] [#:pattern (?expr-kw ?inner)]
@ -156,6 +156,7 @@
[(Wrap p:lambda (e1 e2 rs ?1 renames body)) [(Wrap p:lambda (e1 e2 rs ?1 renames body))
(R [! ?1] (R [! ?1]
[#:pattern (?lambda ?formals . ?body)] [#:pattern (?lambda ?formals . ?body)]
[#:binders #'?formals]
[#:rename (?formals . ?body) renames 'rename-lambda] [#:rename (?formals . ?body) renames 'rename-lambda]
[Block ?body body])] [Block ?body body])]
[(Wrap p:case-lambda (e1 e2 rs ?1 clauses)) [(Wrap p:case-lambda (e1 e2 rs ?1 clauses))
@ -166,12 +167,14 @@
(R [! ?1] (R [! ?1]
[#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
[#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-let-values] [#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-let-values]
[#:binders #'(?vars ...)]
[Expr (?rhs ...) rhss] [Expr (?rhs ...) rhss]
[Block ?body body])] [Block ?body body])]
[(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body)) [(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body))
(R [! ?1] (R [! ?1]
[#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
[#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values] [#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values]
[#:binders #'(?vars ...)]
[Expr (?rhs ...) rhss] [Expr (?rhs ...) rhss]
[Block ?body body])] [Block ?body body])]
[(Wrap p:letrec-syntaxes+values [(Wrap p:letrec-syntaxes+values
@ -182,10 +185,12 @@
[#:rename (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body) [#:rename (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body)
srenames srenames
'rename-lsv] 'rename-lsv]
[#:binders #'(?svars ... ?vvars ...)]
[BindSyntaxes (?srhs ...) srhss] [BindSyntaxes (?srhs ...) srhss]
;; If vrenames is #f, no var bindings to rename ;; If vrenames is #f, no var bindings to rename
[#:when vrenames [#:when vrenames
[#:rename (((?vvars ?vrhs) ...) . ?body) vrenames 'rename-lsv]] [#:rename (((?vvars ?vrhs) ...) . ?body) vrenames 'rename-lsv]
[#:binders #'(?vvars ...)]]
[Expr (?vrhs ...) vrhss] [Expr (?vrhs ...) vrhss]
[Block ?body body] [Block ?body body]
[#:pass2] [#:pass2]
@ -328,6 +333,7 @@
(R [! ?1] (R [! ?1]
[#:pattern ((?formals . ?body) . ?rest)] [#:pattern ((?formals . ?body) . ?rest)]
[#:rename (?formals . ?body) rename 'rename-case-lambda] [#:rename (?formals . ?body) rename 'rename-case-lambda]
[#:binders #'?formals]
[Block ?body body] [Block ?body body]
[CaseLambdaClauses ?rest rest])])) [CaseLambdaClauses ?rest rest])]))
@ -393,6 +399,7 @@
[(struct local-lift (expr ids)) [(struct local-lift (expr ids))
;; FIXME: add action ;; FIXME: add action
(R [#:do (take-lift!)] (R [#:do (take-lift!)]
[#:binders ids]
[#:reductions (list (walk expr ids 'local-lift))])] [#:reductions (list (walk expr ids 'local-lift))])]
[(struct local-lift-end (decl)) [(struct local-lift-end (decl))
@ -409,6 +416,7 @@
[(struct local-bind (names ?1 renames bindrhs)) [(struct local-bind (names ?1 renames bindrhs))
[R [! ?1] [R [! ?1]
;; FIXME: use renames ;; FIXME: use renames
[#:binders names]
[#:when bindrhs => (BindSyntaxes bindrhs)]]])) [#:when bindrhs => (BindSyntaxes bindrhs)]]]))
;; List : ListDerivation -> RST ;; List : ListDerivation -> RST
@ -489,11 +497,12 @@
[Expr ?first head] [Expr ?first head]
[! ?1] [! ?1]
[#:pass2] [#:pass2]
[#:pattern ((?define-values . ?clause) . ?rest)] [#:pattern ((?define-values ?vars . ?body) . ?rest)]
[#:rename ?clause rename] [#:rename (?vars . ?body) rename]
[#:binders #'?vars]
[! ?2] [! ?2]
[#:do (block-value-bindings [#:do (block-value-bindings
(cons #'?clause (block-value-bindings)))] (cons (cons #'?vars #'?body) (block-value-bindings)))]
[#:pattern (?first . ?rest)] [#:pattern (?first . ?rest)]
[BlockPass ?rest rest])] [BlockPass ?rest rest])]
[(cons (Wrap b:defstx (renames head ?1 rename ?2 bindrhs)) rest) [(cons (Wrap b:defstx (renames head ?1 rename ?2 bindrhs)) rest)
@ -503,11 +512,12 @@
[Expr ?first head] [Expr ?first head]
[! ?1] [! ?1]
[#:pass2] [#:pass2]
[#:pattern ((?define-syntaxes . ?clause) . ?rest)] [#:pattern ((?define-syntaxes ?vars . ?body) . ?rest)]
[#:rename ?clause rename] [#:rename (?vars . ?body) rename]
[#:binders #'?vars]
[! ?2] [! ?2]
[#:do (block-syntax-bindings [#:do (block-syntax-bindings
(cons #'?clause (block-syntax-bindings)))] (cons (cons #'?vars #'?body) (block-syntax-bindings)))]
[#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)] [#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
[BindSyntaxes ?rhs bindrhs] [BindSyntaxes ?rhs bindrhs]
[#:pattern (?first . ?rest)] [#:pattern (?first . ?rest)]
@ -519,7 +529,6 @@
[#:do (block-expressions #'(?first . ?rest))] [#:do (block-expressions #'(?first . ?rest))]
;; rest better be empty ;; rest better be empty
[BlockPass ?rest rest])] [BlockPass ?rest rest])]
)) ))
;; BindSyntaxes : BindSyntaxes -> RST ;; BindSyntaxes : BindSyntaxes -> RST

52
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -5,7 +5,7 @@
framework/framework framework/framework
scheme/list scheme/list
scheme/match scheme/match
syntax/boundmap syntax/id-table
macro-debugger/util/class-iop macro-debugger/util/class-iop
"interfaces.ss" "interfaces.ss"
"controller.ss" "controller.ss"
@ -107,18 +107,12 @@
(send -text change-style clickback-style a b))))) (send -text change-style clickback-style a b)))))
(define/public (add-syntax stx (define/public (add-syntax stx
#:binder-table [alpha-table #f] #:binders [binders null]
#:shift-table [shift-table #f] #:shift-table [shift-table #f]
#:definites [definites null] #:definites [definites null]
#:hi-colors [hi-colors null] #:hi-colors [hi-colors null]
#:hi-stxss [hi-stxss null] #:hi-stxss [hi-stxss null]
#:substitutions [substitutions 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)] (let ([display (internal-add-syntax stx)]
[definite-table (make-hasheq)]) [definite-table (make-hasheq)])
(let ([range (send: display display<%> get-range)] (let ([range (send: display display<%> get-range)]
@ -141,22 +135,32 @@
(when shift-table (when shift-table
(for ([shifted-definite (hash-ref shift-table definite null)]) (for ([shifted-definite (hash-ref shift-table definite null)])
(hash-set! definite-table shifted-definite #t)))) (hash-set! definite-table shifted-definite #t))))
(when alpha-table (let ([binder-table (make-free-id-table)])
(let ([range (send: display display<%> get-range)] (define range (send: display display<%> get-range))
[start (send: display display<%> get-start-position)]) (define start (send: display display<%> get-start-position))
(let* ([binders0 (define (get-binders id)
(module-identifier-mapping-map alpha-table (lambda (k v) k))] (let ([binder (free-id-table-ref binder-table id #f)])
[binders (cond [(not binder) null]
(apply append (map get-binders binders0))]) [shift-table (cons binder (get-shifted binder))]
(send: display display<%> underline-syntaxes binders)) [else (list binder)])))
(for ([id (send: range range<%> get-identifier-list)]) (define (get-shifted id)
(define definite? (hash-ref definite-table id #f)) (hash-ref shift-table id null))
(when #f ;; DISABLED ;; Populate table
(add-binding-billboard start range id definite?)) (for ([binder binders])
(for ([binder (get-binders id)]) (free-id-table-set! binder-table binder binder))
(for ([binder-r (send: range range<%> get-ranges binder)]) ;; Underline binders (and shifted binders)
(for ([id-r (send: range range<%> get-ranges id)]) (send: display display<%> underline-syntaxes
(add-binding-arrow start binder-r id-r definite?))))))) (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))) (void)))
(define/private (add-binding-arrow start binder-r id-r definite?) (define/private (add-binding-arrow start binder-r id-r definite?)

85
collects/macro-debugger/view/step-display.ss
View File

@ -81,42 +81,41 @@
(add-text "\n"))) (add-text "\n")))
(define/public (add-step step (define/public (add-step step
#:binders binders
#:shift-table [shift-table #f]) #:shift-table [shift-table #f])
(cond [(step? step) (cond [(step? step)
(show-step step binders shift-table)] (show-step step shift-table)]
[(misstep? step) [(misstep? step)
(show-misstep step binders shift-table)] (show-misstep step shift-table)]
[(prestep? step) [(prestep? step)
(show-prestep step binders shift-table)] (show-prestep step shift-table)]
[(poststep? step) [(poststep? step)
(show-poststep step binders shift-table)])) (show-poststep step shift-table)]))
(define/public (add-syntax stx (define/public (add-syntax stx
#:binders [binders #f] #:binders [binders null]
#:shift-table [shift-table #f] #:definites [definites null]
#:definites [definites null]) #:shift-table [shift-table #f])
(send: sbview sb:syntax-browser<%> add-syntax stx (send: sbview sb:syntax-browser<%> add-syntax stx
#:binder-table binders #:binders binders
#:shift-table shift-table #:definites definites
#:definites definites)) #:shift-table shift-table))
(define/public (add-final stx error (define/public (add-final stx error
#:binders binders #:binders binders
#:shift-table [shift-table #f] #:definites definites
#:definites definites) #:shift-table [shift-table #f])
(when stx (when stx
(send*: sbview sb:syntax-browser<%> (send*: sbview sb:syntax-browser<%>
(add-text "Expansion finished\n") (add-text "Expansion finished\n")
(add-syntax stx (add-syntax stx
#:binder-table binders #:binders binders
#:shift-table shift-table #:definites definites
#:definites definites))) #:shift-table shift-table)))
(when error (when error
(add-error error))) (add-error error)))
;; show-lctx : Step -> void ;; 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 state (protostep-s1 step))
(define lctx (state-lctx state)) (define lctx (state-lctx state))
(when (pair? lctx) (when (pair? lctx)
@ -126,7 +125,7 @@
"while executing macro transformer in:\n") "while executing macro transformer in:\n")
(insert-syntax/redex (bigframe-term bf) (insert-syntax/redex (bigframe-term bf)
(bigframe-foci bf) (bigframe-foci bf)
binders (state-binders state)
shift-table shift-table
(state-uses state) (state-uses state)
(state-frontier state))))) (state-frontier state)))))
@ -141,15 +140,15 @@
(step-type->string (protostep-type step)))) (step-type->string (protostep-type step))))
;; show-step : Step -> void ;; 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) (let-values ([(common-context state1 state2)
(factor-common-context (protostep-s1 step) (factor-common-context (protostep-s1 step)
(step-s2 step))]) (step-s2 step))])
(show-state/redex state1 binders shift-table) (show-state/redex state1 shift-table)
(separator step) (separator step)
(show-state/contractum state2 binders shift-table) (show-state/contractum state2 shift-table)
(show-common-context common-context state1 binders shift-table) (show-common-context common-context state1 shift-table)
(show-lctx step binders shift-table))) (show-lctx step shift-table)))
(define/private (factor-common-context state1 state2) (define/private (factor-common-context state1 state2)
(if (send: config config<%> get-split-context?) (if (send: config config<%> get-split-context?)
@ -173,7 +172,7 @@
(make-state e2 foci2 ctx2z lctx2 binders2 uses2 frontier2 seq2)) (make-state e2 foci2 ctx2z lctx2 binders2 uses2 frontier2 seq2))
(values common-ctx state1z state2z)) (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 (match-define
(struct state (_ _ _ _ _ uses1 frontier1 _)) state1) (struct state (_ _ _ _ _ uses1 frontier1 _)) state1)
(when (pair? ctx) (when (pair? ctx)
@ -182,43 +181,43 @@
(send*: sbview sb:syntax-browser<%> (send*: sbview sb:syntax-browser<%>
(add-text "\nin context:\n") (add-text "\nin context:\n")
(add-syntax the-syntax (add-syntax the-syntax
#:binder-table binders
#:shift-table shift-table
#:definites uses1 #:definites uses1
#:binders (state-binders state1)
#:shift-table shift-table
#:substitutions (list (cons hole-stx "[ HOLE ]"))))))) #: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) (insert-syntax/redex (state-term state)
(state-foci state) (state-foci state)
binders (state-binders state)
shift-table shift-table
(state-uses state) (state-uses state)
(state-frontier 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) (insert-syntax/contractum (state-term state)
(state-foci state) (state-foci state)
binders (state-binders state)
shift-table shift-table
(state-uses state) (state-uses state)
(state-frontier state))) (state-frontier state)))
;; show-prestep : Step -> void ;; show-prestep : Step -> void
(define/private (show-prestep step binders shift-table) (define/private (show-prestep step shift-table)
(separator/small step) (separator/small step)
(show-state/redex (protostep-s1 step) binders shift-table) (show-state/redex (protostep-s1 step) shift-table)
(show-lctx step binders shift-table)) (show-lctx step shift-table))
;; show-poststep : Step -> void ;; show-poststep : Step -> void
(define/private (show-poststep step binders shift-table) (define/private (show-poststep step shift-table)
(separator/small step) (separator/small step)
(show-state/contractum (protostep-s1 step) binders shift-table) (show-state/contractum (protostep-s1 step) shift-table)
(show-lctx step binders shift-table)) (show-lctx step shift-table))
;; show-misstep : Step -> void ;; show-misstep : Step -> void
(define/private (show-misstep step binders shift-table) (define/private (show-misstep step shift-table)
(define state (protostep-s1 step)) (define state (protostep-s1 step))
(show-state/redex state binders shift-table) (show-state/redex state shift-table)
(separator step) (separator step)
(send*: sbview sb:syntax-browser<%> (send*: sbview sb:syntax-browser<%>
(add-error-text (exn-message (misstep-exn step))) (add-error-text (exn-message (misstep-exn step)))
@ -226,10 +225,10 @@
(when (exn:fail:syntax? (misstep-exn step)) (when (exn:fail:syntax? (misstep-exn step))
(for ([e (exn:fail:syntax-exprs (misstep-exn step))]) (for ([e (exn:fail:syntax-exprs (misstep-exn step))])
(send: sbview sb:syntax-browser<%> add-syntax e (send: sbview sb:syntax-browser<%> add-syntax e
#:binder-table binders #:binders (or (state-binders state) null)
#:shift-table shift-table #:definites (or (state-uses state) null)
#:definites (or (state-uses state) null)))) #:shift-table shift-table)))
(show-lctx step binders shift-table)) (show-lctx step shift-table))
;; insert-syntax/color ;; insert-syntax/color
(define/private (insert-syntax/color stx foci binders shift-table (define/private (insert-syntax/color stx foci binders shift-table
@ -238,7 +237,7 @@
(define highlight-frontier? (send: config config<%> get-highlight-frontier?)) (define highlight-frontier? (send: config config<%> get-highlight-frontier?))
(send: sbview sb:syntax-browser<%> add-syntax stx (send: sbview sb:syntax-browser<%> add-syntax stx
#:definites (or definites null) #:definites (or definites null)
#:binder-table binders #:binders binders
#:shift-table shift-table #:shift-table shift-table
#:hi-colors (list hi-color #:hi-colors (list hi-color
"WhiteSmoke") "WhiteSmoke")

15
collects/macro-debugger/view/term-record.ss
View File

@ -47,12 +47,12 @@
(define deriv #f) (define deriv #f)
(define deriv-hidden? #f) (define deriv-hidden? #f)
(define binders #f)
(define shift-table #f) (define shift-table #f)
(define raw-steps #f) (define raw-steps #f)
(define raw-steps-estx #f) ;; #f if raw-steps-exn is exn (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-exn #f) ;; #f if raw-steps-estx is syntax
(define raw-steps-binders #f)
(define raw-steps-definites #f) (define raw-steps-definites #f)
(define raw-steps-oops #f) (define raw-steps-oops #f)
@ -75,9 +75,9 @@
(define-guarded-getters (recache-deriv!) (define-guarded-getters (recache-deriv!)
[get-deriv deriv] [get-deriv deriv]
[get-deriv-hidden? deriv-hidden?] [get-deriv-hidden? deriv-hidden?]
[get-binders binders]
[get-shift-table shift-table]) [get-shift-table shift-table])
(define-guarded-getters (recache-raw-steps!) (define-guarded-getters (recache-raw-steps!)
[get-raw-steps-binders raw-steps-binders]
[get-raw-steps-definites raw-steps-definites] [get-raw-steps-definites raw-steps-definites]
[get-raw-steps-exn raw-steps-exn] [get-raw-steps-exn raw-steps-exn]
[get-raw-steps-oops raw-steps-oops]) [get-raw-steps-oops raw-steps-oops])
@ -95,6 +95,7 @@
(set! raw-steps #f) (set! raw-steps #f)
(set! raw-steps-estx #f) (set! raw-steps-estx #f)
(set! raw-steps-exn #f) (set! raw-steps-exn #f)
(set! raw-steps-binders #f)
(set! raw-steps-definites #f) (set! raw-steps-definites #f)
(set! raw-steps-oops #f)) (set! raw-steps-oops #f))
@ -108,7 +109,6 @@
(invalidate-synth!) (invalidate-synth!)
(set! deriv #f) (set! deriv #f)
(set! deriv-hidden? #f) (set! deriv-hidden? #f)
(set! binders #f)
(set! shift-table #f)) (set! shift-table #f))
;; recache! : -> void ;; recache! : -> void
@ -141,7 +141,6 @@
(module-identifier-mapping-put! alpha-table id id)) (module-identifier-mapping-put! alpha-table id id))
binder-ids) binder-ids)
(set! deriv d) (set! deriv d)
(set! binders alpha-table)
(set! shift-table (compute-shift-table d))))))))) (set! shift-table (compute-shift-table d)))))))))
;; recache-synth! : -> void ;; recache-synth! : -> void
@ -158,12 +157,13 @@
(with-handlers ([(lambda (e) #t) (with-handlers ([(lambda (e) #t)
(lambda (e) (lambda (e)
(set! raw-steps-oops 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?)) (parameterize ((macro-policy show-macro?))
(reductions+ deriv))]) (reductions+ deriv))])
(set! raw-steps raw-steps*) (set! raw-steps raw-steps*)
(set! raw-steps-estx estx*) (set! raw-steps-estx estx*)
(set! raw-steps-exn error*) (set! raw-steps-exn error*)
(set! raw-steps-binders binders*)
(set! raw-steps-definites definites*))))))) (set! raw-steps-definites definites*)))))))
;; recache-steps! : -> void ;; recache-steps! : -> void
@ -283,7 +283,7 @@
(recache-steps!) (recache-steps!)
(cond [(syntax? raw-steps-estx) (cond [(syntax? raw-steps-estx)
(send: displayer step-display<%> add-syntax raw-steps-estx (send: displayer step-display<%> add-syntax raw-steps-estx
#:binders binders #:binders raw-steps-binders
#:shift-table shift-table #:shift-table shift-table
#:definites raw-steps-definites)] #:definites raw-steps-definites)]
[(exn? raw-steps-exn) [(exn? raw-steps-exn)
@ -297,10 +297,9 @@
(let ([step (cursor:next steps)]) (let ([step (cursor:next steps)])
(if step (if step
(send: displayer step-display<%> add-step step (send: displayer step-display<%> add-step step
#:binders binders
#:shift-table shift-table) #:shift-table shift-table)
(send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn (send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn
#:binders binders #:binders raw-steps-binders
#:shift-table shift-table #:shift-table shift-table
#:definites raw-steps-definites)))] #:definites raw-steps-definites)))]
[else (display-oops #t)])) [else (display-oops #t)]))

2
collects/tests/macro-debugger/gentests.ss
View File

@ -61,7 +61,7 @@
[else #f])) [else #f]))
(define (check-hide d policy expect-ok?) (define (check-hide d policy expect-ok?)
(let-values ([(steps defs stx2 exn) (let-values ([(steps binders uses stx2 exn)
(parameterize ((macro-policy policy)) (parameterize ((macro-policy policy))
(reductions+ d))]) (reductions+ d))])
(check-pred list? steps) (check-pred list? steps)

2
collects/tests/macro-debugger/test-setup.ss
View File

@ -127,7 +127,7 @@
;; Specialized macro hiding tests ;; Specialized macro hiding tests
(define (stx/hide-policy d policy) (define (stx/hide-policy d policy)
(define-values (_steps _uses stx _exn) (define-values (_steps _binders _uses stx _exn)
(parameterize ((macro-policy policy)) (parameterize ((macro-policy policy))
(reductions+ d))) (reductions+ d)))
stx) stx)

2
collects/tests/macro-debugger/tests/collects.ss
View File

@ -66,7 +66,7 @@
(check-steps deriv policy)))) (check-steps deriv policy))))
(define (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))) (parameterize ((macro-policy policy)) (reductions+ deriv)))
(check-pred syntax? stx) (check-pred syntax? stx)
(check-eq? exn #f) (check-eq? exn #f)

2
collects/tests/macro-debugger/tests/hiding.ss
View File

@ -11,7 +11,7 @@
(syntax-rules () (syntax-rules ()
[(th form hidden-e2 policy) [(th form hidden-e2 policy)
(test-case (format "~s" 'form) (test-case (format "~s" 'form)
(let-values ([(steps defs stx exn) (let-values ([(steps binders uses stx exn)
(parameterize ((macro-policy policy)) (parameterize ((macro-policy policy))
(reductions+ (trace/k 'form)))]) (reductions+ (trace/k 'form)))])
(check-pred syntax? stx) (check-pred syntax? stx)