From 2d4831a551afbeec0680fa65c6d301853c8a975b Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 14 Aug 2019 16:08:31 +0100 Subject: [PATCH] Start work on case statements --- ast.scm | 11 +++++++++++ tests.scm | 9 +++++++++ 2 files changed, 20 insertions(+) diff --git a/ast.scm b/ast.scm index 52e06bc..86d5225 100644 --- a/ast.scm +++ b/ast.scm @@ -17,6 +17,7 @@ ('if 'if) ('let 'let) ('lambda 'lambda) + ('case 'case) ('closure 'closure) ; only available in codegen ('static-string 'static-string) ; only available in codegen ('stack 'stack) ; only available in codegen (tag that value is passed via stack) @@ -35,6 +36,10 @@ ('app (map f x)) ('lambda `(lambda ,(lambda-args x) ,(f (lambda-body x)))) ('if `(if ,@(map f (cdr x)))) + ('case `(case ,(f (case-expr x)) + ,@(map (lambda (x) + (list (car x) (f (cadr x)))) + (case-cases x)))) ('stack `(stack ,(cadr x) ,(f (caddr x)))) (else x))) @@ -50,6 +55,9 @@ (inner (lambda-body x)))] ['if (append (f x) (flat-map inner (cdr x)))] + ['case (append (f x) + (inner (case-expr x)) + (flat-map inner (map cadr (case-cases x))))] ['stack (append (f x) (inner (caddr x)))] [else (f x)])) @@ -80,6 +88,9 @@ (define let-bindings cadr) (define let-body cddr) +(define case-expr cadr) +(define case-cases cddr) + ; (let ([(foo a b) (foo 123 345)]) a) ; | ; v diff --git a/tests.scm b/tests.scm index b3e630b..49fc2c4 100644 --- a/tests.scm +++ b/tests.scm @@ -278,3 +278,12 @@ (let ([(bar (foo x)) (bar (foo 42))]) x)) 42) + +(test-prog '((data Foo [a] [b] [c]) + (let ([x b]) + (case x + [a 1] + [b 2] + [c 3]))) + 2) + -- 2.30.2