Fix unwanted reordering of match
patterns.
This change ensures that the `reorder?` flag is passed to recursive calls to `compile` correctly. Related to racket/frtime#1, which is probably now fixed. Merge to 6.3.
This commit is contained in:
parent
95c80cf21f
commit
7338f45bd2
|
@ -11,6 +11,9 @@
|
||||||
|
|
||||||
(provide compile*)
|
(provide compile*)
|
||||||
|
|
||||||
|
;; should we reorder stuff?
|
||||||
|
(define can-reorder? (make-parameter #t))
|
||||||
|
|
||||||
;; for non-linear patterns
|
;; for non-linear patterns
|
||||||
(define vars-seen (make-parameter null))
|
(define vars-seen (make-parameter null))
|
||||||
|
|
||||||
|
@ -268,6 +271,7 @@
|
||||||
(define pats (Row-pats row))
|
(define pats (Row-pats row))
|
||||||
;; all the patterns
|
;; all the patterns
|
||||||
(define qs (And-ps (car pats)))
|
(define qs (And-ps (car pats)))
|
||||||
|
(printf ">>> calling compile ~a\n " (append qs (cdr pats)))
|
||||||
(compile* (append (map (lambda _ x) qs) xs)
|
(compile* (append (map (lambda _ x) qs) xs)
|
||||||
(list (make-Row (append qs (cdr pats))
|
(list (make-Row (append qs (cdr pats))
|
||||||
(Row-rhs row)
|
(Row-rhs row)
|
||||||
|
@ -426,7 +430,7 @@
|
||||||
#'failkv))))))]
|
#'failkv))))))]
|
||||||
[else (error 'compile "unsupported pattern: ~a\n" first)]))
|
[else (error 'compile "unsupported pattern: ~a\n" first)]))
|
||||||
|
|
||||||
(define (compile* vars rows esc [reorder? #t])
|
(define (compile* vars rows esc [reorder? (can-reorder?)])
|
||||||
(define (let/wrap clauses body)
|
(define (let/wrap clauses body)
|
||||||
(if (stx-null? clauses)
|
(if (stx-null? clauses)
|
||||||
body
|
body
|
||||||
|
@ -481,7 +485,9 @@
|
||||||
[(f) (generate-temporaries #'(f))]
|
[(f) (generate-temporaries #'(f))]
|
||||||
;; compile the block, with jumps to the previous
|
;; compile the block, with jumps to the previous
|
||||||
;; esc
|
;; esc
|
||||||
[c (compile-one vars (car blocks) esc)])
|
[c
|
||||||
|
(parameterize ([can-reorder? reorder?])
|
||||||
|
(compile-one vars (car blocks) esc))])
|
||||||
;; then compile the rest, with our name as the esc
|
;; then compile the rest, with our name as the esc
|
||||||
(loop (cdr blocks)
|
(loop (cdr blocks)
|
||||||
#'f
|
#'f
|
||||||
|
|
Loading…
Reference in New Issue
Block a user