; does a cover b
(define (case-covers? data-layouts a b)
(let ([a-binding? (and (eqv? (ast-type a) 'var) (not (constructor? data-layouts a)))])
- (if (eqv? ':binding b)
- a-binding?
- (if a-binding?
- #t
- (if (eqv? (ast-type b) 'var)
- (eqv? b a)
+ (cond
+ [(eqv? ':binding b) a-binding?]
+ [a-binding? #t]
+ ; a literal/singleton
+ [(eqv? (ast-type b) 'var) (eqv? b a)]
+ ; two different constructors
+ [(not (eqv? (car a) (car b))) #f]
+ ; two same constructors
+ [else
(all (map (lambda (p q)
(case-covers? data-layouts p q))
- (cdr a) (cdr b))))))))
+ (cdr a) (cdr b)))])))
(define (verify-cases data-layouts annotated-program)
(if (eqv? 'var (ast-type x))
(list (cons x inner-offset))
(begin
-; (display "LITERALliteral\n")
(emit "cmpq $~a, ~a(%rbp)" x inner-offset)
(emit "jne ~a" jne-label)
'() ))))
(xform-prog (cdr lambdas-res)))
; verify pattern matches are total
-; (verify-cases data-layouts type-annotated)
+ (verify-cases data-layouts type-annotated)
(emit "\t.global _start")
(emit "\t.text")
(case (foo 42 12)
[(foo 20 x) 0]
[(foo 42 x) x]
+ [(foo y x) 0]
[(bar x) 0]))
12)
[bar 12]))
12)
; todo: make this error for incomplete pattern match
-(test-exception '((data A [foo Int] [bar Int B])
+(test-exception
+ (codegen '((data A [foo Int] [bar Int B])
(data B [baz Int])
(let ([val (bar 42 (baz 12))])
(case val
[(foo 42) 0]
[(bar 32 (baz 12)) 1]
[(bar 42 (baz x)) x]
- [(foo x) 2]))))
+ [(foo x) 2])))))