From 51352245b2a7e5ae1cba1121457a0eaf49d9fe27 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Wed, 1 Apr 2009 13:02:49 +0900
Subject: [PATCH] adding more macros

---
 eval.c   |  1 +
 eval.h   |  2 +-
 init.scm | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 70 insertions(+), 1 deletion(-)

diff --git a/eval.c b/eval.c
index 1e3a8654..62dfaa2f 100644
--- a/eval.c
+++ b/eval.c
@@ -358,6 +358,7 @@ static sexp analyze (sexp x, sexp context) {
         x = apply(sexp_macro_proc(op),
                   sexp_list3(x, sexp_context_env(context), sexp_macro_env(op)),
                   context);
+        /* sexp_debug("expand => ", x, context); */
         goto loop;
       } else if (sexp_opcodep(op)) {
         res = analyze_app(sexp_cdr(x), context);
diff --git a/eval.h b/eval.h
index 18a3d6dc..bf1e5375 100644
--- a/eval.h
+++ b/eval.h
@@ -18,7 +18,7 @@
 
 #define sexp_init_file "init.scm"
 
-#define sexp_debug(msg, obj) (sexp_write_string(msg,cur_error_port), sexp_write(obj, cur_error_port), sexp_write_char('\n',cur_error_port))
+#define sexp_debug(msg, obj, ctx) (sexp_write_string(msg,env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)), sexp_write(obj, env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)), sexp_write_char('\n',env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)))
 
 /* procedure types */
 typedef sexp (*sexp_proc0) ();
diff --git a/init.scm b/init.scm
index b80658b1..e3210566 100644
--- a/init.scm
+++ b/init.scm
@@ -208,6 +208,57 @@
                    (cons (rename 'and) (cddr expr))
                    #f))))))
 
+(define-syntax cond
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (null? (cdr expr))
+         #f
+         (let ((cl (cadr expr)))
+           (if (eq? 'else (car cl))
+               (cons (rename 'begin) (cdr cl))
+               (if (if (null? (cdr cl)) #t (eq? '=> (cadr cl)))
+                   (list (rename 'let)
+                         (list (list (rename 'tmp) (car cl)))
+                         (list (rename 'if) (rename 'tmp)
+                               (if (null? (cdr cl))
+                                   (rename 'tmp)
+                                   (list (caddr cl) (rename 'tmp)))))
+                   (list (rename 'if)
+                         (car cl)
+                         (cons (rename 'begin) (cdr cl))
+                         (cons (rename 'cond) (cddr expr))))))))))
+
+(define-syntax quasiquote
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (qq x d)
+       (if (pair? x)
+           (if (eq? 'unquote (car x))
+               (if (<= d 0)
+                   (cadr x)
+                   (list (rename 'unquote) (qq (cadr x) (- d 1))))
+               (if (eq? 'unquote-splicing (car x))
+                   (if (<= d 0)
+                       (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
+                       (list (rename 'unquote-splicing) (qq (cadr x) (- d 1))))
+                   (if (eq? 'quasiquote (car x))
+                       (list (rename 'quasiquote) (qq (cadr x) (+ d 1)))
+                       (if (and (<= d 0)
+                                (pair? (car x))
+                                (eq? 'unquote-splicing (caar x)))
+                           (list (rename 'append)
+                                 (cadar x)
+                                 (qq (cdr x) d))
+                           (list (rename 'cons)
+                                 (qq (car x) d)
+                                 (qq (cdr x) d))))))
+           (if (vector? x)
+               (list (rename 'list->vector) (qq (vector->list x) d))
+               (if (symbol? x)
+                   (list (rename 'quote) x)
+                   x))))
+     (qq (cadr expr) 0))))
+
 ;; char utils
 
 ;; (define (char=? a b) (= (char->integer a) (char->integer b)))
@@ -227,6 +278,23 @@
 ;; (define (char-ci>=? a b)
 ;;   (>= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
 
+;; vector utils
+
+(define (list->vector ls)
+  (let ((vec (make-vector (length ls))))
+    (let lp ((ls ls) (i 0))
+      (if (pair? ls)
+          (begin
+            (vector-set! vec i (car ls))
+            (lp (cdr ls) (+ i 1)))))
+    vec))
+
+(define (vector->list vec)
+  (let lp ((i (- (vector-length vec) 1)) (res '()))
+    (if (< i 0)
+        res
+        (lp (- i 1) (cons (vector-ref vec i) res)))))
+
 ;; math
 
 ;; (define (abs x) (if (< x 0) (- x) x))