From f969364176e4846ba6234a6420484bb61b34077b Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Sun, 6 Dec 2009 23:17:37 +0900
Subject: [PATCH] adding initial macroexpand utility

This expands an expression and gives you an sexp representation
of the resulting ast, renaming symbols when there are conflicts.
It doesn't guarantee the minimum number of renames (neither in
terms of renamed bindings nor renamed instances) but tries to be
minimal and does guarantee no renames if there are no conflicts.

This is just for debugging purposes - chibi itself directly
uses the AST without renaming or doing anything like this.
---
 lib/chibi/macroexpand.module |  6 +++
 lib/chibi/macroexpand.scm    | 76 ++++++++++++++++++++++++++++++++++++
 2 files changed, 82 insertions(+)
 create mode 100644 lib/chibi/macroexpand.module
 create mode 100644 lib/chibi/macroexpand.scm

diff --git a/lib/chibi/macroexpand.module b/lib/chibi/macroexpand.module
new file mode 100644
index 00000000..9aac5dbc
--- /dev/null
+++ b/lib/chibi/macroexpand.module
@@ -0,0 +1,6 @@
+
+(define-module (chibi macroexpand)
+  (import (scheme))
+  (import (chibi ast))
+  (export macroexpand)
+  (include "macroexpand.scm"))
diff --git a/lib/chibi/macroexpand.scm b/lib/chibi/macroexpand.scm
new file mode 100644
index 00000000..897d5169
--- /dev/null
+++ b/lib/chibi/macroexpand.scm
@@ -0,0 +1,76 @@
+
+(define (macroexpand x)
+  (ast->sexp (analyze 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 (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))
+           ,(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) (map a2s x))
+       ((opcode? x) (or (opcode-name x) x))
+       (else x)))))
+