Fix bindings in ADT pattern matching codegen

[scheme.git] / codegen.scm

diff --git a/codegen.scm b/codegen.scm
index a70ef6c899f2d4c3d4c656bbf9676ca91dab08c5..6203cfdef4f02d367c512517298ca890ce75f384 100644 (file)
--- a/codegen.scm
+++ b/codegen.scm
@@ -69,6 +69,9 @@
 (define make-env list)
 (define env-data-layouts car)
 (define env-bindings cadr)
+(define (env-append-bindings env bindings)
+  (make-env (env-data-layouts env)
+           (append bindings (env-bindings env))))
 
 (define (codegen-add xs si env)
   (define (go ys)
@@ -444,18 +447,32 @@
                                        ; checks if equal and returns assoc list of bindings
   (define (check-equal jne-label type inner-offset x)
 
+                                       ; TODO: tidy this up! comparibles and binds could be merged
                                        ; (foo a 2 (bar x)) -> ((2 Int 1) ((bar x) A 2))
                                        ; sum: foo
     (define (comparibles sum)
-      (if (not (list? sum))
-         '()
       (let ([product-types (cdr (assoc sum (cdr (assoc type dls))))])
+       (if (null? product-types)
+           '()
            (filter (lambda (x) (not (eqv? 'var (ast-type (car x)))))
                    (map (lambda (x t i) (list x t i))
                         (cdr x)
                         product-types
                         (range 0 (length product-types)))))))
     
+    (define (binds sum)
+      (let ([product-types (cdr (assoc sum (cdr (assoc type dls))))])
+       (if (null? product-types)
+           '()
+           (filter (lambda (x) (eqv? 'var (ast-type (car x))))
+                   (map (lambda (x i)
+                          (cons x
+                                (- inner-offset
+                                   (data-product-offset dls type sum i))))
+                        (cdr x)
+                        (range 0 (length (cdr x))))))))
+            
+
     (let ([sums (assoc type dls)])
       (if sums
          (let* ([sum (if (list? x) (car x) x)] ; can sometimes be a singleton
@@ -463,13 +480,15 @@
                                        ; the tag is at the top (beginning) of the adt on the stack
            (emit "cmpq $~a, ~a(%rbp)" tag inner-offset)
            (emit "jne ~a" jne-label)
+
+           (append (binds sum)
             (flat-map
-            (lambda (cmpx cmpt cmpi)
+            (lambda (cmp) ; cmp = (x type index)
               (check-equal jne-label
-                           cmpt
-                           (- inner-offset (data-product-offset dls type sum i))
-                           cmpx))
-            (comparibles sum)))
+                           (cadr cmp)
+                           (- inner-offset (data-product-offset dls type sum (caddr cmp)))
+                           (car cmp)))
+            (comparibles sum))))
          (if (eqv? 'var (ast-type x))
              (list (cons x inner-offset))
              (begin
@@ -482,8 +501,9 @@
           [expr (cadr case)]
           [next-section-label (fresh-label)]
           [inner-si (- si (type-size dls type))]
-          [new-env (append (check-equal next-section-label type si match)
-                           env)])
+          [new-env (env-append-bindings env
+                    (check-equal next-section-label type si match))])
+
 
       (codegen-expr expr inner-si new-env)
       (emit "jmp ~a" exit-label)