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

match: eliminate field refs due to _ in constructor patterns

Browse Source 
Related to #3487.
This commit is contained in:
Bogdan Popa 2020-11-06 21:40:44 +02:00 committed by Sam Tobin-Hochstadt
parent 403ef87ec2
commit 684a1f1039
2 changed files with 46 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
pkgs/racket-test/tests/match/examples.rkt
View File

@ -342,6 +342,30 @@
[(struct tree (a (struct tree (b _ _)) _)) (list a b)]
[_ 'no])))
(comp
'ok
(let ()
(define-struct st ([x #:mutable])
#:transparent)
(define a (st 1))
(define b (impersonate-struct a st-x (lambda (_self _x)
(error "must not impersonate"))))
(match b
[(st _) 'ok])))
(comp
'ok
(let ()
(define impersonated? #f)
(define-struct st ([x #:mutable])
#:transparent)
(define a (st 1))
(define b (impersonate-struct a st-x (lambda (_self x)
(set! impersonated? #t)
x)))
(match b
[(st x) (if impersonated? 'ok 'fail)])))
(comp 1
(match #&1
[(box a) a]

23
racket/collects/racket/match/compiler.rkt
View File

@ -74,7 +74,11 @@
(Row-vars-seen row)))
rows)
esc)])
#`[question (let ([tmps (accs #,x)] ...) body)]))
(define-values (used-tmps used-accs)
(remove-unused-tmps #'(tmps ...) #'(accs ...) #'body))
(with-syntax ([(used-tmps ...) used-tmps]
[(used-accs ...) used-accs])
#`[question (let ([used-tmps (used-accs #,x)] ...) body)])))
(cond
[(eq? 'box k)
(compile-con-pat (list #'unsafe-unbox*) #'box? (compose list Box-p))]
@ -130,6 +134,23 @@
[(procedure? k) (constant-pat k)]
[else (error 'match-compile "bad key: ~a" k)]))
;; Remove any `tmps' (and their associated `accs') that are not
;; present in `body'.
(define (remove-unused-tmps tmps accs body)
(define seen (make-hasheq))
(let loop ([stx body])
(cond
[(identifier? stx)
(for/first ([tmp (in-list (syntax-e tmps))] #:when (free-identifier=? tmp stx))
(hash-set! seen tmp #t))]
[(list? (syntax-e stx))
(for-each loop (syntax-e stx))]))
(for/lists (tmps accs)
([tmp (in-list (syntax-e tmps))]
[acc (in-list (syntax-e accs))]
#:when (hash-has-key? seen tmp))
(values tmp acc)))
;; produces the syntax for a let clause
(define (compile-one vars block esc)