From: Mike D. Lowis <mike@mdlowis.com>
Date: Mon, 23 Jul 2012 17:10:42 +0000 (-0400)
Subject: Added an AST to Scheme translation layer. We can now convert DLang code to Scheme... 
X-Git-Url: https://git.mdlowis.com/?a=commitdiff_plain;h=8bf946ed8e60ab5f198de3072353e412bec812c0;p=archive%2Fdlang-scm.git

Added an AST to Scheme translation layer. We can now convert DLang code to Scheme code
---

diff --git a/source/main.scm b/source/main.scm
index 2bffe6f..99bd281 100644
--- a/source/main.scm
+++ b/source/main.scm
@@ -1,12 +1,12 @@
-(declare (uses parser))
+(declare (uses lexer parser scheme))
 
 (define (parse-file fname)
-  (define result
-    (dlang/program (dlang/lexer (open-input-file fname))))
-  (print result))
+  (define result (dlang/program (dlang/lexer (open-input-file fname))))
+  (set! result (scheme-program result))
+  result)
 
 ; If we have a file, then parse it
 (if (= 1 (length (command-line-arguments)))
-  (parse-file (car (command-line-arguments)))
+  (map print (parse-file (car (command-line-arguments))))
   (print "No input file provided."))
 
diff --git a/source/scheme.scm b/source/scheme.scm
new file mode 100644
index 0000000..7e0b2a7
--- /dev/null
+++ b/source/scheme.scm
@@ -0,0 +1,77 @@
+(declare (unit scheme) (uses parse-utils))
+
+(define (scheme-program lst)
+  (if (null? lst) '()
+    (append
+      (list (scheme-expression (car lst)))
+      (scheme-program (cdr lst)))))
+
+(define (scheme-expression expr)
+  (define type (syntree-type expr))
+  (cond
+    ((equal? type 'id)        (scheme-id expr))
+    ((equal? type 'character) (scheme-character expr))
+    ((equal? type 'number)    (scheme-number expr))
+    ((equal? type 'symbol)    (scheme-symbol expr))
+    ((equal? type 'string)    (scheme-string expr))
+    ((equal? type 'define)    (scheme-define expr))
+    ((equal? type 'assign)    (scheme-assign expr))
+    ((equal? type 'if)        (scheme-if expr))
+    ((equal? type 'begin)     (scheme-begin expr))
+    ((equal? type 'func)      (scheme-func expr))
+    ((equal? type 'apply)     (scheme-apply expr))
+    (else "unknown")))
+
+(define (scheme-id expr)
+  (syntree-text expr))
+
+(define (scheme-character expr)
+  (string-ref (syntree-text expr) 1))
+
+(define (scheme-number expr)
+  (syntree-text expr))
+
+(define (scheme-symbol expr)
+  (string-append "'" (substring (syntree-text expr) 1)))
+
+(define (scheme-string expr)
+  (syntree-text expr))
+
+(define (scheme-define expr)
+  (string-append
+    "(define "
+    (scheme-expression (list-ref (syntree-children expr) 0))
+    " "
+    (scheme-expression (list-ref (syntree-children expr) 1))
+    ")"))
+
+(define (scheme-assign expr)
+  (string-append
+    "(set! "
+    (scheme-expression (list-ref (syntree-children expr) 0))
+    " "
+    (scheme-expression (list-ref (syntree-children expr) 1))
+    ")"))
+
+(define (scheme-if expr)
+  (append '("if")
+    (map scheme-expression (syntree-children expr))))
+
+(define (scheme-begin expr)
+  (append '("begin")
+    (map scheme-expression (syntree-children expr))))
+
+(define (scheme-func expr)
+  (append '("lambda")
+    (scheme-idlist (car (syntree-children expr)))
+    (scheme-block (cadr (syntree-children expr)))))
+
+(define (scheme-apply expr)
+  (map scheme-expression (syntree-children expr)))
+
+(define (scheme-idlist expr)
+  (list (map scheme-expression (syntree-children expr))))
+
+(define (scheme-block expr)
+  (map scheme-expression (syntree-children expr)))
+