From 9d44cbd99a90e1a59182174d9d22be0148a4f207 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Wed, 16 Dec 2009 20:15:45 +0900
Subject: [PATCH] adding SRFI-0 cond-expand

---
 Makefile             |  1 +
 TODO                 | 12 ++++++++----
 config.scm           |  9 ++++++---
 eval.c               |  3 +++
 include/chibi/sexp.h |  1 +
 init.scm             | 20 ++++++++++++++++++++
 6 files changed, 39 insertions(+), 7 deletions(-)

diff --git a/Makefile b/Makefile
index 0a892b6f..9ace5e37 100644
--- a/Makefile
+++ b/Makefile
@@ -81,6 +81,7 @@ INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h
 include/chibi/install.h: Makefile
 	echo '#define sexp_so_extension "'$(SO)'"' > $@
 	echo '#define sexp_module_dir "'$(MODDIR)'"' >> $@
+	echo '#define sexp_platform "'$(PLATFORM)'"' >> $@
 
 sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile
 	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
diff --git a/TODO b/TODO
index ee91a9da..57f7c861 100644
--- a/TODO
+++ b/TODO
@@ -79,12 +79,14 @@
    - State "DONE"       [2009-10-13 Tue 14:38]
 ** DONE shared library includes
    - State "DONE"       [2009-12-08 Tue 14:39]
-** TODO only/except/rename/prefix modifiers
+** DONE only/except/rename/prefix modifiers
+   - State "DONE"       [2009-12-16 Wed 18:57]
 ** TODO scheme-complete.el support
 ** TODO access individual modules from repl
 
 * core modules
-** TODO SRFI-0 cond-expand
+** DONE SRFI-0 cond-expand
+   - State "DONE"       [2009-12-16 Wed 20:12]
 ** DONE SRFI-9 define-record-type
    - State "DONE"       [2009-12-08 Tue 14:50]
 ** DONE SRFI-69 hash-tables
@@ -95,8 +97,10 @@
    - State "DONE"       [2009-12-08 Tue 14:54]
 ** TODO network interface
 ** TODO posix interface
-** TODO pathname library
-** TODO uri library
+** DONE pathname library
+   - State "DONE"       [2009-12-16 Wed 18:58]
+** DONE uri library
+   - State "DONE"       [2009-12-16 Wed 18:58]
 ** TODO http library
 ** TODO show (formatting) library
 ** TODO zip library
diff --git a/config.scm b/config.scm
index d71f8180..ebbb8424 100644
--- a/config.scm
+++ b/config.scm
@@ -124,7 +124,7 @@
     mod))
 
 (define-syntax define-module
-  (rsc-macro-transformer
+  (er-macro-transformer
    (lambda (expr env)
      (let ((name (cadr expr))
            (body (cddr expr)))
@@ -141,7 +141,7 @@
           (set! *this-module* tmp))))))
 
 (define-syntax define-config-primitive
-  (rsc-macro-transformer
+  (er-macro-transformer
    (lambda (expr env)
      `(define-syntax ,(cadr expr)
         (er-macro-transformer
@@ -198,5 +198,8 @@
   (set! *modules*
         (list (cons '(scheme) (make-module exports
                                            (interaction-environment)
-                                           (list (cons 'export exports)))))))
+                                           (list (cons 'export exports))))
+              (cons '(srfi 0) (make-module (list 'cond-expand)
+                                           (interaction-environment)
+                                           (list (list 'export 'cond-expand)))))))
 
diff --git a/eval.c b/eval.c
index c638b10e..69517750 100644
--- a/eval.c
+++ b/eval.c
@@ -2373,6 +2373,9 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
                   sexp_c_string(ctx, sexp_module_dir, -1));
   sexp_env_define(ctx, e, sexp_intern(ctx, "*shared-object-extension*"),
                   sexp_c_string(ctx, sexp_so_extension, -1));
+  tmp = sexp_list1(ctx, sym=sexp_intern(ctx, sexp_platform));
+  sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi"));
+  sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp);
   sexp_gc_release4(ctx);
   return e;
 }
diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h
index ab1e2d07..88ae48d9 100644
--- a/include/chibi/sexp.h
+++ b/include/chibi/sexp.h
@@ -674,6 +674,7 @@ enum sexp_context_globals {
 #endif
   SEXP_G_OOM_ERROR,             /* out of memory exception object */
   SEXP_G_OOS_ERROR,             /* out of stack exception object */
+  SEXP_G_OPTIMIZATIONS,
   SEXP_G_QUOTE_SYMBOL,
   SEXP_G_QUASIQUOTE_SYMBOL,
   SEXP_G_UNQUOTE_SYMBOL,
diff --git a/init.scm b/init.scm
index ce2fe440..64e3a05a 100644
--- a/init.scm
+++ b/init.scm
@@ -771,3 +771,23 @@
                            ',(cdr mod+imps))
                          res))
                (error "couldn't find module" (car ls))))))))))
+
+;; SRFI-0
+
+(define-syntax cond-expand
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (check x)
+       (if (pair? x)
+           (case (car x)
+             ((and) (every check (cdr x)))
+             ((or) (any check (cdr x)))
+             ((not) (not (check (cadr x))))
+             (else (error "cond-expand: bad feature" x)))
+           (memq (identifier->symbol x) (cons 'else *features*))))
+     (let expand ((ls (cdr expr)))
+       (cond ((null? ls) (error "cond-expand: no expansions" (cdr expr)))
+             ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls)))
+             ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls)))
+             (else (expand (cdr ls))))))))
+