Fix total pattern match verification

[scheme.git] / ast.scm

diff --git a/ast.scm b/ast.scm
index eabad585fec27b4f6c83f3c747ca0c7925a80de2..cfd774a2202cd5af24ae71c7facfd81bd966d63c 100644 (file)
--- a/ast.scm
+++ b/ast.scm
@@ -25,7 +25,6 @@
    ((builtin? x) 'builtin)
    ((symbol? x) 'var)
    ((integer? x) 'int-literal)
-   ((boolean? x) 'bool-literal)
    ((string? x) 'string-literal)))
 
 (define (ast-traverse f x)
@@ -106,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)