initial import of cond-expand from @KeenS's patch

include/picrin.h

@@ -76,6 +76,7 @@ typedef struct {
   pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
   pic_sym sDEFINE_SYNTAX, sIMPORT, sEXPORT;
   pic_sym sDEFINE_LIBRARY, sIN_LIBRARY;
+  pic_sym sCOND_EXPAND;
   pic_sym sCONS, sCAR, sCDR, sNILP;
   pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
   pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT;
@@ -83,6 +84,7 @@ typedef struct {
   pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG;
   pic_sym rDEFINE_SYNTAX, rIMPORT, rEXPORT;
   pic_sym rDEFINE_LIBRARY, rIN_LIBRARY;
+  pic_sym rCOND_EXPAND;
 
   struct pic_lib *PICRIN_BASE;
   struct pic_lib *PICRIN_USER;

lib.c

@@ -9,6 +9,7 @@
 #include "picrin/error.h"
 #include "picrin/dict.h"
 #include "picrin/string.h"
+#include "picrin/proc.h"
 
 struct pic_lib *
 pic_open_library(pic_state *pic, pic_value name)
@@ -200,6 +201,109 @@ pic_export(pic_state *pic, pic_sym sym)
   export(pic, pic_sym_value(sym));
 }
 
+bool pic_condexpand_clause(pic_state *, pic_value);
+
+bool
+pic_condexpand_feature(pic_state *pic, pic_value name)
+{
+  pic_value feature;
+
+  pic_for_each(feature, pic->features){
+    if(pic_eq_p(feature, name))
+      return true;
+  }
+  return false;
+}
+
+bool
+pic_condexpand_library(pic_state *pic, pic_value name)
+{
+  pic_debug(pic, name);
+
+  if(pic_find_library(pic, name))
+    return true;
+  else
+    return false;
+}
+
+bool
+pic_condexpand_and(pic_state *pic, pic_value clauses)
+{
+  pic_value clause;
+
+  pic_for_each(clause, clauses){
+    if(!pic_condexpand_clause(pic, clause))
+      return false;
+  }
+  return true;
+}
+
+bool
+pic_condexpand_or(pic_state *pic, pic_value clauses)
+{
+  pic_value clause;
+
+  pic_for_each(clause, clauses){
+    if(pic_condexpand_clause(pic, clause))
+      return true;
+  }
+  return false;
+}
+
+bool
+pic_condexpand_not(pic_state *pic, pic_value clause)
+{
+  return ! pic_condexpand_clause(pic, clause);
+}
+
+bool
+pic_condexpand_clause(pic_state *pic, pic_value clause)
+{
+  const pic_sym sELSE = pic_intern_cstr(pic, "else");
+  const pic_sym sLIBRARY = pic_intern_cstr(pic, "library");
+  const pic_sym sOR = pic_intern_cstr(pic, "or");
+  const pic_sym sAND = pic_intern_cstr(pic, "and");
+  const pic_sym sNOT = pic_intern_cstr(pic, "not");
+
+  if (pic_eq_p(clause, pic_sym_value(sELSE)))
+    return true;
+  else if (pic_sym_p(clause))
+    return pic_condexpand_feature(pic, clause);
+  else if (!pic_pair_p(clause))
+    pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause);
+  else {
+    pic_value car = pic_car(pic, clause);
+    pic_value cdr = pic_cdr(pic, clause);
+    if(pic_eq_p(car, pic_sym_value(sLIBRARY)))
+      return pic_condexpand_library(pic, pic_car(pic, cdr));
+    else if(pic_eq_p(car, pic_sym_value(sAND)))
+      return pic_condexpand_and(pic, cdr);
+    else if(pic_eq_p(car, pic_sym_value(sOR)))
+      return pic_condexpand_or(pic, cdr);
+    else if(pic_eq_p(car, pic_sym_value(sNOT)))
+      return pic_condexpand_not(pic, pic_car(pic, cdr));
+    else
+      pic_errorf(pic, "unknown 'cond-expand' directive ~s", clause);
+    UNREACHABLE();
+    return false;
+  }
+}
+
+static pic_value
+pic_lib_condexpand(pic_state *pic)
+{
+  pic_value *clauses;
+  size_t argc, i;
+
+  pic_get_args(pic, "*", &argc, &clauses);
+
+  for (i = 0; i < argc; i++)
+    if(pic_condexpand_clause(pic, pic_car(pic, clauses[i])))
+      return pic_cons(pic, pic_sym_value(pic->rBEGIN), pic_cdr(pic, clauses[i]));
+
+  return pic_none_value();
+}
+
 static pic_value
 pic_lib_import(pic_state *pic)
 {
@@ -275,6 +379,7 @@ pic_init_lib(pic_state *pic)
 {
   void pic_defmacro(pic_state *, pic_sym, pic_sym, pic_func_t);
 
+  pic_defmacro(pic, pic->sCOND_EXPAND, pic->rCOND_EXPAND, pic_lib_condexpand);
   pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import);
   pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export);
   pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library);

macro.c

@@ -372,6 +372,7 @@ pic_null_syntactic_environment(pic_state *pic)
   pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT);
   pic_define_syntactic_keyword(pic, senv, pic->sEXPORT, pic->rEXPORT);
   pic_define_syntactic_keyword(pic, senv, pic->sIN_LIBRARY, pic->rIN_LIBRARY);
+  pic_define_syntactic_keyword(pic, senv, pic->sCOND_EXPAND, pic->rCOND_EXPAND);
 
   return senv;
 }

state.c

@@ -109,6 +109,7 @@ pic_open(int argc, char *argv[], char **envp)
   register_core_symbol(pic, sEXPORT, "export");
   register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
   register_core_symbol(pic, sIN_LIBRARY, "in-library");
+  register_core_symbol(pic, sCOND_EXPAND, "cond-expand");
   register_core_symbol(pic, sCONS, "cons");
   register_core_symbol(pic, sCAR, "car");
   register_core_symbol(pic, sCDR, "cdr");
@@ -142,6 +143,7 @@ pic_open(int argc, char *argv[], char **envp)
   register_renamed_symbol(pic, rEXPORT, "export");
   register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library");
   register_renamed_symbol(pic, rIN_LIBRARY, "in-library");
+  register_renamed_symbol(pic, rCOND_EXPAND, "cond-expand");
   pic_gc_arena_restore(pic, ai);
 
   /* root block */