Fix total pattern match verification

[scheme.git] / ast.scm

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)