diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss index cfdc5a9..3ba4ad0 100644 --- a/collects/macro-debugger/model/debug.ss +++ b/collects/macro-debugger/model/debug.ss @@ -5,7 +5,6 @@ "reductions.ss" "reductions-config.ss" "deriv-util.ss" - "deriv-find.ss" "hiding-policies.ss" "deriv.ss" "steps.ss") @@ -15,7 +14,6 @@ (all-from-out "reductions-config.ss") (all-from-out "deriv.ss") (all-from-out "deriv-util.ss") - (all-from-out "deriv-find.ss") (all-from-out "hiding-policies.ss") (all-from-out "steps.ss") (all-from-out scheme/match)) diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss index 951dd2c..ee8afd2 100644 --- a/collects/macro-debugger/model/deriv-util.ss +++ b/collects/macro-debugger/model/deriv-util.ss @@ -4,6 +4,7 @@ (for-syntax scheme/private/struct-info) scheme/list scheme/match + unstable/struct "deriv.ss") (provide make @@ -68,33 +69,3 @@ (define (wderivlist-es2 xs) (let ([es2 (map wderiv-e2 xs)]) (and (andmap syntax? es2) es2))) - -;; ---- - -(define-syntax (make stx) - (syntax-case stx () - [(make S expr ...) - (unless (identifier? #'S) - (raise-syntax-error #f "not an identifier" stx #'S)) - (let () - (define (no-info) (raise-syntax-error #f "not a struct" stx #'S)) - (define info - (extract-struct-info - (syntax-local-value #'S no-info))) - (define constructor (list-ref info 1)) - (define accessors (list-ref info 3)) - (unless (identifier? #'constructor) - (raise-syntax-error #f "constructor not available for struct" stx #'S)) - (unless (andmap identifier? accessors) - (raise-syntax-error #f "incomplete info for struct type" stx #'S)) - (let ([num-slots (length accessors)] - [num-provided (length (syntax->list #'(expr ...)))]) - (unless (= num-provided num-slots) - (raise-syntax-error - #f - (format "wrong number of arguments for struct ~s (expected ~s)" - (syntax-e #'S) - num-slots) - stx))) - (with-syntax ([constructor constructor]) - #'(constructor expr ...)))])) diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss index a1fe495..b75d7b4 100644 --- a/collects/macro-debugger/model/steps.ss +++ b/collects/macro-debugger/model/steps.ss @@ -1,8 +1,7 @@ #lang scheme/base (require "deriv.ss" - "deriv-util.ss" - "deriv-find.ss") + "deriv-util.ss") (provide (struct-out protostep) (struct-out step) (struct-out misstep) diff --git a/collects/macro-debugger/view/step-display.ss b/collects/macro-debugger/view/step-display.ss index 355a940..5a9196a 100644 --- a/collects/macro-debugger/view/step-display.ss +++ b/collects/macro-debugger/view/step-display.ss @@ -15,7 +15,6 @@ "hiding-panel.ss" "../model/deriv.ss" "../model/deriv-util.ss" - "../model/deriv-find.ss" "../model/deriv-parser.ss" "../model/trace.ss" "../model/reductions-config.ss" diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index 41b44b8..ccc8992 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -18,7 +18,6 @@ (prefix-in sb: "../syntax-browser/interfaces.ss") "../model/deriv.ss" "../model/deriv-util.ss" - "../model/deriv-find.ss" "../model/trace.ss" "../model/reductions.ss" "../model/steps.ss" diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss index e13daf5..2fc5637 100644 --- a/collects/macro-debugger/view/term-record.ss +++ b/collects/macro-debugger/view/term-record.ss @@ -7,6 +7,8 @@ scheme/gui framework/framework syntax/boundmap + syntax/stx + unstable/find "interfaces.ss" "prefs.ss" "extensions.ss" @@ -15,7 +17,6 @@ "step-display.ss" "../model/deriv.ss" "../model/deriv-util.ss" - "../model/deriv-find.ss" "../model/deriv-parser.ss" "../model/trace.ss" "../model/reductions-config.ss" @@ -135,13 +136,8 @@ (when (not d) (set! deriv-hidden? #t)) (when d - (let ([alpha-table (make-module-identifier-mapping)] - [binder-ids (extract-all-fresh-names d)]) - (for-each (lambda (id) - (module-identifier-mapping-put! alpha-table id id)) - binder-ids) - (set! deriv d) - (set! shift-table (compute-shift-table d))))))))) + (set! deriv d) + (set! shift-table (compute-shift-table d)))))))) ;; recache-synth! : -> void (define/private (recache-synth!) @@ -317,3 +313,29 @@ [else (error 'term-record::display-oops "internal error")])) )) + + +;; compute-shift-table : deriv -> hash[id => (listof id)] +(define (compute-shift-table d) + (define ht (make-hasheq)) + (define module-forms + (find p:module? d #:stop-on-found? #t)) + (define module-shift-renamers + (for/list ([mf module-forms]) + (let ([shift (p:module-shift mf)] + [body (p:module-body mf)]) + (and shift body + (with-syntax ([(_module _name _lang shifted-body) shift]) + (add-rename-mapping ht (wderiv-e2 body) #'shifted-body)))))) + ht) + +(define (add-rename-mapping ht from to) + (define (loop from to) + (cond [(and (stx-pair? from) (stx-pair? to)) + (loop (stx-car from) (stx-car to)) + (loop (stx-cdr from) (stx-cdr to))] + [(and (identifier? from) (identifier? to)) + (hash-set! ht from (cons to (hash-ref ht from null)))] + [else (void)])) + (loop from to) + (void))