From e675ebf32308d4657b0d0e81d2496f6f92ff4297 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 27 Feb 2007 23:44:25 +0000
Subject: [PATCH] Macro stepper:   fixed bug in reductions wrt
 letrec-syntaxes+values   added more binding arrows

svn: r5702
---
 collects/macro-debugger/model/deriv-util.ss | 28 ++++++++++++++++++++-
 collects/macro-debugger/model/reductions.ss |  5 +++-
 2 files changed, 31 insertions(+), 2 deletions(-)

diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss
index d173cf0cd3..1eaf40fd1b 100644
--- a/collects/macro-debugger/model/deriv-util.ss
+++ b/collects/macro-debugger/model/deriv-util.ss
@@ -263,7 +263,11 @@
           (p:let-values? x)
           (p:letrec-values? x)
           (p:letrec-syntaxes+values? x)
-          (p:rename? x)))
+          (p:rename? x)
+          (b:defvals? x)
+          (b:defstx? x)
+          (p:define-values? x)
+          (p:define-syntaxes? x)))
     (define (extract-fresh-names d)
       (match d
         [(struct p:lambda (e1 e2 rs renames body))
@@ -292,6 +296,28 @@
               (with-syntax ([(((?vvars ?vrhs) ...) . ?body) vrenames])
                 #'(?vvars ...))
               null))]
+        [(struct b:defvals (rename head))
+         (let ([head-e2 (lift/deriv-e2 head)])
+           (if head-e2
+               (with-syntax ([(?dv ?vars ?rhs) head-e2])
+                 #'?vars)
+               null))]
+        [(struct b:defstx (rename head rhs))
+         (let ([head-e2 (lift/deriv-e2 head)])
+           (if head-e2
+               (with-syntax ([(?ds ?svars ?rhs) head-e2])
+                 #'?svars)
+               null))]
+        [(struct p:define-values (e1 e2 rs rhs))
+         (if rhs
+             (with-syntax ([(?dv ?vars ?rhs) e1])
+               #'?vars)
+             null)]
+        [(struct p:define-syntaxes (e1 e2 rs rhs))
+         (if rhs
+             (with-syntax ([(?ds ?svars ?srhs) e1])
+               #'?svars)
+             null)]
         [_ null]))
 
     (let ([all-renaming-forms
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
index 4ff982f469..1ba1827838 100644
--- a/collects/macro-debugger/model/reductions.ss
+++ b/collects/macro-debugger/model/reductions.ss
@@ -46,6 +46,7 @@
 
       ;; Primitives
       [(struct p:variable (e1 e2 rs))
+       (learn-definites (list e2))
        (if (bound-identifier=? e1 e2)
            null
            (list (walk e1 e2 'resolve-variable)))]
@@ -185,7 +186,7 @@
        (R e1
           [! exni]
           [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
-          [#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs] ...) . ?body*) srenames]
+          [#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames]
           [#:rename
            (syntax/skeleton e1
                             (?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...)
@@ -217,6 +218,8 @@
                    (list (stumble tagged-stx (car exni)))
                    null))]
       [(AnyQ p:#%top (e1 e2 rs tagged-stx) exni)
+       (with-syntax ([(?top . ?var) tagged-stx])
+         (learn-definites (list #'?var)))
        (append (if (eq? e1 tagged-stx)
                    null
                    (list (walk e1 tagged-stx 'tag-top)))