commit 3f158d67fdd56ddf6d34f95468a8ebd399a5f283
parent 84c6dad33e3c7042d49e3e4ea8102c1a6d096a21
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sun, 15 Nov 2009 07:37:56 +0000
macro-debugger: eliminated deriv-find, use unstable/find
svn: r16775
original commit: f042eb1e4df9a5b790adeaf09b4eab61f28fc008
Diffstat:
6 files changed, 32 insertions(+), 44 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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))
