From 57fb1fc2fe2e084c9694ddedcfab65d2624014d9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 10 Sep 2014 01:48:20 +0900 Subject: [PATCH] initial import of cond-expand from @KeenS's patch --- include/picrin.h | 2 + lib.c | 105 +++++++++++++++++++++++++++++++++++++++++++++++ macro.c | 1 + state.c | 2 + 4 files changed, 110 insertions(+) diff --git a/include/picrin.h b/include/picrin.h index ac03feb6..f752d2cf 100644 --- a/include/picrin.h +++ b/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; diff --git a/lib.c b/lib.c index 898b0b6b..2b2459bb 100644 --- a/lib.c +++ b/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); diff --git a/macro.c b/macro.c index 22d9f331..993cf537 100644 --- a/macro.c +++ b/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; } diff --git a/state.c b/state.c index 07d85892..d0c05e4e 100644 --- a/state.c +++ b/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 */