suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixed case-lambda reductions bug

Browse Source 
Removed let*-values prule, faked as mrule
Suppressed copies of warning messages

svn: r4246
This commit is contained in:
Ryan Culpepper 2006-09-05 19:58:57 +00:00
parent bd15eb9833
commit 1a2eea24ad
8 changed files with 56 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/macro-debugger/model/debug.ss
View File

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

1
collects/macro-debugger/model/deriv-c.ss
View File

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

6
collects/macro-debugger/model/deriv-parser.ss
View File

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

1
collects/macro-debugger/model/deriv.ss
View File

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

9
collects/macro-debugger/model/hide.ss
View File

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

4
collects/macro-debugger/model/reductions.ss
View File

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

25
collects/macro-debugger/model/synth-engine.ss
View File

@ -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]

48
collects/macro-debugger/view/gui.ss
View File

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