From d0b4fc609a2c9f51a74318bd8c93b15f4a0bbe68 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 2 Aug 2019 16:08:37 +0100 Subject: [PATCH] WIP in let-binding pattern match stuff --- ast.scm | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/ast.scm b/ast.scm index 469a96f..23e7723 100644 --- a/ast.scm +++ b/ast.scm @@ -71,8 +71,16 @@ [else (p x)])) (define (let-bindings e) - (define (extract x) ) ; TODO - (flat-map extract (cadr e)) + (define (pattern-match x body) + (if (eqv? (ast-type x) 'var) + (cons x body) + (let* ([constructor (car x)] + [destructor (lambda (i) `(destruct ,i ,constructor))]) + (flat-map (lambda (y i) + (pattern-match y (list (destructor i) body))) + (cdr x) + (range 0 (length (cdr x))))))) + (flat-map (lambda (x) (pattern-match (car x) (cdr x))) (cadr e))) (define let-body cddr) (define (lambda? x) @@ -107,7 +115,12 @@ (define lambda-body caddr) ; utils -(define (flat-map f x) (fold-left append '() (map f x))) +(define (range s n) + (if (= 0 n) '() + (append (range s (- n 1)) + (list (+ s (- n 1)))))) + +(define (flat-map f . xs) (fold-left append '() (map f xs))) (define (repeat x n) (if (<= n 0) '() (cons x (repeat x (- n 1))))) -- 2.30.2