Check for the right number of bindings in pattern matching

diff --git a/ast.scm b/ast.scm
index 8a986173d675f43eb58cd0c5f7c6c7c679175d9f..b3f21bd07d6d07ba2b64017cff0a365cbf77abd4 100644 (file)
--- a/ast.scm
+++ b/ast.scm
@@ -83,27 +83,47 @@
                                        ;   v
                                        ; (let ([a (foo~0 (foo 123 345)]
                                         ;       [b (foo~1 (foo 123 345)]) a)
                                        ;   v
                                        ; (let ([a (foo~0 (foo 123 345)]
                                         ;       [b (foo~1 (foo 123 345)]) a)

-(define (expand-pattern-matches x)  
+(define (expand-pattern-matches program)
+  (define (go x)

     (define (pattern-match binding)
       (let ([binding-name (car binding)]
            [body (cadr binding)])
        (if (eqv? (ast-type binding-name) 'var)
            (list (list binding-name body))
     (define (pattern-match binding)
       (let ([binding-name (car binding)]
            [body (cadr binding)])
        (if (eqv? (ast-type binding-name) 'var)
            (list (list binding-name body))

+           

            (let* ([sum-name (car binding-name)]
            (let* ([sum-name (car binding-name)]

-                [destructor (lambda (i) (dtor-name sum-name i))])
+                  [destructor (lambda (i) (dtor-name sum-name i))]
+                  [products (cdr binding-name)]
+
+                  [data-layouts (program-data-layouts program)]
+
+                  [type (data-tor-type data-layouts sum-name)]
+
+                  [sum (assoc sum-name (cdr (assoc type data-layouts)))]
+                  
+                  [expected-number (length (cdr sum))])
+
+                                       ; assert that there is the correct number of bindings
+             (when (not (= (length products)
+                           expected-number))
+               (error #f (format "Got ~a bindings: expected ~a for ~a"
+                              (length products)
+                              expected-number
+                              binding)))
+             

              (flat-map (lambda (y i)
                          (pattern-match (list y `(,(destructor i) ,body))))
              (flat-map (lambda (y i)
                          (pattern-match (list y `(,(destructor i) ,body))))

-                     (cdr binding-name)
-                     (range 0 (length (cdr binding-name))))))))
+                       products
+                       (range 0 (length products)))))))

     (case (ast-type x)
       ['let `(let ,(flat-map pattern-match (let-bindings x))
     (case (ast-type x)
       ['let `(let ,(flat-map pattern-match (let-bindings x))

-                 ,@(map expand-pattern-matches (let-body x)))]
-      [else (ast-traverse expand-pattern-matches x)]))
+              ,@(map go (let-body x)))]
+      [else (ast-traverse go x)]))
+  (program-map-exprs go program))

 
 (define (lambda? x)
   (and (list? x) (eq? (car x) 'lambda)))
 
 
 (define (lambda? x)
   (and (list? x) (eq? (car x) 'lambda)))
 

-

 (define (statement-type x)
   (cond
    [(and (list? x)
 (define (statement-type x)
   (cond
    [(and (list? x)


@@ -137,6 +157,11 @@
      ,@(filter (lambda (x) (eqv? (statement-type x) 'expr))
               program)))
 
      ,@(filter (lambda (x) (eqv? (statement-type x) 'expr))
               program)))
 

+(define (data-tor-type data-layouts tor)
+  (let* ([tors (flat-map data-tors data-layouts)]
+        [info (cadr (assoc tor tors))])
+    (car info)))
+

                                        ; a data tor is either a constructor or destructor for an ADT
                                        ; data-tors returns constructors and destructors for a data-layout
                                        ; (data A (foo Int Bool)
                                        ; a data tor is either a constructor or destructor for an ADT
                                        ; data-tors returns constructors and destructors for a data-layout
                                        ; (data A (foo Int Bool)

diff --git a/codegen.scm b/codegen.scm
index 8e3a7d5c7191488c5a11843c07e7c5f168672407..dededbec01e0856b19703d8945e096e49b316aa5 100644 (file)
--- a/codegen.scm
+++ b/codegen.scm
@@ -658,9 +658,7 @@
   (set! cur-lambda 0)
   (let* ([data-layouts (program-data-layouts program)]
 
   (set! cur-lambda 0)
   (let* ([data-layouts (program-data-layouts program)]
 

-        [pattern-matched (program-map-exprs
-                          expand-pattern-matches
-                          program)]
+        [pattern-matched (expand-pattern-matches program)]

         [type-annotated (annotate-types pattern-matched)]
         [stack-annotated (annotate-stack-values data-layouts
                                                 type-annotated)]
         [type-annotated (annotate-types pattern-matched)]
         [stack-annotated (annotate-stack-values data-layouts
                                                 type-annotated)]

diff --git a/tests.scm b/tests.scm
index bcd878a11dfccb8368d930931d5ad00721d8c626..fa5b195e1b2575c4d14f9e385c854aad53dd0823 100644 (file)
--- a/tests.scm
+++ b/tests.scm
@@ -7,7 +7,13 @@
           (format "test failed:\nexpected: ~a\nactual:   ~a"
                   expected actual))))
 
           (format "test failed:\nexpected: ~a\nactual:   ~a"
                   expected actual))))
 

-(define (test . xs) (apply test-f (cons equal? xs)))
+(define-syntax test
+  (syntax-rules ()
+    ((_ a e)
+     (begin
+       (display (quote a))
+       (newline)
+       (test-f equal? a e)))))

 
 (define-syntax test-types
   (syntax-rules ()
 
 (define-syntax test-types
   (syntax-rules ()


@@ -30,7 +36,7 @@
   (display prog)
   (newline)
   (compile-to-binary prog "/tmp/test-prog" host-os)
   (display prog)
   (newline)
   (compile-to-binary prog "/tmp/test-prog" host-os)

-  (test (system "/tmp/test-prog") exit-code))
+  (test-f equal? (system "/tmp/test-prog") exit-code))

 
 (define (test-expr prog exit-code)
   (test-prog (list prog) exit-code))
 
 (define (test-expr prog exit-code)
   (test-prog (list prog) exit-code))


@@ -41,7 +47,24 @@
   (compile-to-binary prog "/tmp/test-prog" host-os)
   (system "/tmp/test-prog > /tmp/test-output.txt")
   (let ((str (read-file "/tmp/test-output.txt")))
   (compile-to-binary prog "/tmp/test-prog" host-os)
   (system "/tmp/test-prog > /tmp/test-output.txt")
   (let ((str (read-file "/tmp/test-output.txt")))

-    (test str output)))
+    (test-f equal? str output)))
+
+(define-syntax test-exception
+  (syntax-rules ()
+    ((_ f)
+     (begin
+       (display (quote f))
+       (newline)
+       (call/cc (lambda (k)
+                 (with-exception-handler
+                  (lambda (x)
+                    (when (eqv? 'no-exception x)
+                      (error #f "test failed: no exception thrown"))
+                    (k))
+                  (lambda ()
+                    (begin
+                      f
+                      (raise 'no-exception))))))))))

 
 (test (data-tors '(A . ((foo Int Bool)
                        (bar Bool))))
 
 (test (data-tors '(A . ((foo Int Bool)
                        (bar Bool))))


@@ -61,11 +84,19 @@
        (bar . (abs Bool A))
        (bar~0 . (abs A Bool))))
 
        (bar . (abs Bool A))
        (bar~0 . (abs A Bool))))
 

-(test (expand-pattern-matches '(let ([(foo x y) (foo 123 234)] [z (f 123)]) x))
-      '(let ([x (foo~0 (foo 123 234))]
+(test (expand-pattern-matches
+       '((data A (foo Int Int))
+        (let ([(foo x y) (foo 123 234)] [z (f 123)]) x)))
+      '((data A (foo Int Int))
+       (let ([x (foo~0 (foo 123 234))]

              [y (foo~1 (foo 123 234))]
              [z (f 123)])
              [y (foo~1 (foo 123 234))]
              [z (f 123)])

-        x))
+         x)))
+
+(test-exception
+ (expand-pattern-matches '((data A (foo Int Int))
+                          (let ([(foo x) (foo 123 234)])
+                            x))))

 
 (test-types (typecheck '((lambda (x) (+ ((lambda (y) (x y 3)) 5) 2))))
            '(abs (abs Int (abs Int Int)) Int))
 
 (test-types (typecheck '((lambda (x) (+ ((lambda (y) (x y 3)) 5) 2))))
            '(abs (abs Int (abs Int Int)) Int))

diff --git a/typecheck.scm b/typecheck.scm
index a526620e7139665fd72273394914462419cb45d0..d180e44e92e755f1e4fbb4172f3535e70f8ebb24 100644 (file)
--- a/typecheck.scm
+++ b/typecheck.scm
@@ -259,7 +259,7 @@
 
                                        ; we typecheck the lambda calculus only (only single arg lambdas)
 (define (typecheck prog)
 
                                        ; we typecheck the lambda calculus only (only single arg lambdas)
 (define (typecheck prog)

-  (let ([expanded (program-map-exprs expand-pattern-matches prog)])
+  (let ([expanded (expand-pattern-matches prog)])

     (cadr (check (init-adts-env expanded) (normalize (program-body expanded))))))
 
 
     (cadr (check (init-adts-env expanded) (normalize (program-body expanded))))))