From 27ce8d0f3b6725bad6eb14eb2726847a838d21f5 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 15 Sep 2006 13:18:50 +0000 Subject: [PATCH] =?UTF-8?q?Fixed=20hiding=20bugs=20=20=20in=20case-lambda,?= =?UTF-8?q?=20fixed=20renaming=20bug=20=20=20in=20let-values=20and=20letre?= =?UTF-8?q?c-values,=20fixed=20hiding=20on=20errors=20=20=20fixed=20do-ren?= =?UTF-8?q?ame=20loop;=20now=20let=20bound-id=3D=3F=20works=20as=20expecte?= =?UTF-8?q?d!=20Added=20hide.ss=20to=20debug.ss=20exports?= svn: r4347 --- collects/macro-debugger/model/debug.ss | 2 ++ collects/macro-debugger/model/hide.ss | 14 ++++++++------ 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss index 48fef9cfbb..9297742881 100644 --- a/collects/macro-debugger/model/debug.ss +++ b/collects/macro-debugger/model/debug.ss @@ -3,6 +3,7 @@ (require (lib "plt-match.ss")) (require "trace.ss" "deriv-util.ss" + "hide.ss" "hiding-policies.ss" "deriv.ss") @@ -10,6 +11,7 @@ (all-from "deriv.ss") (all-from "deriv-util.ss") (all-from "hiding-policies.ss") + (all-from "hide.ss") (all-from (lib "plt-match.ss")) find-deriv) diff --git a/collects/macro-debugger/model/hide.ss b/collects/macro-debugger/model/hide.ss index 23ffe46485..f509424570 100644 --- a/collects/macro-debugger/model/hide.ss +++ b/collects/macro-debugger/model/hide.ss @@ -206,7 +206,7 @@ [for-bderiv BODY body]))] [(AnyQ p:case-lambda (e1 e2 rs renames+bodies)) - (let ([var-renames (map car renames+bodies)]) + (let ([var-renames (map caar renames+bodies)]) (>>P d (make-p:case-lambda renames+bodies) (case-lambda [FORMALS . BODY] ...) ([for-renames (FORMALS ...) var-renames] @@ -221,7 +221,7 @@ [for-bderiv BODY body])))] [(AnyQ p:letrec-values (e1 e2 rs renames rhss body)) - (let ([var-renames (map stx-car (stx-car renames))]) + (let ([var-renames (if renames (map stx-car (stx-car renames)) null)]) (>>P d (make-p:letrec-values renames rhss body) (letrec-values ([VARS RHS] ...) . BODY) ([for-renames (VARS ...) var-renames] @@ -229,8 +229,8 @@ [for-bderiv BODY body])))] [(AnyQ p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body)) - (let ([svar-renames (map stx-car (stx-car srenames))] - [vvar-renames (map stx-car (stx-car vrenames))]) + (let ([svar-renames (if srenames (map stx-car (stx-car srenames)) null)] + [vvar-renames (if vrenames (map stx-car (stx-car vrenames)) null)]) (>>Pn d (make-p:letrec-syntaxes+values srenames srhss vrenames vrhss body) (letrec-syntaxes+values ([SVARS SRHS] ...) ([VVARS VRHS] ...) . BODY) ([for-renames (SVARS ...) svar-renames] @@ -502,8 +502,8 @@ (loop (cdr clauses) (cdr renames+bodies))) null))))] [(AnyQ p:let-values (e1 e2 rs renames rhss body)) - (>>Seek [#:append (map for-deriv rhss)] - [#:rename (do-rename/let e1 renames)] + (>>Seek [#:rename (do-rename/let e1 renames)] + [#:append (map for-deriv rhss)] (for-bderiv body))] [(AnyQ p:letrec-values (e1 e2 rs renames rhss body)) (>>Seek [#:rename (do-rename/let e1 renames)] @@ -1181,6 +1181,8 @@ (loop (syntax-e stx) (syntax-e rename) active?)))] [(syntax? rename) (loop stx (syntax-e rename) active?)] + [(syntax? stx) + (loop (syntax-e stx) rename active?)] [(and (pair? stx) (pair? rename)) (append (loop (car stx) (car rename) active?)