Fixed case-lambda reductions bug

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

svn: r4246

original commit: 1a2eea24ad962e4906c3231127f4a9e3a9d207b6
This commit is contained in:
Ryan Culpepper 2006-09-05 19:58:57 +00:00
parent cbf83f809b
commit d75f99286b
5 changed files with 5 additions and 9 deletions

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

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)

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,7 +341,8 @@
(#: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)])

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

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)