From 6b91111c8d3fd8e617bece8d69f6c98d5e6ef3cb Mon Sep 17 00:00:00 2001
From: Luke Lau <luke_lau@icloud.com>
Date: Sat, 17 Aug 2019 19:53:14 +0100
Subject: [PATCH] Fix total pattern match verification

---
 ast.scm     | 17 ++++++++++-------
 codegen.scm |  3 +--
 tests.scm   |  6 ++++--
 3 files changed, 15 insertions(+), 11 deletions(-)

diff --git a/ast.scm b/ast.scm
index c32e47e..cfd774a 100644
--- 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 7518d83..748781d 100644
--- 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 4e68185..7a9b3bf 100644
--- 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])))))
 
-- 
2.30.2