From 8d1ed6da27d7ce2b9a671381e890b88966611859 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Sun, 25 Jul 2010 21:27:39 +0900
Subject: [PATCH] adding ast.scm where ast->sexp was moved

---
 lib/chibi/ast.scm | 91 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 91 insertions(+)
 create mode 100644 lib/chibi/ast.scm

diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm
new file mode 100644
index 00000000..020f257a
--- /dev/null
+++ b/lib/chibi/ast.scm
@@ -0,0 +1,91 @@
+;; ast.scm -- ast utilities
+;; Copyright (c) 2010 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (macroexpand x)
+  (ast->sexp (analyze x)))
+
+(define (procedure-name x)
+  (bytecode-name (procedure-code x)))
+
+(define (ast-renames ast)
+  (define i 0)
+  (define renames '())
+  (define (rename-symbol id)
+    (set! i (+ i 1))
+    (string->symbol
+     (string-append (symbol->string (identifier->symbol id))
+                    "." (number->string i))))
+  (define (rename-lambda lam)
+    (or (assq lam renames)
+        (let ((res (list lam)))
+          (set! renames (cons res renames))
+          res)))
+  (define (rename! id lam)
+    (let ((cell (rename-lambda lam)))
+      (set-cdr! cell (cons (cons id (rename-symbol id)) (cdr cell)))))
+  (define (check-ref id lam env)
+    (let ((sym (identifier->symbol id)))
+      (let lp1 ((ls env))
+        (cond
+         ((pair? ls)
+          (let lp2 ((ls2 (car ls)) (found? #f))
+            (cond
+             ((null? ls2)
+              (if (not found?) (lp1 (cdr ls))))
+             ((and (eq? id (caar ls2)) (eq? lam (cdar ls2)))
+               (lp2 (cdr ls2) #t))
+             ((eq? sym (identifier->symbol (caar ls2)))
+              (rename! (caar ls2) (cdar ls2))
+              (lp2 (cdr ls2) found?))
+             (else
+              (lp2 (cdr ls2) found?)))))))))
+  (define (flatten-dot x)
+    (cond ((pair? x) (cons (car x) (flatten-dot (cdr x))))
+          ((null? x) x)
+          (else (list x))))
+  (define (extend-env lam env)
+    (cons (map (lambda (x) (cons x lam)) (flatten-dot (lambda-params lam))) env))
+  (let lp ((x ast) (env '()))
+    (cond
+     ((lambda? x) (lp (lambda-body x) (extend-env x env)))
+     ((ref? x) (check-ref (ref-name x) (cdr (ref-cell x)) env))
+     ((cnd? x) (lp (cnd-test x) env) (lp (cnd-pass x) env) (lp (cnd-fail x) env))
+     ((set? x) (lp (set-var x) env) (lp (set-value x) env))
+     ((seq? x) (for-each (lambda (x) (lp x env)) (seq-ls x)))
+     ((pair? x) (for-each (lambda (x) (lp x env)) x))))
+  renames)
+
+(define (get-rename id lam renames)
+  (let ((ls (assq lam renames)))
+    (if (not ls)
+        (identifier->symbol id)
+        (cond ((assq id (cdr ls)) => cdr) (else (identifier->symbol id))))))
+
+(define (map* f ls)
+  (cond ((pair? ls) (cons (f (car ls)) (map* f (cdr ls))))
+        ((null? ls) '())
+        (else (f ls))))
+
+(define (ast->sexp ast)
+  (let ((renames (ast-renames ast)))
+    (let a2s ((x ast))
+      (cond
+       ((lambda? x)
+        `(lambda ,(map* (lambda (id) (get-rename id x renames)) (lambda-params x))
+           ,@(map (lambda (d) `(define ,(identifier->symbol (caar d)) #f))
+                  (lambda-defs x))
+           ,@(if (seq? (lambda-body x))
+                 (map a2s (seq-ls (lambda-body x)))
+                 (list (a2s (lambda-body x))))))
+       ((cnd? x) `(if ,(a2s (cnd-test x)) ,(a2s (cnd-pass x)) ,(a2s (cnd-fail x))))
+       ((set? x) `(set! ,(a2s (set-var x)) ,(a2s (set-value x))))
+       ((ref? x) (get-rename (ref-name x) (cdr (ref-cell x)) renames))
+       ((seq? x) `(begin ,@(map a2s (seq-ls x))))
+       ((lit? x)
+        (let ((v (lit-value x)))
+          (if (or (pair? v) (null? v) (symbol? v)) `',v v)))
+       ((pair? x) (cons (a2s (car x)) (a2s (cdr x))))
+       ((opcode? x) (or (opcode-name x) x))
+       (else x)))))
+