From d75f99286b72d7677229d315e373d35a663e9ea9 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 5 Sep 2006 19:58:57 +0000 Subject: [PATCH] Fixed case-lambda reductions bug Removed let*-values prule, faked as mrule Suppressed copies of warning messages svn: r4246 original commit: 1a2eea24ad962e4906c3231127f4a9e3a9d207b6 --- collects/macro-debugger/model/debug.ss | 2 -- collects/macro-debugger/model/deriv-c.ss | 1 - collects/macro-debugger/model/deriv-parser.ss | 6 ++++-- collects/macro-debugger/model/deriv.ss | 1 - collects/macro-debugger/model/reductions.ss | 4 +--- 5 files changed, 5 insertions(+), 9 deletions(-) diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss index 1426e5d..48fef9c 100644 --- a/collects/macro-debugger/model/debug.ss +++ b/collects/macro-debugger/model/debug.ss @@ -51,8 +51,6 @@ (apply append (map loop (map cdr (or rbs null))))] [(AnyQ p:let-values (_ _ _ _ rhss body)) (append (loops rhss) (loop body))] - [(AnyQ p:let*-values (_ _ _ inner)) - (loop inner)] [(AnyQ p:letrec-values (_ _ _ _ rhss body)) (append (loops rhss) (loop body))] [(AnyQ p:letrec-syntaxes+values (_ _ _ _ srhss _ vrhss body)) diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss index bca3848..9c5380c 100644 --- a/collects/macro-debugger/model/deriv-c.ss +++ b/collects/macro-debugger/model/deriv-c.ss @@ -50,7 +50,6 @@ (define-struct (p:lambda prule) (renames body) #f) (define-struct (p:case-lambda prule) (renames+bodies) #f) (define-struct (p:let-values prule) (renames rhss body) #f) - (define-struct (p:let*-values prule) (inner) #f) (define-struct (p:letrec-values prule) (renames rhss body) #f) (define-struct (p:letrec-syntaxes+values prule) (srenames srhss vrenames vrhss body) #f) diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index efd1406..45a291b 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -3,6 +3,7 @@ (require "yacc-ext.ss" "yacc-interrupted.ss" "deriv.ss" + "deriv-util.ss" "deriv-tokens.ss") (provide parse-derivation) @@ -340,11 +341,12 @@ (#:args e1 e2 rs) ;; let*-values with bindings is "macro-like" [(prim-let*-values ! (? EE)) - (make-p:let*-values e1 e2 rs $3)] + (let ([next-e1 (lift/deriv-e1 $3)]) + (make-mrule e1 e2 (make-transformation e1 next-e1 rs e1 next-e1 null) $3))] ;; No bindings... model as "let" [(prim-let*-values NoError renames-let (? NextEEs 'rhss) next-group (? EB 'body)) (make-p:let-values e1 e2 rs $3 $4 $6)]) - + (PrimLetrecValues (#:args e1 e2 rs) [(prim-letrec-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body)) diff --git a/collects/macro-debugger/model/deriv.ss b/collects/macro-debugger/model/deriv.ss index f3e8305..45f67fa 100644 --- a/collects/macro-debugger/model/deriv.ss +++ b/collects/macro-debugger/model/deriv.ss @@ -108,7 +108,6 @@ (struct p:lambda (renames body)) (struct p:case-lambda (renames+bodies)) (struct p:let-values (renames body)) - (struct p:let*-values (inner)) (struct p:letrec-values (renames rhss body)) (struct p:letrec-syntaxes+values (srenames srhss vrenames vrhss body)) (struct p:module (body)) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index d47d78d..8992e24 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -179,9 +179,7 @@ [Expr (?vrhs ...) vrhss] [Block ?body body] => (lambda (mid) - (if (eq? mid e2) - null - (list (walk mid e2 "Remove syntax bindings")))))] + (list (walk mid e2 "Remove syntax bindings"))))] ;; The auto-tagged atomic primitives [(AnyQ p:#%datum (e1 e2 rs tagged-stx) exni) (append (if (eq? e1 tagged-stx)