macro-debugger: eliminated deriv-find, use unstable/find

svn: r16775

original commit: f042eb1e4df9a5b790adeaf09b4eab61f28fc008

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))

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 ...)))]))

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)

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"

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"

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))