From: Luke Lau <luke_lau@icloud.com>
Date: Tue, 6 Aug 2019 15:06:29 +0000 (+0100)
Subject: A bit more work on ADT codegen
X-Git-Url: http://git.lukelau.me/?p=scheme.git;a=commitdiff_plain;h=190fc656a7b4e12e6fcf640c56e6ff71b5a39e40

A bit more work on ADT codegen
---

diff --git a/codegen.scm b/codegen.scm
index 55189cf..b90e7cd 100644
--- a/codegen.scm
+++ b/codegen.scm
@@ -369,7 +369,13 @@
 (define (codegen-data-tor e si env)
 
   (define (codegen-destructor tor)
-    (codegen-expr (cadr e) si env)
+    (when (not (eqv? 'stack (ast-type (cadr e))))
+      (error #f "expected stack value"))
+    (let* ([stack-expr (cadr e)]
+	  [stack-body (caddr stack-expr)]
+	  [stack-type (cadr stack-expr)])
+      
+    (codegen-expr stack-body si env)
     (let ([index (cadr tor)]
 	  [products 2]
 	  [to-traverse (list-head products index)]
@@ -378,9 +384,9 @@
 		   wordsize ; skip tag in first word
 		   to-traverse)])
       3
-      ))
+      )))
   
-  (let ([tor (data-tor env e)]
+  (let* ([tor (data-tor env e)]
 	 [constructor (eqv? 'constructor (cadr tor))])
     (if constructor
 	(codegen-constructor tor)
@@ -423,19 +429,21 @@
     ('static-string (emit "movq ~a@GOTPCREL(%rip), %rax"
 			  (cadr e)))
 
+    ('stack (error #f "stack value that needs explicit handling" e))
+
     (else (error #f "don't know how to codegen this"))))
 
 					; takes in a expr annotated with types and returns a type-less AST
 					; with stack values wrapped
 (define (annotate-stack-values data-layout ann-e)
-  (define (struct-type? type)
+  (define (stack-type? type)
     (assoc type data-layout))
   (define (strip e)
     (ast-traverse strip (ann-expr e)))
   (let* ([e (ann-expr ann-e)]
 	 [type (ann-type ann-e)])
-    (if (struct-type? type)
-	`(struct ,(type-size data-layout type) ,(ast-traverse strip e))
+    (if (stack-type? type)
+	`(stack ,type ,(ast-traverse strip e))
 	(ast-traverse (lambda (x)
 			(annotate-stack-values data-layout x))
 		      e))))
diff --git a/tests.scm b/tests.scm
index 87ed2a6..648ce07 100644
--- a/tests.scm
+++ b/tests.scm
@@ -227,7 +227,7 @@
 
 					; adts and pattern matching
 
-(test-prog '((data (A [foo Int]))
+(test-prog '((data A [foo Int])
 	     (let ([(foo x) (foo 42)])
 	       x))
 	   42)