Fix total pattern match verification

diff --git a/ast.scm b/ast.scm
index c32e47e663d3e8fb2bbe10021eab404ad79c0cf9..cfd774a2202cd5af24ae71c7facfd81bd966d63c 100644 (file)
--- a/ast.scm
+++ b/ast.scm
@@ -105,15 +105,18 @@
                                        ; 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)
 

diff --git a/codegen.scm b/codegen.scm
index 7518d8396527ec44c9291f854aea6d128c33ab08..748781d9f4cde883830176a93c651172c8ec81f4 100644 (file)
--- a/codegen.scm
+++ b/codegen.scm
@@ -502,7 +502,6 @@
        (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)
              '() ))))
@@ -874,7 +873,7 @@
         (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")

diff --git a/tests.scm b/tests.scm
index 4e6818578f8e37ee3e88205e4b47aff44b9130cb..7a9b3bffd34df74b48680816cf8e7ceb50b7adbc 100644 (file)
--- a/tests.scm
+++ b/tests.scm
@@ -311,6 +311,7 @@
             (case (foo 42 12)
               [(foo 20 x) 0]
               [(foo 42 x) x]
+              [(foo y x) 0]
               [(bar x) 0]))
           12)
 
@@ -334,12 +335,13 @@
               [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])))))