From 1a2eea24ad962e4906c3231127f4a9e3a9d207b6 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 --- 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/hide.ss | 9 +--- collects/macro-debugger/model/reductions.ss | 4 +- collects/macro-debugger/model/synth-engine.ss | 25 ++++++---- collects/macro-debugger/view/gui.ss | 48 ++++++++++++++----- 8 files changed, 56 insertions(+), 40 deletions(-) diff --git a/collects/macro-debugger/model/debug.ss b/collects/macro-debugger/model/debug.ss index 1426e5d314..48fef9cfbb 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 bca3848373..9c5380c261 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 efd14066ad..45a291b584 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 f3e8305ff5..45f67fa89c 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/hide.ss b/collects/macro-debugger/model/hide.ss index a16ea15bd8..4476492224 100644 --- a/collects/macro-debugger/model/hide.ss +++ b/collects/macro-debugger/model/hide.ss @@ -208,11 +208,6 @@ ([for-derivs (SRHS ...) srhss] [for-derivs (VRHS ...) vrhss] [for-bderiv BODY body]))] -; #:with (lambda (new-e2) -; (syntax-case #'BODY () -; [(e) #'e] -; [(e ...) #'(begin e ...)])))] - [(AnyQ p:#%datum (e1 e2 rs tagged-stx)) (cond [(or (eq? tagged-stx e1) (show-macro? #'#%datum)) (values d e2)] @@ -454,7 +449,7 @@ (for-bderiv body))] [(AnyQ p:case-lambda (e1 e2 rs renames+bodies)) ;; Like lambda - (with-syntax ([(?case-lambda [?clause ...]) e1]) + (with-syntax ([(?case-lambda ?clause ...) e1]) (apply append (map (lambda (rename+body clause-stx) (let ([new-table (table-restrict/case-lambda clause-stx (car rename+body))]) @@ -467,8 +462,6 @@ (let ([new-table (table-restrict/let e1 renames)]) (parameterize ((subterms-table new-table)) (for-bderiv body))))] - [(AnyQ p:let*-values (e1 e2 rs inner)) - (for-deriv inner)] [(AnyQ p:letrec-values (e1 e2 rs renames rhss body)) (let ([new-table (table-restrict/let e1 renames)]) (parameterize ((subterms-table new-table)) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index d47d78dae5..8992e24e01 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) diff --git a/collects/macro-debugger/model/synth-engine.ss b/collects/macro-debugger/model/synth-engine.ss index 3a06f86f6a..778fd9540c 100644 --- a/collects/macro-debugger/model/synth-engine.ss +++ b/collects/macro-debugger/model/synth-engine.ss @@ -53,11 +53,14 @@ #'(>>Prim pr e1 restamp? cons+vars inp outp clauses #:with values)] [(>>Prim pr e1 restamp? cons+vars inp outp clauses #:with transform) #'(>>Prim pr e1 restamp? cons+vars inp outp clauses - #:with2 (lambda (prvar stx) (values prvar (transform stx))))] + #:with transform #:with2 values)] + [(>>Prim pr given-e1 restamp? cons+vars inp outp clauses #:with2 transform) + #'(>>Prim pr given-e1 restamp? cons+vars inp outp clauses #:with values #:with2 transform)] [(>>Prim pr given-e1 restamp? (constructor var ...) in-pattern out-pattern ([recur hole fill/bind] ...) + #:with stransform #:with2 transform) (let ([restamp? (syntax-e #'restamp?)]) (with-syntax ([(s-tmp ...) (generate-temporaries #'(fill/bind ...))]) @@ -65,14 +68,16 @@ (let-values ([(fill/bind s-tmp) (let ([fbvar fill/bind]) (if fbvar (recur fbvar) (values fbvar #f)))] ...) - (let ([new-e2 (if (or (interrupted-wrap? prule-var) (error-wrap? prule-var)) - #f - (with-syntax ([in-pattern given-e1]) - (with-syntax ([hole s-tmp] ...) - #,(if restamp? - #'(syntax/restamp out-pattern #'out-pattern - (deriv-e2 prule-var)) - #'#'out-pattern))))]) + (let ([new-e2 + (stransform + (if (or (interrupted-wrap? prule-var) (error-wrap? prule-var)) + #f + (with-syntax ([in-pattern given-e1]) + (with-syntax ([hole s-tmp] ...) + #,(if restamp? + #'(syntax/restamp out-pattern #'out-pattern + (deriv-e2 prule-var)) + #'#'out-pattern)))))]) (let ([new-pr (match prule-var [(AnyQ prule (e1 _ rs)) @@ -80,7 +85,7 @@ (let-values ([(new-pr new-e2) (transform new-pr new-e2)]) (values (rewrap prule-var new-pr) new-e2))))))))])) - + (define-syntax >>Seek (syntax-rules (!) [(>>Seek) null] diff --git a/collects/macro-debugger/view/gui.ss b/collects/macro-debugger/view/gui.ss index e672058500..071b668a09 100644 --- a/collects/macro-debugger/view/gui.ss +++ b/collects/macro-debugger/view/gui.ss @@ -49,6 +49,10 @@ (define/override (on-size w h) (send widget update/preserve-view)) + (define/augment (on-close) + (send widget shutdown) + (inner (void) on-close)) + (override/return-false file-menu:create-new? file-menu:create-open? file-menu:create-open-recent? @@ -130,6 +134,8 @@ (define steps #f) + (define warnings-frame #f) + (define/public (add-deriv d) (set! derivs (append derivs (list d))) (when (and (not (send updown-navigator is-shown?)) @@ -376,10 +382,10 @@ (with-handlers ([(lambda (e) (catch-errors?)) (lambda (e) (no-synthesize deriv))]) (parameterize ((current-hiding-warning-handler - (let ([warnings (delay (new warnings-frame%))]) - (lambda (tag message) - (send (force warnings) - add-warning tag))))) + (lambda (tag message) + (unless warnings-frame + (set! warnings-frame (new warnings-frame%))) + (send warnings-frame add-warning tag)))) (let-values ([(d s) (hide/policy deriv show-macro?)]) d))) deriv))) @@ -407,7 +413,12 @@ (define/private (get-show-macro?) (let ([policy (send macro-hiding-prefs get-policy)]) (and policy (lambda (id) (policy-show-macro? policy id))))) - + + ;; -- + + (define/public (shutdown) + (when warnings-frame (send warnings-frame show #f))) + ;; Initialization (super-new) @@ -632,6 +643,22 @@ (define ec (new editor-canvas% (parent this) (editor text))) (send text lock #t) + (define -nonlinearity-text #f) + (define -localactions-text #f) + + (define/private (add-nonlinearity-text) + (unless -nonlinearity-text + (set! -nonlinearity-text #t) + (add-text "An opaque macro duplicated one of its subterms. " + "Macro hiding requires opaque macros to use their subterms linearly. " + "The macro stepper is showing the expansion of that macro use."))) + (define/private (add-localactions-text) + (unless -localactions-text + (set! -localactions-text #t) + (add-text "An opaque macro called local-expand, syntax-local-lift-expression, " + "etc. Macro hiding cannot currently handle local actions. " + "The macro stepper is showing the expansion of that macro use."))) + (define/private (add-text . strs) (send text lock #f) (for-each (lambda (s) (send text insert s)) strs) @@ -641,15 +668,10 @@ (define/public (add-warning tag) (case tag ((nonlinearity) - (add-text - "An opaque macro duplicated one of its subterms. " - "Macro hiding requires opaque macros to use their subterms linearly. " - "The macro stepper is showing the expansion of that macro use.")) + (add-nonlinearity-text)) ((localactions) - (add-text - "An opaque macro called local-expand, syntax-local-lift-expression, " - "etc. Macro hiding cannot currently handle local actions. " - "The macro stepper is showing the expansion of that macro use.")))) + (add-nonlinearity-text)))) + (send this show #t))) ;; Main entry points