[Guile-commits] 19/99: Simplify output Javascript

[Christopher Allan Webber]

cwebber pushed a commit to branch compile-to-js-merge
in repository guile.

commit 46905ec32223938e7ac4380ec9bdea791fce75d1
Author: Ian Price <ianprice90@googlemail.com>
AuthorDate: Sat Jun 13 15:29:13 2015 +0100

    Simplify output Javascript
---
 module/language/javascript/simplify.scm      | 48 ++++++++++++++++++++++++++++
 module/language/js-il/compile-javascript.scm |  5 ++-
 2 files changed, 52 insertions(+), 1 deletion(-)

diff --git a/module/language/javascript/simplify.scm 
b/module/language/javascript/simplify.scm
new file mode 100644
index 0000000..b3360aa
--- /dev/null
+++ b/module/language/javascript/simplify.scm
@@ -0,0 +1,48 @@
+(define-module (language javascript simplify)
+  #:use-module (language javascript)
+  #:use-module (ice-9 match)
+  #:use-module ((srfi srfi-1) #:select (fold-right))
+  #:export (flatten-blocks))
+
+(define (flatten-blocks exp)
+  (define (flatten exp rest)
+    (match exp
+      (($ block statements)
+       (fold-right flatten rest statements))
+      (else
+       (cons (flatten-exp exp) rest))))
+  (define (flatten-block stmts)
+    (fold-right flatten '() stmts))
+  (define (flatten-exp exp)
+    (match exp
+      (($ const c) exp)
+      (($ new exp)
+       (make-new (flatten-exp exp)))
+      (($ return exp)
+       (make-return (flatten-exp exp)))
+      (($ id name) exp)
+      (($ var id exp)
+       (make-var id (flatten-exp exp)))
+      (($ refine id field)
+       (make-refine (flatten-exp id)
+                    (flatten-exp field)))
+      (($ binop op arg1 arg2)
+       (make-binop op
+                   (flatten-exp arg1)
+                   (flatten-exp arg2)))
+      (($ function args body)
+       (make-function args (flatten-block body)))
+      (($ block statements)
+       (maybe-make-block (flatten-block statements)))
+      (($ branch test then else)
+       (make-branch (flatten-exp test)
+                    (flatten-block then)
+                    (flatten-block else)))
+      (($ call function args)
+       (make-call (flatten-exp function)
+                  (map flatten-exp args)))))
+  (define (maybe-make-block exp)
+    (match exp
+      ((exp) exp)
+      (exps (make-block exps))))
+  (maybe-make-block (flatten exp '())))
diff --git a/module/language/js-il/compile-javascript.scm 
b/module/language/js-il/compile-javascript.scm
index 3b13e08..ca7cca5 100644
--- a/module/language/js-il/compile-javascript.scm
+++ b/module/language/js-il/compile-javascript.scm
@@ -3,6 +3,7 @@
   #:use-module (ice-9 match)
   #:use-module ((language js-il) #:renamer (symbol-prefix-proc 'il:))
   #:use-module (language javascript)
+  #:use-module (language javascript simplify)
   #:use-module (language js-il direct)
   #:use-module (system foreign)
   #:export (compile-javascript))
@@ -15,7 +16,9 @@
 
 (define (compile-javascript exp env opts)
   (set! exp (remove-immediate-calls exp))
-  (values (compile-exp exp) env env))
+  (set! exp (compile-exp exp))
+  (set! exp (flatten-blocks exp))
+  (values exp env env))
 
 (define *scheme* (make-id "scheme"))