commit ab84d89ac7a78deefdab8783badaf24e10327ab6
parent 725ec0f963b78bf56c86d7d12b351855faaa7100
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 5 Jun 2011 01:50:11 -0300
Split the kground.c init code file between all the kg*.c files, for better incremental compiling.
Diffstat:
41 files changed, 964 insertions(+), 1165 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -114,12 +114,13 @@ keval.o: keval.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h kerror.h
kgbooleans.o: kgbooleans.c kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kpair.h kgc.h ksymbol.h kstring.h \
- kcontinuation.h kerror.h kghelpers.h kapplicative.h koperative.h
+ kcontinuation.h kerror.h kghelpers.h kapplicative.h koperative.h \
+ kenvironment.h
kgc.o: kgc.c kgc.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kport.h imath.h imrat.h ktable.h kstring.h kerror.h
kgchars.o: kgchars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
- kghelpers.h kpair.h kgc.h kgchars.h
+ kghelpers.h kpair.h kgc.h kenvironment.h ksymbol.h kstring.h kgchars.h
kgcombiners.o: kgcombiners.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h \
ksymbol.h kstring.h koperative.h kapplicative.h kerror.h kghelpers.h \
@@ -130,11 +131,12 @@ kgcontinuations.o: kgcontinuations.c kstate.h klimits.h klisp.h kobject.h \
kgcontinuations.h kgcontrol.h
kgcontrol.o: kgcontrol.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h kerror.h kghelpers.h \
- kapplicative.h koperative.h kgcontrol.h kgcombiners.h
+ kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h \
+ kgcontrol.h kgcombiners.h
kgencapsulations.o: kgencapsulations.c kstate.h klimits.h klisp.h \
kobject.h klispconf.h ktoken.h kmem.h kencapsulation.h kapplicative.h \
koperative.h kerror.h kghelpers.h kpair.h kgc.h kcontinuation.h \
- kgencapsulations.h
+ kenvironment.h ksymbol.h kstring.h kgencapsulations.h
kgenv_mut.o: kgenv_mut.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h ksymbol.h \
kstring.h kerror.h kghelpers.h kapplicative.h koperative.h kgenv_mut.h \
@@ -145,30 +147,32 @@ kgenvironments.o: kgenvironments.c kstate.h klimits.h klisp.h kobject.h \
kgenvironments.h kgenv_mut.h kgpair_mut.h kgcontrol.h
kgeqp.o: kgeqp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h kerror.h kghelpers.h \
- kapplicative.h koperative.h kgeqp.h kinteger.h imath.h krational.h \
- imrat.h
+ kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h kgeqp.h \
+ kinteger.h imath.h krational.h imrat.h
kgequalp.o: kgequalp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kground.h kpair.h kgc.h kstring.h kcontinuation.h \
- kerror.h kghelpers.h kapplicative.h koperative.h kgeqp.h kinteger.h \
- imath.h krational.h imrat.h kgequalp.h
+ ktoken.h kmem.h kpair.h kgc.h kstring.h kcontinuation.h kerror.h \
+ kghelpers.h kapplicative.h koperative.h kenvironment.h ksymbol.h kgeqp.h \
+ kinteger.h imath.h krational.h imrat.h kgequalp.h
kghelpers.o: kghelpers.c kghelpers.h kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kerror.h kpair.h kgc.h kapplicative.h \
- koperative.h kcontinuation.h ksymbol.h kstring.h
+ koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h
kgkd_vars.o: kgkd_vars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h koperative.h \
- kapplicative.h kenvironment.h kerror.h kghelpers.h kgcontinuations.h \
- kgkd_vars.h
+ kapplicative.h kenvironment.h kerror.h kghelpers.h ksymbol.h kstring.h \
+ kgcontinuations.h kgkd_vars.h
kgks_vars.o: kgks_vars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h koperative.h \
- kapplicative.h kenvironment.h kerror.h kghelpers.h kgks_vars.h
+ kapplicative.h kenvironment.h kerror.h kghelpers.h ksymbol.h kstring.h \
+ kgks_vars.h
kgnumbers.o: kgnumbers.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
ksymbol.h kstring.h kinteger.h imath.h krational.h imrat.h kreal.h \
- kghelpers.h kpair.h kgc.h kgnumbers.h kgkd_vars.h
+ kghelpers.h kpair.h kgc.h kenvironment.h kgnumbers.h kgkd_vars.h
kgpair_mut.o: kgpair_mut.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kcontinuation.h ksymbol.h \
- kstring.h kerror.h kghelpers.h kapplicative.h koperative.h kgpair_mut.h \
- kgeqp.h kinteger.h imath.h krational.h imrat.h kgnumbers.h
+ kstring.h kerror.h kghelpers.h kapplicative.h koperative.h \
+ kenvironment.h kgpair_mut.h kgeqp.h kinteger.h imath.h krational.h \
+ imrat.h kgnumbers.h
kgpairs_lists.o: kgpairs_lists.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kstring.h kcontinuation.h \
kenvironment.h ksymbol.h kerror.h kghelpers.h kapplicative.h \
@@ -179,22 +183,24 @@ kgports.o: kgports.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kwrite.h kghelpers.h kgports.h kgcontinuations.h kgcontrol.h kgkd_vars.h
kgpromises.o: kgpromises.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpromise.h kpair.h kgc.h kapplicative.h \
- koperative.h kcontinuation.h kerror.h kghelpers.h kgpromises.h
+ koperative.h kcontinuation.h kerror.h kghelpers.h kenvironment.h \
+ ksymbol.h kstring.h kgpromises.h
kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kground.h kenvironment.h ksymbol.h kstring.h \
- koperative.h kapplicative.h kerror.h kghelpers.h kpair.h kgc.h \
- kcontinuation.h kgbooleans.h kgeqp.h kinteger.h imath.h krational.h \
- imrat.h kgequalp.h kgsymbols.h kgcontrol.h kgpairs_lists.h kgpair_mut.h \
+ ktoken.h kmem.h kground.h kghelpers.h kerror.h kpair.h kgc.h \
+ kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
+ kstring.h kgbooleans.h kgeqp.h kinteger.h imath.h krational.h imrat.h \
+ kgequalp.h kgsymbols.h kgcontrol.h kgpairs_lists.h kgpair_mut.h \
kgenvironments.h kgenv_mut.h kgcombiners.h kgcontinuations.h \
kgencapsulations.h kgpromises.h kgkd_vars.h kgks_vars.h kgnumbers.h \
kgstrings.h kgchars.h kgports.h ktable.h keval.h krepl.h
kgstrings.o: kgstrings.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
- ksymbol.h kstring.h kghelpers.h kpair.h kgc.h kgchars.h kgstrings.h \
- kgnumbers.h
+ ksymbol.h kstring.h kghelpers.h kpair.h kgc.h kenvironment.h kgchars.h \
+ kgstrings.h kgnumbers.h
kgsymbols.o: kgsymbols.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kcontinuation.h kpair.h kgc.h kstring.h ksymbol.h \
- kerror.h kghelpers.h kapplicative.h koperative.h kgsymbols.h
+ kerror.h kghelpers.h kapplicative.h koperative.h kenvironment.h \
+ kgsymbols.h
kinteger.o: kinteger.c kinteger.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h imath.h kgc.h
klisp.o: klisp.c klimits.h klisp.h kobject.h klispconf.h kstate.h \
@@ -231,7 +237,7 @@ ksymbol.o: ksymbol.c ksymbol.h kobject.h klimits.h klisp.h klispconf.h \
ktable.o: ktable.c klisp.h kobject.h klimits.h klispconf.h kgc.h kstate.h \
ktoken.h kmem.h ktable.h kapplicative.h koperative.h kgeqp.h kinteger.h \
imath.h krational.h imrat.h kghelpers.h kerror.h kpair.h kcontinuation.h \
- kstring.h
+ kenvironment.h ksymbol.h kstring.h
ktoken.o: ktoken.c ktoken.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h kmem.h kinteger.h imath.h krational.h imrat.h kreal.h kpair.h \
kgc.h kstring.h ksymbol.h kerror.h kport.h
diff --git a/src/kgbooleans.c b/src/kgbooleans.c
@@ -168,3 +168,24 @@ void Sandp_Sorp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* 6.1.5 $or? */
/* uses Sandp_Sorp */
+
+/* init ground */
+void kinit_booleans_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 4.1.1 boolean? */
+ add_applicative(K, ground_env, "boolean?", typep, 2, symbol,
+ i2tv(K_TBOOLEAN));
+ /* 6.1.1 not? */
+ add_applicative(K, ground_env, "not?", notp, 0);
+ /* 6.1.2 and? */
+ add_applicative(K, ground_env, "and?", andp, 0);
+ /* 6.1.3 or? */
+ add_applicative(K, ground_env, "or?", orp, 0);
+ /* 6.1.4 $and? */
+ add_operative(K, ground_env, "$and?", Sandp_Sorp, 2, symbol, KFALSE);
+ /* 6.1.5 $or? */
+ add_operative(K, ground_env, "$or?", Sandp_Sorp, 2, symbol, KTRUE);
+}
diff --git a/src/kgbooleans.h b/src/kgbooleans.h
@@ -43,4 +43,7 @@ void Sandp_Sorp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* Helper */
bool kbooleanp(TValue obj);
+/* init ground */
+void kinit_booleans_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgchars.c b/src/kgchars.c
@@ -127,3 +127,66 @@ bool kchar_ci_gtp(TValue ch1, TValue ch2)
bool kchar_ci_gep(TValue ch1, TValue ch2)
{ return tolower(chvalue(ch1)) >= tolower(chvalue(ch2)); }
+/* init ground */
+void kinit_chars_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /*
+ ** This section is still missing from the report. The bindings here are
+ ** taken from r5rs scheme and should not be considered standard. They are
+ ** provided in the meantime to allow programs to use character features
+ ** (ASCII only).
+ */
+
+ /* 14.1.1? char? */
+ add_applicative(K, ground_env, "char?", typep, 2, symbol,
+ i2tv(K_TCHAR));
+ /* 14.1.2? char-alphabetic?, char-numeric?, char-whitespace? */
+ /* unlike in r5rs these take an arbitrary number of chars
+ (even cyclical list) */
+ add_applicative(K, ground_env, "char-alphabetic?", ftyped_predp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_alphabeticp));
+ add_applicative(K, ground_env, "char-numeric?", ftyped_predp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_numericp));
+ add_applicative(K, ground_env, "char-whitespace?", ftyped_predp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_whitespacep));
+ /* 14.1.3? char-upper-case?, char-lower-case? */
+ /* unlike in r5rs these take an arbitrary number of chars
+ (even cyclical list) */
+ add_applicative(K, ground_env, "char-upper-case?", ftyped_predp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_upper_casep));
+ add_applicative(K, ground_env, "char-lower-case?", ftyped_predp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_lower_casep));
+ /* 14.1.4? char->integer, integer->char */
+ add_applicative(K, ground_env, "char->integer", kchar_to_integer, 0);
+ add_applicative(K, ground_env, "integer->char", kinteger_to_char, 0);
+ /* 14.1.4? char-upcase, char-downcase */
+ add_applicative(K, ground_env, "char-upcase", kchar_upcase, 0);
+ add_applicative(K, ground_env, "char-downcase", kchar_downcase, 0);
+ /* 14.2.1? char=? */
+ add_applicative(K, ground_env, "char=?", ftyped_bpredp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_eqp));
+ /* 14.2.2? char<?, char<=?, char>?, char>=? */
+ add_applicative(K, ground_env, "char<?", ftyped_bpredp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_ltp));
+ add_applicative(K, ground_env, "char<=?", ftyped_bpredp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_lep));
+ add_applicative(K, ground_env, "char>?", ftyped_bpredp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_gtp));
+ add_applicative(K, ground_env, "char>=?", ftyped_bpredp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_gep));
+ /* 14.2.3? char-ci=? */
+ add_applicative(K, ground_env, "char-ci=?", ftyped_bpredp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_ci_eqp));
+ /* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */
+ add_applicative(K, ground_env, "char-ci<?", ftyped_bpredp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_ci_ltp));
+ add_applicative(K, ground_env, "char-ci<=?", ftyped_bpredp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_ci_lep));
+ add_applicative(K, ground_env, "char-ci>?", ftyped_bpredp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_ci_gtp));
+ add_applicative(K, ground_env, "char-ci>=?", ftyped_bpredp, 3,
+ symbol, p2tv(kcharp), p2tv(kchar_ci_gep));
+}
diff --git a/src/kgchars.h b/src/kgchars.h
@@ -76,4 +76,7 @@ bool kchar_ci_lep(TValue ch1, TValue ch2);
bool kchar_ci_gtp(TValue ch1, TValue ch2);
bool kchar_ci_gep(TValue ch1, TValue ch2);
+/* init ground */
+void kinit_chars_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -601,3 +601,33 @@ void map(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* Helper for combiner? */
bool kcombinerp(TValue obj) { return ttiscombiner(obj); }
+
+/* init ground */
+void kinit_combiners_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 4.10.1 operative? */
+ add_applicative(K, ground_env, "operative?", typep, 2, symbol,
+ i2tv(K_TOPERATIVE));
+ /* 4.10.2 applicative? */
+ add_applicative(K, ground_env, "applicative?", typep, 2, symbol,
+ i2tv(K_TAPPLICATIVE));
+ /* 4.10.3 $vau */
+ /* 5.3.1 $vau */
+ add_operative(K, ground_env, "$vau", Svau, 0);
+ /* 4.10.4 wrap */
+ add_applicative(K, ground_env, "wrap", wrap, 0);
+ /* 4.10.5 unwrap */
+ add_applicative(K, ground_env, "unwrap", unwrap, 0);
+ /* 5.3.2 $lambda */
+ add_operative(K, ground_env, "$lambda", Slambda, 0);
+ /* 5.5.1 apply */
+ add_applicative(K, ground_env, "apply", apply, 0);
+ /* 5.9.1 map */
+ add_applicative(K, ground_env, "map", map, 0);
+ /* 6.2.1 combiner? */
+ add_applicative(K, ground_env, "combiner?", ftypep, 2, symbol,
+ p2tv(kcombinerp));
+}
diff --git a/src/kgcombiners.h b/src/kgcombiners.h
@@ -84,4 +84,7 @@ void do_map_encycle(klisp_State *K, TValue *xparams, TValue obj);
void do_map(klisp_State *K, TValue *xparams, TValue obj);
void do_map_cycle(klisp_State *K, TValue *xparams, TValue obj);
+/* init ground */
+void kinit_combiners_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -24,7 +24,6 @@
#include "kgcontinuations.h"
#include "kgcontrol.h" /* for seq helpers in $let/cc */
-
/* 7.1.1 continuation? */
/* uses typep */
@@ -321,3 +320,43 @@ void kgexit(klisp_State *K, TValue *xparams, TValue ptree,
/* should be probably handled in kcall_cont() */
kcall_cont(K, K->root_cont, KINERT);
}
+
+/* init ground */
+void kinit_continuations_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 7.1.1 continuation? */
+ add_applicative(K, ground_env, "continuation?", typep, 2, symbol,
+ i2tv(K_TCONTINUATION));
+ /* 7.2.2 call/cc */
+ add_applicative(K, ground_env, "call/cc", call_cc, 0);
+ /* 7.2.3 extend-continuation */
+ add_applicative(K, ground_env, "extend-continuation", extend_continuation,
+ 0);
+ /* 7.2.4 guard-continuation */
+ add_applicative(K, ground_env, "guard-continuation", guard_continuation,
+ 0);
+ /* 7.2.5 continuation->applicative */
+ add_applicative(K, ground_env, "continuation->applicative",
+ continuation_applicative, 0);
+ /* 7.2.6 root-continuation */
+ add_value(K, ground_env, "root-continuation",
+ K->root_cont);
+ /* 7.2.7 error-continuation */
+ add_value(K, ground_env, "error-continuation",
+ K->root_cont);
+ /* 7.3.1 apply-continuation */
+ add_applicative(K, ground_env, "apply-continuation", apply_continuation,
+ 0);
+ /* 7.3.2 $let/cc */
+ add_operative(K, ground_env, "$let/cc", Slet_cc,
+ 0);
+ /* 7.3.3 guard-dynamic-extent */
+ add_applicative(K, ground_env, "guard-dynamic-extent",
+ guard_dynamic_extent, 0);
+ /* 7.3.4 exit */
+ add_applicative(K, ground_env, "exit", kgexit,
+ 0);
+}
diff --git a/src/kgcontinuations.h b/src/kgcontinuations.h
@@ -64,4 +64,7 @@ void kgexit(klisp_State *K, TValue *xparams, TValue ptree,
void do_extended_cont(klisp_State *K, TValue *xparams, TValue obj);
void do_pass_value(klisp_State *K, TValue *xparams, TValue obj);
+/* init ground */
+void kinit_continuations_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -366,3 +366,22 @@ void for_each(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* this will be a nop */
kapply_cc(K, KINERT);
}
+
+/* init ground */
+void kinit_control_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 4.5.1 inert? */
+ add_applicative(K, ground_env, "inert?", typep, 2, symbol,
+ i2tv(K_TINERT));
+ /* 4.5.2 $if */
+ add_operative(K, ground_env, "$if", Sif, 0);
+ /* 5.1.1 $sequence */
+ add_operative(K, ground_env, "$sequence", Ssequence, 0);
+ /* 5.6.1 $cond */
+ add_operative(K, ground_env, "$cond", Scond, 0);
+ /* 6.9.1 for-each */
+ add_applicative(K, ground_env, "for-each", for_each, 0);
+}
diff --git a/src/kgcontrol.h b/src/kgcontrol.h
@@ -44,4 +44,7 @@ void do_cond(klisp_State *K, TValue *xparams, TValue obj);
void do_select_clause(klisp_State *K, TValue *xparams, TValue obj);
void do_for_each(klisp_State *K, TValue *xparams, TValue obj);
+/* init ground */
+void kinit_control_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgencapsulations.c b/src/kgencapsulations.c
@@ -111,3 +111,14 @@ void make_encapsulation_type(klisp_State *K, TValue *xparams, TValue ptree,
krooted_tvs_pop(K);
kapply_cc(K, ls);
}
+
+/* init ground */
+void kinit_encapsulations_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 8.1.1 make-encapsulation-type */
+ add_applicative(K, ground_env, "make-encapsulation-type",
+ make_encapsulation_type, 0);
+}
diff --git a/src/kgencapsulations.h b/src/kgencapsulations.h
@@ -22,4 +22,7 @@
void make_encapsulation_type(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv);
+/* init ground */
+void kinit_encapsulations_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgenv_mut.c b/src/kgenv_mut.c
@@ -287,3 +287,19 @@ void SimportB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
krooted_tvs_pop(K);
ktail_eval(K, env_expr, denv);
}
+
+/* init ground */
+void kinit_env_mut_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 4.9.1 $define! */
+ add_operative(K, ground_env, "$define!", SdefineB, 1, symbol);
+ /* 6.8.1 $set! */
+ add_operative(K, ground_env, "$set!", SsetB, 1, symbol);
+ /* 6.8.2 $provide! */
+ add_operative(K, ground_env, "$provide!", SprovideB, 1, symbol);
+ /* 6.8.3 $import! */
+ add_operative(K, ground_env, "$import!", SimportB, 1, symbol);
+}
diff --git a/src/kgenv_mut.h b/src/kgenv_mut.h
@@ -250,4 +250,7 @@ void SprovideB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* 6.8.3 $import! */
void SimportB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+/* init ground */
+void kinit_env_mut_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -625,3 +625,46 @@ void Sbindings_to_environment(klisp_State *K, TValue *xparams, TValue ptree,
ktail_eval(K, expr, denv);
}
+
+/* init ground */
+void kinit_environments_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 4.8.1 environment? */
+ add_applicative(K, ground_env, "environment?", typep, 2, symbol,
+ i2tv(K_TENVIRONMENT));
+ /* 4.8.2 ignore? */
+ add_applicative(K, ground_env, "ignore?", typep, 2, symbol,
+ i2tv(K_TIGNORE));
+ /* 4.8.3 eval */
+ add_applicative(K, ground_env, "eval", eval, 0);
+ /* 4.8.4 make-environment */
+ add_applicative(K, ground_env, "make-environment", make_environment, 0);
+ /* 5.10.1 $let */
+ add_operative(K, ground_env, "$let", Slet, 1, symbol);
+ /* 6.7.1 $binds? */
+ add_operative(K, ground_env, "$binds?", Sbindsp, 0);
+ /* 6.7.2 get-current-environment */
+ add_applicative(K, ground_env, "get-current-environment",
+ get_current_environment, 0);
+ /* 6.7.3 make-kernel-standard-environment */
+ add_applicative(K, ground_env, "make-kernel-standard-environment",
+ make_kernel_standard_environment, 0);
+ /* 6.7.4 $let* */
+ add_operative(K, ground_env, "$let*", SletS, 1, symbol);
+ /* 6.7.5 $letrec */
+ add_operative(K, ground_env, "$letrec", Sletrec, 1, symbol);
+ /* 6.7.6 $letrec* */
+ add_operative(K, ground_env, "$letrec*", SletrecS, 1, symbol);
+ /* 6.7.7 $let-redirect */
+ add_operative(K, ground_env, "$let-redirect", Slet_redirect, 1, symbol);
+ /* 6.7.8 $let-safe */
+ add_operative(K, ground_env, "$let-safe", Slet_safe, 1, symbol);
+ /* 6.7.9 $remote-eval */
+ add_operative(K, ground_env, "$remote-eval", Sremote_eval, 0);
+ /* 6.7.10 $bindings->environment */
+ add_operative(K, ground_env, "$bindings->environment",
+ Sbindings_to_environment, 1, symbol);
+}
diff --git a/src/kgenvironments.h b/src/kgenvironments.h
@@ -85,4 +85,7 @@ void Sbindings_to_environment(klisp_State *K, TValue *xparams, TValue ptree,
void do_let(klisp_State *K, TValue *xparams, TValue obj);
+/* init ground */
+void kinit_environments_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgeqp.c b/src/kgeqp.c
@@ -48,3 +48,13 @@ void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, res);
}
+
+/* init ground */
+void kinit_eqp_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+ /* 4.2.1 eq? */
+ /* 6.5.1 eq? */
+ add_applicative(K, ground_env, "eq?", eqp, 0);
+}
diff --git a/src/kgeqp.h b/src/kgeqp.h
@@ -59,4 +59,7 @@ inline bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
return res;
}
+/* init ground */
+void kinit_eqp_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -12,7 +12,6 @@
#include "kstate.h"
#include "kobject.h"
-#include "kground.h"
#include "kpair.h"
#include "kstring.h" /* for kstring_equalp */
#include "kcontinuation.h"
@@ -212,3 +211,14 @@ bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
return result;
}
+
+
+/* init ground */
+void kinit_equalp_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+ /* 4.3.1 equal? */
+ /* 6.6.1 equal? */
+ add_applicative(K, ground_env, "equal?", equalp, 0);
+}
diff --git a/src/kgequalp.h b/src/kgequalp.h
@@ -26,4 +26,7 @@ void equalp(klisp_State *K, TValue *xparas, TValue ptree, TValue denv);
/* compare two objects and check to see if they are "equal?". */
bool equal2p(klisp_State *K, TValue obj1, TValue obj2);
+/* init ground */
+void kinit_equalp_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -21,6 +21,8 @@
#include "kapplicative.h"
#include "koperative.h"
#include "kcontinuation.h"
+#include "kenvironment.h"
+#include "ksymbol.h"
/* to use in type checking binds when no check is needed */
#define anytype(obj_) (true)
@@ -426,4 +428,53 @@ inline int32_t kcheck32(klisp_State *K, char *msg, int64_t i)
int64_t kgcd32_64(int32_t a, int32_t b);
int64_t klcm32_64(int32_t a, int32_t b);
+
+/*
+** Macros for ground environment initialization
+*/
+
+/*
+** BEWARE: this is highly unhygienic, it assumes variables "symbol" and
+** "value", both of type TValue. symbol will be bound to a symbol named by
+** "n_" and can be referrenced in the var_args
+** GC: All of these should be called when GC is deactivated on startup
+*/
+
+/* TODO add si to the symbols */
+#if KTRACK_SI
+#define add_operative(K_, env_, n_, fn_, ...) \
+ { symbol = ksymbol_new(K_, n_, KNIL); \
+ value = kmake_operative(K_, fn_, __VA_ARGS__); \
+ TValue str = kstring_new_b_imm(K_, __FILE__); \
+ TValue si = kcons(K, str, kcons(K_, i2tv(__LINE__), \
+ i2tv(0))); \
+ kset_source_info(K_, value, si); \
+ kadd_binding(K_, env_, symbol, value); }
+
+#define add_applicative(K_, env_, n_, fn_, ...) \
+ { symbol = ksymbol_new(K_, n_, KNIL); \
+ value = kmake_applicative(K_, fn_, __VA_ARGS__); \
+ TValue str = kstring_new_b_imm(K_, __FILE__); \
+ TValue si = kcons(K, str, kcons(K_, i2tv(__LINE__), \
+ i2tv(0))); \
+ kset_source_info(K_, kunwrap(value), si); \
+ kset_source_info(K_, value, si); \
+ kadd_binding(K_, env_, symbol, value); }
+#else /* KTRACK_SI */
+#define add_operative(K_, env_, n_, fn_, ...) \
+ { symbol = ksymbol_new(K_, n_, KNIL); \
+ value = kmake_operative(K_, fn_, __VA_ARGS__); \
+ kadd_binding(K_, env_, symbol, value); }
+
+#define add_applicative(K_, env_, n_, fn_, ...) \
+ { symbol = ksymbol_new(K_, n_); \
+ value = kmake_applicative(K_, fn_, __VA_ARGS__); \
+ kadd_binding(K_, env_, symbol, value); }
+#endif /* KTRACK_SI */
+
+#define add_value(K_, env_, n_, v_) \
+ { value = v_; \
+ symbol = ksymbol_new(K_, n_, KNIL); \
+ kadd_binding(K_, env_, symbol, v_); }
+
#endif
diff --git a/src/kgkd_vars.c b/src/kgkd_vars.c
@@ -200,3 +200,13 @@ void make_keyed_dynamic_variable(klisp_State *K, TValue *xparams,
kapply_cc(K, ls);
}
+/* init ground */
+void kinit_kgkd_vars_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 10.1.1 make-keyed-dynamic-variable */
+ add_applicative(K, ground_env, "make-keyed-dynamic-variable",
+ make_keyed_dynamic_variable, 0);
+}
diff --git a/src/kgkd_vars.h b/src/kgkd_vars.h
@@ -30,4 +30,7 @@ void make_keyed_dynamic_variable(klisp_State *K, TValue *xparams,
void do_unbind(klisp_State *K, TValue *xparams, TValue obj);
+/* init ground */
+void kinit_kgkd_vars_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgks_vars.c b/src/kgks_vars.c
@@ -76,3 +76,15 @@ void make_keyed_static_variable(klisp_State *K, TValue *xparams,
kapply_cc(K, ls);
}
+
+
+/* init ground */
+void kinit_kgks_vars_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 11.1.1 make-keyed-static-variable */
+ add_applicative(K, ground_env, "make-keyed-static-variable",
+ make_keyed_static_variable, 0);
+}
diff --git a/src/kgks_vars.h b/src/kgks_vars.h
@@ -22,4 +22,7 @@
void make_keyed_static_variable(klisp_State *K, TValue *xparams,
TValue ptree, TValue denv);
+/* init ground */
+void kinit_kgks_vars_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -2213,3 +2213,140 @@ void kexpt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
arith_kapply_cc(K, res);
}
+
+
+/* init ground */
+void kinit_numbers_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* No complex or bounded reals for now */
+ /* 12.5.1 number?, finite?, integer? */
+ add_applicative(K, ground_env, "number?", ftypep, 2, symbol,
+ p2tv(knumberp));
+ add_applicative(K, ground_env, "finite?", ftyped_predp, 3, symbol,
+ p2tv(knumberp), p2tv(kfinitep));
+ add_applicative(K, ground_env, "integer?", ftypep, 2, symbol,
+ p2tv(kintegerp));
+ /* 12.5.2 =? */
+ add_applicative(K, ground_env, "=?", ftyped_kbpredp, 3,
+ symbol, p2tv(knumber_wpvp), p2tv(knum_eqp));
+ /* 12.5.3 <?, <=?, >?, >=? */
+ add_applicative(K, ground_env, "<?", ftyped_kbpredp, 3,
+ symbol, p2tv(kreal_wpvp), p2tv(knum_ltp));
+ add_applicative(K, ground_env, "<=?", ftyped_kbpredp, 3,
+ symbol, p2tv(kreal_wpvp), p2tv(knum_lep));
+ add_applicative(K, ground_env, ">?", ftyped_kbpredp, 3,
+ symbol, p2tv(kreal_wpvp), p2tv(knum_gtp));
+ add_applicative(K, ground_env, ">=?", ftyped_kbpredp, 3,
+ symbol, p2tv(kreal_wpvp), p2tv(knum_gep));
+ /* 12.5.4 + */
+ add_applicative(K, ground_env, "+", kplus, 0);
+ /* 12.5.5 * */
+ add_applicative(K, ground_env, "*", ktimes, 0);
+ /* 12.5.6 - */
+ add_applicative(K, ground_env, "-", kminus, 0);
+ /* 12.5.7 zero? */
+ add_applicative(K, ground_env, "zero?", ftyped_predp, 3, symbol,
+ p2tv(knumberp), p2tv(kzerop));
+ /* 12.5.8 div, mod, div-and-mod */
+ add_applicative(K, ground_env, "div", kdiv_mod, 2, symbol,
+ i2tv(FDIV_DIV));
+ add_applicative(K, ground_env, "mod", kdiv_mod, 2, symbol,
+ i2tv(FDIV_MOD));
+ add_applicative(K, ground_env, "div-and-mod", kdiv_mod, 2, symbol,
+ i2tv(FDIV_DIV | FDIV_MOD));
+ /* 12.5.9 div0, mod0, div0-and-mod0 */
+ add_applicative(K, ground_env, "div0", kdiv_mod, 2, symbol,
+ i2tv(FDIV_ZERO | FDIV_DIV));
+ add_applicative(K, ground_env, "mod0", kdiv_mod, 2, symbol,
+ i2tv(FDIV_ZERO | FDIV_MOD));
+ add_applicative(K, ground_env, "div0-and-mod0", kdiv_mod, 2, symbol,
+ i2tv(FDIV_ZERO | FDIV_DIV | FDIV_MOD));
+ /* 12.5.10 positive?, negative? */
+ add_applicative(K, ground_env, "positive?", ftyped_predp, 3, symbol,
+ p2tv(krealp), p2tv(kpositivep));
+ add_applicative(K, ground_env, "negative?", ftyped_predp, 3, symbol,
+ p2tv(krealp), p2tv(knegativep));
+ /* 12.5.11 odd?, even? */
+ add_applicative(K, ground_env, "odd?", ftyped_predp, 3, symbol,
+ p2tv(kintegerp), p2tv(koddp));
+ add_applicative(K, ground_env, "even?", ftyped_predp, 3, symbol,
+ p2tv(kintegerp), p2tv(kevenp));
+ /* 12.5.12 abs */
+ add_applicative(K, ground_env, "abs", kabs, 0);
+ /* 12.5.13 min, max */
+ add_applicative(K, ground_env, "min", kmin_max, 2, symbol, b2tv(FMIN));
+ add_applicative(K, ground_env, "max", kmin_max, 2, symbol, b2tv(FMAX));
+ /* 12.5.14 gcd, lcm */
+ add_applicative(K, ground_env, "gcd", kgcd, 0);
+ add_applicative(K, ground_env, "lcm", klcm, 0);
+ /* 12.6.1 exact?, inexact?, robust?, undefined? */
+ add_applicative(K, ground_env, "exact?", ftyped_predp, 3, symbol,
+ p2tv(knumberp), p2tv(kexactp));
+ add_applicative(K, ground_env, "inexact?", ftyped_predp, 3, symbol,
+ p2tv(knumberp), p2tv(kinexactp));
+ add_applicative(K, ground_env, "robust?", ftyped_predp, 3, symbol,
+ p2tv(knumberp), p2tv(krobustp));
+ add_applicative(K, ground_env, "undefined?", ftyped_predp, 3, symbol,
+ p2tv(knumberp), p2tv(kundefinedp));
+ /* 12.6.2 get-real-internal-bounds, get-real-exact-bounds */
+ add_applicative(K, ground_env, "get-real-internal-bounds",
+ kget_real_internal_bounds, 0);
+ add_applicative(K, ground_env, "get-real-exact-bounds",
+ kget_real_exact_bounds, 0);
+ /* 12.6.3 get-real-internal-primary, get-real-exact-primary */
+ add_applicative(K, ground_env, "get-real-internal-primary",
+ kget_real_internal_primary, 0);
+ add_applicative(K, ground_env, "get-real-exact-primary",
+ kget_real_exact_primary, 0);
+ /* 12.6.4 make-inexact */
+ add_applicative(K, ground_env, "make-inexact", kmake_inexact, 0);
+ /* 12.6.5 real->inexact, real->exact */
+ add_applicative(K, ground_env, "real->inexact", kreal_to_inexact, 0);
+ add_applicative(K, ground_env, "real->exact", kreal_to_exact, 0);
+ /* 12.6.6 with-strict-arithmetic, get-strict-arithmetic? */
+ add_applicative(K, ground_env, "with-strict-arithmetic",
+ kwith_strict_arithmetic, 0);
+ add_applicative(K, ground_env, "get-strict-arithmetic?",
+ kget_strict_arithmeticp, 0);
+ /* 12.8.1 rational? */
+ add_applicative(K, ground_env, "rational?", ftypep, 2, symbol,
+ p2tv(krationalp));
+ /* 12.8.2 / */
+ add_applicative(K, ground_env, "/", kdivided, 0);
+ /* 12.8.3 numerator, denominator */
+ add_applicative(K, ground_env, "numerator", knumerator, 0);
+ add_applicative(K, ground_env, "denominator", kdenominator, 0);
+ /* 12.8.4 floor, ceiling, truncate, round */
+ add_applicative(K, ground_env, "floor", kreal_to_integer, 2,
+ symbol, i2tv((int32_t) K_FLOOR));
+ add_applicative(K, ground_env, "ceiling", kreal_to_integer, 2,
+ symbol, i2tv((int32_t) K_CEILING));
+ add_applicative(K, ground_env, "truncate", kreal_to_integer, 2,
+ symbol, i2tv((int32_t) K_TRUNCATE));
+ add_applicative(K, ground_env, "round", kreal_to_integer, 2,
+ symbol, i2tv((int32_t) K_ROUND_EVEN));
+ /* 12.8.5 rationalize, simplest-rational */
+ add_applicative(K, ground_env, "rationalize", krationalize, 0);
+ add_applicative(K, ground_env, "simplest-rational", ksimplest_rational, 0);
+ /* 12.9.1 real? */
+ add_applicative(K, ground_env, "real?", ftypep, 2, symbol,
+ p2tv(krealp));
+ /* 12.9.2 exp, log */
+ add_applicative(K, ground_env, "exp", kexp, 0);
+ add_applicative(K, ground_env, "log", klog, 0);
+ /* 12.9.3 sin, cos, tan */
+ add_applicative(K, ground_env, "sin", ktrig, 1, sin);
+ add_applicative(K, ground_env, "cos", ktrig, 1, cos);
+ add_applicative(K, ground_env, "tan", ktrig, 1, tan);
+ /* 12.9.4 asin, acos, atan */
+ add_applicative(K, ground_env, "asin", katrig, 1, asin);
+ add_applicative(K, ground_env, "acos", katrig, 1, acos);
+ add_applicative(K, ground_env, "atan", katan, 0);
+ /* 12.9.5 sqrt */
+ add_applicative(K, ground_env, "sqrt", ksqrt, 0);
+ /* 12.9.6 expt */
+ add_applicative(K, ground_env, "expt", kexpt, 0);
+}
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -221,4 +221,7 @@ inline bool knum_same_signp(klisp_State *K, TValue n1, TValue n2)
return kpositivep(K, n1) == kpositivep(K, n2);
}
+/* init ground */
+void kinit_numbers_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -490,3 +490,27 @@ void memqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, res);
}
+
+/* init ground */
+void kinit_pair_mut_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 4.7.1 set-car!, set-cdr! */
+ add_applicative(K, ground_env, "set-car!", set_carB, 0);
+ add_applicative(K, ground_env, "set-cdr!", set_cdrB, 0);
+ /* 4.7.2 copy-es-immutable */
+ add_applicative(K, ground_env, "copy-es-immutable", copy_es, 2, symbol,
+ b2tv(false));
+ /* 5.8.1 encycle! */
+ add_applicative(K, ground_env, "encycle!", encycleB, 0);
+ /* 6.4.1 append! */
+ add_applicative(K, ground_env, "append!", appendB, 0);
+ /* 6.4.2 copy-es */
+ add_applicative(K, ground_env, "copy-es", copy_es, 2, symbol, b2tv(true));
+ /* 6.4.3 assq */
+ add_applicative(K, ground_env, "assq", assq, 0);
+ /* 6.4.3 memq? */
+ add_applicative(K, ground_env, "memq?", memqp, 0);
+}
diff --git a/src/kgpair_mut.h b/src/kgpair_mut.h
@@ -51,4 +51,7 @@ void assq(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* 6.4.3 memq? */
void memqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+/* init ground */
+void kinit_pair_mut_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -996,3 +996,109 @@ void reduce(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
kapply_cc(K, res);
}
+
+/* init ground */
+void kinit_pairs_lists_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 4.6.1 pair? */
+ add_applicative(K, ground_env, "pair?", typep, 2, symbol,
+ i2tv(K_TPAIR));
+ /* 4.6.2 null? */
+ add_applicative(K, ground_env, "null?", typep, 2, symbol,
+ i2tv(K_TNIL));
+ /* 4.6.3 cons */
+ add_applicative(K, ground_env, "cons", cons, 0);
+ /* 5.2.1 list */
+ add_applicative(K, ground_env, "list", list, 0);
+ /* 5.2.2 list* */
+ add_applicative(K, ground_env, "list*", listS, 0);
+ /* 5.4.1 car, cdr */
+ add_applicative(K, ground_env, "car", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(1, 0x0000));
+ add_applicative(K, ground_env, "cdr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(1, 0x0001));
+ /* 5.4.2 caar, cadr, ... cddddr */
+ add_applicative(K, ground_env, "caar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(2, 0x0000));
+ add_applicative(K, ground_env, "cadr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(2, 0x0001));
+ add_applicative(K, ground_env, "cdar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(2, 0x0010));
+ add_applicative(K, ground_env, "cddr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(2, 0x0011));
+ add_applicative(K, ground_env, "caaar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(3, 0x0000));
+ add_applicative(K, ground_env, "caadr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(3, 0x0001));
+ add_applicative(K, ground_env, "cadar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(3, 0x0010));
+ add_applicative(K, ground_env, "caddr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(3, 0x0011));
+ add_applicative(K, ground_env, "cdaar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(3, 0x0100));
+ add_applicative(K, ground_env, "cdadr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(3, 0x0101));
+ add_applicative(K, ground_env, "cddar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(3, 0x0110));
+ add_applicative(K, ground_env, "cdddr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(3, 0x0111));
+ add_applicative(K, ground_env, "caaaar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x0000));
+ add_applicative(K, ground_env, "caaadr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x0001));
+ add_applicative(K, ground_env, "caadar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x0010));
+ add_applicative(K, ground_env, "caaddr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x0011));
+ add_applicative(K, ground_env, "cadaar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x0100));
+ add_applicative(K, ground_env, "cadadr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x0101));
+ add_applicative(K, ground_env, "caddar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x0110));
+ add_applicative(K, ground_env, "cadddr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x0111));
+ add_applicative(K, ground_env, "cdaaar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x1000));
+ add_applicative(K, ground_env, "cdaadr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x1001));
+ add_applicative(K, ground_env, "cdadar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x1010));
+ add_applicative(K, ground_env, "cdaddr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x1011));
+ add_applicative(K, ground_env, "cddaar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x1100));
+ add_applicative(K, ground_env, "cddadr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x1101));
+ add_applicative(K, ground_env, "cdddar", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x1110));
+ add_applicative(K, ground_env, "cddddr", c_ad_r, 2, symbol,
+ C_AD_R_PARAM(4, 0x1111));
+ /* 5.7.1 get-list-metrics */
+ add_applicative(K, ground_env, "get-list-metrics", get_list_metrics, 0);
+ /* 5.7.2 list-tail */
+ add_applicative(K, ground_env, "list-tail", list_tail, 0);
+ /* 6.3.1 length */
+ add_applicative(K, ground_env, "length", length, 0);
+ /* 6.3.2 list-ref */
+ add_applicative(K, ground_env, "list-ref", list_ref, 0);
+ /* 6.3.3 append */
+ add_applicative(K, ground_env, "append", append, 0);
+ /* 6.3.4 list-neighbors */
+ add_applicative(K, ground_env, "list-neighbors", list_neighbors, 0);
+ /* 6.3.5 filter */
+ add_applicative(K, ground_env, "filter", filter, 0);
+ /* 6.3.6 assoc */
+ add_applicative(K, ground_env, "assoc", assoc, 0);
+ /* 6.3.7 member? */
+ add_applicative(K, ground_env, "member?", memberp, 0);
+ /* 6.3.8 finite-list? */
+ add_applicative(K, ground_env, "finite-list?", finite_listp, 0);
+ /* 6.3.9 countable-list? */
+ add_applicative(K, ground_env, "countable-list?", countable_listp, 0);
+ /* 6.3.10 reduce */
+ add_applicative(K, ground_env, "reduce", reduce, 0);
+}
diff --git a/src/kgpairs_lists.h b/src/kgpairs_lists.h
@@ -97,4 +97,7 @@ void do_reduce_combine(klisp_State *K, TValue *xparams, TValue obj);
void do_reduce_cycle(klisp_State *K, TValue *xparams, TValue obj);
void do_reduce(klisp_State *K, TValue *xparams, TValue obj);
+/* init ground */
+void kinit_pairs_lists_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgports.c b/src/kgports.c
@@ -548,3 +548,87 @@ void display(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kwrite_display_to_port(K, port, obj, true);
kapply_cc(K, KINERT);
}
+
+/* init ground */
+void kinit_ports_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 15.1.1 port? */
+ add_applicative(K, ground_env, "port?", typep, 2, symbol,
+ i2tv(K_TPORT));
+ /* 15.1.2 input-port?, output-port? */
+ add_applicative(K, ground_env, "input-port?", ftypep, 2, symbol,
+ p2tv(kis_input_port));
+ add_applicative(K, ground_env, "output-port?", ftypep, 2, symbol,
+ p2tv(kis_output_port));
+ /* 15.1.3 with-input-from-file, with-ouput-to-file */
+ add_applicative(K, ground_env, "with-input-from-file", with_file,
+ 3, symbol, b2tv(false), K->kd_in_port_key);
+ add_applicative(K, ground_env, "with-output-to-file", with_file,
+ 3, symbol, b2tv(true), K->kd_out_port_key);
+ /* 15.1.4 get-current-input-port, get-current-output-port */
+ add_applicative(K, ground_env, "get-current-input-port", get_current_port,
+ 2, symbol, K->kd_in_port_key);
+ add_applicative(K, ground_env, "get-current-output-port", get_current_port,
+ 2, symbol, K->kd_out_port_key);
+ /* 15.1.5 open-input-file, open-output-file */
+ add_applicative(K, ground_env, "open-input-file", open_file, 2, symbol,
+ b2tv(false));
+ add_applicative(K, ground_env, "open-output-file", open_file, 2, symbol,
+ b2tv(true));
+ /* 15.1.6 close-input-file, close-output-file */
+ /* ASK John: should this be called close-input-port & close-ouput-port
+ like in r5rs? that doesn't seem consistent with open thou */
+ add_applicative(K, ground_env, "close-input-file", close_file, 2, symbol,
+ b2tv(false));
+ add_applicative(K, ground_env, "close-output-file", close_file, 2, symbol,
+ b2tv(true));
+ /* 15.1.7 read */
+ add_applicative(K, ground_env, "read", read, 0);
+ /* 15.1.8 write */
+ add_applicative(K, ground_env, "write", write, 0);
+
+ /*
+ ** These are from scheme (r5rs)
+ */
+
+ /* 15.1.? eof-object? */
+ add_applicative(K, ground_env, "eof-object?", typep, 2, symbol,
+ i2tv(K_TEOF));
+ /* 15.1.? newline */
+ add_applicative(K, ground_env, "newline", newline, 0);
+ /* 15.1.? write-char */
+ add_applicative(K, ground_env, "write-char", write_char, 0);
+ /* 15.1.? read-char */
+ add_applicative(K, ground_env, "read-char", read_peek_char, 2, symbol,
+ b2tv(false));
+ /* 15.1.? peek-char */
+ add_applicative(K, ground_env, "peek-char", read_peek_char, 2, symbol,
+ b2tv(true));
+ /* 15.1.? char-ready? */
+ /* XXX: this always return #t, proper behaviour requires platform
+ specific code (probably select for posix, a thread for windows
+ (at least for files & consoles), I think pipes and sockets may
+ have something */
+ add_applicative(K, ground_env, "char-ready?", char_readyp, 0);
+ /* 15.2.1 call-with-input-file, call-with-output-file */
+ add_applicative(K, ground_env, "call-with-input-file", call_with_file,
+ 2, symbol, b2tv(false));
+ add_applicative(K, ground_env, "call-with-output-file", call_with_file,
+ 2, symbol, b2tv(true));
+ /* 15.2.2 load */
+ add_applicative(K, ground_env, "load", load, 0);
+ /* 15.2.3 get-module */
+ add_applicative(K, ground_env, "get-module", get_module, 0);
+ /* 15.2.? display */
+ add_applicative(K, ground_env, "display", display, 0);
+
+ /* MAYBE: That's all there is in the report combined with r5rs scheme,
+ but we will probably need: file-exists?, rename-file and remove-file.
+ It would also be good to be able to select between append, truncate and
+ error if a file exists, but that would need to be an option in all three
+ methods of opening. Also some directory checking, traversing etc */
+ /* BUT SEE r7rs draft for some of the above */
+}
diff --git a/src/kgports.h b/src/kgports.h
@@ -85,4 +85,7 @@ void display(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
void do_close_file_ret(klisp_State *K, TValue *xparams, TValue obj);
+/* init ground */
+void kinit_ports_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgpromises.c b/src/kgpromises.c
@@ -105,3 +105,20 @@ void memoize(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue new_prom = kmake_promise(K, exp, KNIL);
kapply_cc(K, new_prom);
}
+
+/* init ground */
+void kinit_promises_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 9.1.1 promise? */
+ add_applicative(K, ground_env, "promise?", typep, 2, symbol,
+ i2tv(K_TPROMISE));
+ /* 9.1.2 force */
+ add_applicative(K, ground_env, "force", force, 0);
+ /* 9.1.3 $lazy */
+ add_operative(K, ground_env, "$lazy", Slazy, 0);
+ /* 9.1.4 memoize */
+ add_applicative(K, ground_env, "memoize", memoize, 0);
+}
diff --git a/src/kgpromises.h b/src/kgpromises.h
@@ -32,4 +32,7 @@ void memoize(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
void do_handle_result(klisp_State *K, TValue *xparams, TValue obj);
+/* init ground */
+void kinit_promises_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kground.c b/src/kground.c
@@ -14,11 +14,6 @@
#include "kstate.h"
#include "kobject.h"
#include "kground.h"
-#include "kenvironment.h"
-#include "ksymbol.h"
-#include "koperative.h"
-#include "kapplicative.h"
-#include "kerror.h"
#include "kghelpers.h"
#include "kgbooleans.h"
@@ -47,51 +42,6 @@
#include "keval.h"
#include "krepl.h"
-
-/*
-** BEWARE: this is highly unhygienic, it assumes variables "symbol" and
-** "value", both of type TValue. symbol will be bound to a symbol named by
-** "n_" and can be referrenced in the var_args
-** GC: All of these should be called when GC is deactivated on startup
-*/
-
-/* TODO add si to the symbols */
-#if KTRACK_SI
-#define add_operative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new(K_, n_, KNIL); \
- value = kmake_operative(K_, fn_, __VA_ARGS__); \
- TValue str = kstring_new_b_imm(K_, __FILE__); \
- TValue si = kcons(K, str, kcons(K_, i2tv(__LINE__), \
- i2tv(0))); \
- kset_source_info(K_, value, si); \
- kadd_binding(K_, env_, symbol, value); }
-
-#define add_applicative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new(K_, n_, KNIL); \
- value = kmake_applicative(K_, fn_, __VA_ARGS__); \
- TValue str = kstring_new_b_imm(K_, __FILE__); \
- TValue si = kcons(K, str, kcons(K_, i2tv(__LINE__), \
- i2tv(0))); \
- kset_source_info(K_, kunwrap(value), si); \
- kset_source_info(K_, value, si); \
- kadd_binding(K_, env_, symbol, value); }
-#else /* KTRACK_SI */
-#define add_operative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new(K_, n_, KNIL); \
- value = kmake_operative(K_, fn_, __VA_ARGS__); \
- kadd_binding(K_, env_, symbol, value); }
-
-#define add_applicative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new(K_, n_); \
- value = kmake_applicative(K_, fn_, __VA_ARGS__); \
- kadd_binding(K_, env_, symbol, value); }
-#endif /* KTRACK_SI */
-
-#define add_value(K_, env_, n_, v_) \
- { value = v_; \
- symbol = ksymbol_new(K_, n_, KNIL); \
- kadd_binding(K_, env_, symbol, v_); }
-
/* for init_cont_names */
#define add_cont_name(K_, t_, c_, n_) \
{ TValue str = kstring_new_b_imm(K_, n_); \
@@ -158,1045 +108,33 @@ void kinit_cont_names(klisp_State *K)
*/
void kinit_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env; /* this is already rooted */
- TValue symbol, value;
-
- /*
- ** This section will roughly follow the report and will reference the
- ** section in which each symbol is defined
- */
-
- /*
- **
- ** 4 Core types and primitive features
- **
- */
-
- /*
- ** 4.1 Booleans
- */
-
- /* 4.1.1 boolean? */
- add_applicative(K, ground_env, "boolean?", typep, 2, symbol,
- i2tv(K_TBOOLEAN));
-
- /*
- ** 4.2 Equivalence under mutation
- */
-
- /* 4.2.1 eq? */
- /* 6.5.1 eq? */
- add_applicative(K, ground_env, "eq?", eqp, 0);
-
- /*
- ** 4.3 Equivalence up to mutation
- */
-
- /* 4.3.1 equal? */
- /* 6.6.1 equal? */
- add_applicative(K, ground_env, "equal?", equalp, 0);
-
- /*
- ** 4.4 Symbols
- */
-
- /* 4.4.1 symbol? */
- add_applicative(K, ground_env, "symbol?", typep, 2, symbol,
- i2tv(K_TSYMBOL));
-
- /*
- ** 4.5 Control
- */
-
- /* 4.5.1 inert? */
- add_applicative(K, ground_env, "inert?", typep, 2, symbol,
- i2tv(K_TINERT));
-
- /* 4.5.2 $if */
- add_operative(K, ground_env, "$if", Sif, 0);
-
- /*
- ** 4.6 Pairs and lists
- */
-
- /* 4.6.1 pair? */
- add_applicative(K, ground_env, "pair?", typep, 2, symbol,
- i2tv(K_TPAIR));
-
- /* 4.6.2 null? */
- add_applicative(K, ground_env, "null?", typep, 2, symbol,
- i2tv(K_TNIL));
-
- /* 4.6.3 cons */
- add_applicative(K, ground_env, "cons", cons, 0);
-
- /*
- ** 4.7 Pair mutation
- */
-
- /* 4.7.1 set-car!, set-cdr! */
- add_applicative(K, ground_env, "set-car!", set_carB, 0);
- add_applicative(K, ground_env, "set-cdr!", set_cdrB, 0);
-
- /* 4.7.2 copy-es-immutable */
- add_applicative(K, ground_env, "copy-es-immutable", copy_es, 2, symbol,
- b2tv(false));
-
- /*
- ** 4.8 Environments
- */
-
- /* 4.8.1 environment? */
- add_applicative(K, ground_env, "environment?", typep, 2, symbol,
- i2tv(K_TENVIRONMENT));
-
- /* 4.8.2 ignore? */
- add_applicative(K, ground_env, "ignore?", typep, 2, symbol,
- i2tv(K_TIGNORE));
-
- /* 4.8.3 eval */
- add_applicative(K, ground_env, "eval", eval, 0);
-
- /* 4.8.4 make-environment */
- add_applicative(K, ground_env, "make-environment", make_environment, 0);
-
- /*
- ** 4.9 Environment mutation
- */
-
- /* 4.9.1 $define! */
- add_operative(K, ground_env, "$define!", SdefineB, 1, symbol);
-
- /*
- ** 4.10 Combiners
- */
-
- /* 4.10.1 operative? */
- add_applicative(K, ground_env, "operative?", typep, 2, symbol,
- i2tv(K_TOPERATIVE));
-
- /* 4.10.2 applicative? */
- add_applicative(K, ground_env, "applicative?", typep, 2, symbol,
- i2tv(K_TAPPLICATIVE));
-
- /* 4.10.3 $vau */
- /* 5.3.1 $vau */
- add_operative(K, ground_env, "$vau", Svau, 0);
-
- /* 4.10.4 wrap */
- add_applicative(K, ground_env, "wrap", wrap, 0);
-
- /* 4.10.5 unwrap */
- add_applicative(K, ground_env, "unwrap", unwrap, 0);
-
- /*
- **
- ** 5 Core library features (I)
- **
- */
-
- /*
- ** 5.1 Control
- */
-
- /* 5.1.1 $sequence */
- add_operative(K, ground_env, "$sequence", Ssequence, 0);
-
- /*
- ** 5.2 Pairs and lists
- */
-
- /* 5.2.1 list */
- add_applicative(K, ground_env, "list", list, 0);
-
- /* 5.2.2 list* */
- add_applicative(K, ground_env, "list*", listS, 0);
-
- /*
- ** 5.3 Combiners
- */
-
- /* 5.3.1 $vau */
- /* DONE: above, together with 4.10.4 */
-
- /* 5.3.2 $lambda */
- add_operative(K, ground_env, "$lambda", Slambda, 0);
-
- /*
- ** 5.4 Pairs and lists
- */
-
- /* 5.4.1 car, cdr */
- add_applicative(K, ground_env, "car", c_ad_r, 2, symbol,
- C_AD_R_PARAM(1, 0x0000));
- add_applicative(K, ground_env, "cdr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(1, 0x0001));
-
- /* 5.4.2 caar, cadr, ... cddddr */
- add_applicative(K, ground_env, "caar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(2, 0x0000));
- add_applicative(K, ground_env, "cadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(2, 0x0001));
- add_applicative(K, ground_env, "cdar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(2, 0x0010));
- add_applicative(K, ground_env, "cddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(2, 0x0011));
-
- add_applicative(K, ground_env, "caaar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0000));
- add_applicative(K, ground_env, "caadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0001));
- add_applicative(K, ground_env, "cadar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0010));
- add_applicative(K, ground_env, "caddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0011));
- add_applicative(K, ground_env, "cdaar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0100));
- add_applicative(K, ground_env, "cdadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0101));
- add_applicative(K, ground_env, "cddar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0110));
- add_applicative(K, ground_env, "cdddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(3, 0x0111));
-
- add_applicative(K, ground_env, "caaaar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0000));
- add_applicative(K, ground_env, "caaadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0001));
- add_applicative(K, ground_env, "caadar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0010));
- add_applicative(K, ground_env, "caaddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0011));
- add_applicative(K, ground_env, "cadaar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0100));
- add_applicative(K, ground_env, "cadadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0101));
- add_applicative(K, ground_env, "caddar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0110));
- add_applicative(K, ground_env, "cadddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x0111));
- add_applicative(K, ground_env, "cdaaar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1000));
- add_applicative(K, ground_env, "cdaadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1001));
- add_applicative(K, ground_env, "cdadar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1010));
- add_applicative(K, ground_env, "cdaddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1011));
- add_applicative(K, ground_env, "cddaar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1100));
- add_applicative(K, ground_env, "cddadr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1101));
- add_applicative(K, ground_env, "cdddar", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1110));
- add_applicative(K, ground_env, "cddddr", c_ad_r, 2, symbol,
- C_AD_R_PARAM(4, 0x1111));
-
- /*
- ** 5.5 Combiners
- */
-
- /* 5.5.1 apply */
- add_applicative(K, ground_env, "apply", apply, 0);
-
- /*
- ** 5.6 Control
- */
-
- /* 5.6.1 $cond */
- add_operative(K, ground_env, "$cond", Scond, 0);
-
- /*
- ** 5.7 Pairs and lists
- */
-
- /* 5.7.1 get-list-metrics */
- add_applicative(K, ground_env, "get-list-metrics", get_list_metrics, 0);
-
- /* 5.7.2 list-tail */
- add_applicative(K, ground_env, "list-tail", list_tail, 0);
-
- /*
- ** 5.8 Pair mutation
- */
-
- /* 5.8.1 encycle! */
- add_applicative(K, ground_env, "encycle!", encycleB, 0);
-
- /*
- ** 5.9 Combiners
- */
-
- /* 5.9.1 map */
- add_applicative(K, ground_env, "map", map, 0);
-
- /*
- ** 5.10 Environments
- */
-
- /* 5.10.1 $let */
- add_operative(K, ground_env, "$let", Slet, 1, symbol);
-
- /*
- **
- ** 6 Core library features (II)
- **
- */
-
- /*
- ** 6.1 Booleans
- */
-
- /* 6.1.1 not? */
- add_applicative(K, ground_env, "not?", notp, 0);
-
- /* 6.1.2 and? */
- add_applicative(K, ground_env, "and?", andp, 0);
-
- /* 6.1.3 or? */
- add_applicative(K, ground_env, "or?", orp, 0);
-
- /* 6.1.4 $and? */
- add_operative(K, ground_env, "$and?", Sandp_Sorp, 2, symbol, KFALSE);
-
- /* 6.1.5 $or? */
- add_operative(K, ground_env, "$or?", Sandp_Sorp, 2, symbol, KTRUE);
-
- /*
- ** 6.2 Combiners
- */
-
- /* 6.2.1 combiner? */
- add_applicative(K, ground_env, "combiner?", ftypep, 2, symbol,
- p2tv(kcombinerp));
-
- /*
- ** 6.3 Pairs and lists
- */
-
- /* 6.3.1 length */
- add_applicative(K, ground_env, "length", length, 0);
-
- /* 6.3.2 list-ref */
- add_applicative(K, ground_env, "list-ref", list_ref, 0);
-
- /* 6.3.3 append */
- add_applicative(K, ground_env, "append", append, 0);
-
- /* 6.3.4 list-neighbors */
- add_applicative(K, ground_env, "list-neighbors", list_neighbors, 0);
-
- /* 6.3.5 filter */
- add_applicative(K, ground_env, "filter", filter, 0);
-
- /* 6.3.6 assoc */
- add_applicative(K, ground_env, "assoc", assoc, 0);
-
- /* 6.3.7 member? */
- add_applicative(K, ground_env, "member?", memberp, 0);
-
- /* 6.3.8 finite-list? */
- add_applicative(K, ground_env, "finite-list?", finite_listp, 0);
-
- /* 6.3.9 countable-list? */
- add_applicative(K, ground_env, "countable-list?", countable_listp, 0);
-
- /* 6.3.10 reduce */
- add_applicative(K, ground_env, "reduce", reduce, 0);
-
- /*
- ** 6.4 Pair mutation
- */
-
- /* 6.4.1 append! */
- add_applicative(K, ground_env, "append!", appendB, 0);
-
- /* 6.4.2 copy-es */
- add_applicative(K, ground_env, "copy-es", copy_es, 2, symbol, b2tv(true));
-
- /* 6.4.3 assq */
- add_applicative(K, ground_env, "assq", assq, 0);
-
- /* 6.4.3 memq? */
- add_applicative(K, ground_env, "memq?", memqp, 0);
-
- /*
- ** 6.5 Equivalance under mutation
- */
-
- /* 6.5.1 eq? */
- /* DONE: above, together with 4.2.1 */
-
- /*
- ** 6.6 Equivalance up to mutation
- */
-
- /* 6.6.1 equal? */
- /* DONE: above, together with 4.3.1 */
-
- /*
- ** 6.7 Environments
- */
-
- /* 6.7.1 $binds? */
- add_operative(K, ground_env, "$binds?", Sbindsp, 0);
-
- /* 6.7.2 get-current-environment */
- add_applicative(K, ground_env, "get-current-environment",
- get_current_environment, 0);
-
- /* 6.7.3 make-kernel-standard-environment */
- add_applicative(K, ground_env, "make-kernel-standard-environment",
- make_kernel_standard_environment, 0);
-
- /* 6.7.4 $let* */
- add_operative(K, ground_env, "$let*", SletS, 1, symbol);
-
- /* 6.7.5 $letrec */
- add_operative(K, ground_env, "$letrec", Sletrec, 1, symbol);
-
- /* 6.7.6 $letrec* */
- add_operative(K, ground_env, "$letrec*", SletrecS, 1, symbol);
-
- /* 6.7.7 $let-redirect */
- add_operative(K, ground_env, "$let-redirect", Slet_redirect, 1, symbol);
-
- /* 6.7.8 $let-safe */
- add_operative(K, ground_env, "$let-safe", Slet_safe, 1, symbol);
-
- /* 6.7.9 $remote-eval */
- add_operative(K, ground_env, "$remote-eval", Sremote_eval, 0);
-
- /* 6.7.10 $bindings->environment */
- add_operative(K, ground_env, "$bindings->environment",
- Sbindings_to_environment, 1, symbol);
-
- /*
- ** 6.8 Environment mutation
- */
-
- /* 6.8.1 $set! */
- add_operative(K, ground_env, "$set!", SsetB, 1, symbol);
-
- /* 6.8.2 $provide! */
- add_operative(K, ground_env, "$provide!", SprovideB, 1, symbol);
-
- /* 6.8.3 $import! */
- add_operative(K, ground_env, "$import!", SimportB, 1, symbol);
-
- /*
- ** 6.9 Control
- */
-
- /* 6.9.1 for-each */
- add_applicative(K, ground_env, "for-each", for_each, 0);
-
- /*
- **
- ** 7 Continuations
- **
- */
-
- /*
- ** 7.2 Primitive features
- */
-
- /* 7.1.1 continuation? */
- add_applicative(K, ground_env, "continuation?", typep, 2, symbol,
- i2tv(K_TCONTINUATION));
-
- /* 7.2.2 call/cc */
- add_applicative(K, ground_env, "call/cc", call_cc, 0);
-
- /* 7.2.3 extend-continuation */
- add_applicative(K, ground_env, "extend-continuation", extend_continuation, 0);
-
- /* 7.2.4 guard-continuation */
- add_applicative(K, ground_env, "guard-continuation", guard_continuation,
- 0);
-
- /* 7.2.5 continuation->applicative */
- add_applicative(K, ground_env, "continuation->applicative",
- continuation_applicative, 0);
-
- /* 7.2.6 root-continuation */
- add_value(K, ground_env, "root-continuation",
- K->root_cont);
-
- /* 7.2.7 error-continuation */
- add_value(K, ground_env, "error-continuation",
- K->root_cont);
-
- /*
- ** 7.3 Library features
- */
-
- /* 7.3.1 apply-continuation */
- add_applicative(K, ground_env, "apply-continuation", apply_continuation,
- 0);
-
- /* 7.3.2 $let/cc */
- add_operative(K, ground_env, "$let/cc", Slet_cc,
- 0);
-
- /* 7.3.3 guard-dynamic-extent */
- add_applicative(K, ground_env, "guard-dynamic-extent",
- guard_dynamic_extent, 0);
-
- /* 7.3.4 exit */
- add_applicative(K, ground_env, "exit", kgexit,
- 0);
-
-
- /*
- **
- ** 8 Encapsulations
- **
- */
-
- /*
- ** 8.1 Primitive features
- */
-
- /* 8.1.1 make-encapsulation-type */
- add_applicative(K, ground_env, "make-encapsulation-type",
- make_encapsulation_type, 0);
-
- /*
- **
- ** 9 Promises
- **
- */
-
- /*
- ** 9.1 Library features
- */
-
- /* 9.1.1 promise? */
- add_applicative(K, ground_env, "promise?", typep, 2, symbol,
- i2tv(K_TPROMISE));
-
- /* 9.1.2 force */
- add_applicative(K, ground_env, "force", force, 0);
-
- /* 9.1.3 $lazy */
- add_operative(K, ground_env, "$lazy", Slazy, 0);
-
- /* 9.1.4 memoize */
- add_applicative(K, ground_env, "memoize", memoize, 0);
-
- /*
- **
- ** 10 Keyed Dynamic Variables
- **
- */
-
- /*
- ** 10.1 Primitive features
- */
-
- /* 10.1.1 make-keyed-dynamic-variable */
- add_applicative(K, ground_env, "make-keyed-dynamic-variable",
- make_keyed_dynamic_variable, 0);
-
-
/*
- **
- ** 11 Keyed Static Variables
- **
- */
-
- /*
- ** 11.1 Primitive features
- */
-
- /* 11.1.1 make-keyed-static-variable */
- add_applicative(K, ground_env, "make-keyed-static-variable",
- make_keyed_static_variable, 0);
-
-
- /*
- **
- ** 12 Numbers
- **
- */
-
- /* Only integers, rationals and exact infinities for now */
-
- /*
- ** 12.5 Number features
- */
-
- /* 12.5.1 number?, finite?, integer? */
- add_applicative(K, ground_env, "number?", ftypep, 2, symbol,
- p2tv(knumberp));
- add_applicative(K, ground_env, "finite?", ftyped_predp, 3, symbol,
- p2tv(knumberp), p2tv(kfinitep));
- add_applicative(K, ground_env, "integer?", ftypep, 2, symbol,
- p2tv(kintegerp));
-
- /* 12.5.2 =? */
- add_applicative(K, ground_env, "=?", ftyped_kbpredp, 3,
- symbol, p2tv(knumber_wpvp), p2tv(knum_eqp));
-
- /* 12.5.3 <?, <=?, >?, >=? */
- add_applicative(K, ground_env, "<?", ftyped_kbpredp, 3,
- symbol, p2tv(kreal_wpvp), p2tv(knum_ltp));
- add_applicative(K, ground_env, "<=?", ftyped_kbpredp, 3,
- symbol, p2tv(kreal_wpvp), p2tv(knum_lep));
- add_applicative(K, ground_env, ">?", ftyped_kbpredp, 3,
- symbol, p2tv(kreal_wpvp), p2tv(knum_gtp));
- add_applicative(K, ground_env, ">=?", ftyped_kbpredp, 3,
- symbol, p2tv(kreal_wpvp), p2tv(knum_gep));
-
- /* 12.5.4 + */
- add_applicative(K, ground_env, "+", kplus, 0);
-
- /* 12.5.5 * */
- add_applicative(K, ground_env, "*", ktimes, 0);
-
- /* 12.5.6 - */
- add_applicative(K, ground_env, "-", kminus, 0);
-
- /* 12.5.7 zero? */
- add_applicative(K, ground_env, "zero?", ftyped_predp, 3, symbol,
- p2tv(knumberp), p2tv(kzerop));
-
- /* 12.5.8 div, mod, div-and-mod */
- add_applicative(K, ground_env, "div", kdiv_mod, 2, symbol,
- i2tv(FDIV_DIV));
- add_applicative(K, ground_env, "mod", kdiv_mod, 2, symbol,
- i2tv(FDIV_MOD));
- add_applicative(K, ground_env, "div-and-mod", kdiv_mod, 2, symbol,
- i2tv(FDIV_DIV | FDIV_MOD));
-
- /* 12.5.9 div0, mod0, div0-and-mod0 */
- add_applicative(K, ground_env, "div0", kdiv_mod, 2, symbol,
- i2tv(FDIV_ZERO | FDIV_DIV));
- add_applicative(K, ground_env, "mod0", kdiv_mod, 2, symbol,
- i2tv(FDIV_ZERO | FDIV_MOD));
- add_applicative(K, ground_env, "div0-and-mod0", kdiv_mod, 2, symbol,
- i2tv(FDIV_ZERO | FDIV_DIV | FDIV_MOD));
-
- /* 12.5.10 positive?, negative? */
- add_applicative(K, ground_env, "positive?", ftyped_predp, 3, symbol,
- p2tv(krealp), p2tv(kpositivep));
- add_applicative(K, ground_env, "negative?", ftyped_predp, 3, symbol,
- p2tv(krealp), p2tv(knegativep));
-
- /* 12.5.11 odd?, even? */
- add_applicative(K, ground_env, "odd?", ftyped_predp, 3, symbol,
- p2tv(kintegerp), p2tv(koddp));
- add_applicative(K, ground_env, "even?", ftyped_predp, 3, symbol,
- p2tv(kintegerp), p2tv(kevenp));
-
- /* 12.5.12 abs */
- add_applicative(K, ground_env, "abs", kabs, 0);
-
- /* 12.5.13 min, max */
- add_applicative(K, ground_env, "min", kmin_max, 2, symbol, b2tv(FMIN));
- add_applicative(K, ground_env, "max", kmin_max, 2, symbol, b2tv(FMAX));
-
- /* 12.5.14 gcd, lcm */
- add_applicative(K, ground_env, "gcd", kgcd, 0);
- add_applicative(K, ground_env, "lcm", klcm, 0);
-
- /*
- ** 12.8 Inexact features
- */
-
- /* 12.6.1 exact?, inexact?, robust?, undefined? */
- add_applicative(K, ground_env, "exact?", ftyped_predp, 3, symbol,
- p2tv(knumberp), p2tv(kexactp));
- add_applicative(K, ground_env, "inexact?", ftyped_predp, 3, symbol,
- p2tv(knumberp), p2tv(kinexactp));
- add_applicative(K, ground_env, "robust?", ftyped_predp, 3, symbol,
- p2tv(knumberp), p2tv(krobustp));
- add_applicative(K, ground_env, "undefined?", ftyped_predp, 3, symbol,
- p2tv(knumberp), p2tv(kundefinedp));
-
- /* 12.6.2 get-real-internal-bounds, get-real-exact-bounds */
- add_applicative(K, ground_env, "get-real-internal-bounds",
- kget_real_internal_bounds, 0);
- add_applicative(K, ground_env, "get-real-exact-bounds",
- kget_real_exact_bounds, 0);
-
- /* 12.6.3 get-real-internal-primary, get-real-exact-primary */
- add_applicative(K, ground_env, "get-real-internal-primary",
- kget_real_internal_primary, 0);
- add_applicative(K, ground_env, "get-real-exact-primary",
- kget_real_exact_primary, 0);
-
- /* 12.6.4 make-inexact */
- add_applicative(K, ground_env, "make-inexact", kmake_inexact, 0);
-
- /* 12.6.5 real->inexact, real->exact */
- add_applicative(K, ground_env, "real->inexact", kreal_to_inexact, 0);
- add_applicative(K, ground_env, "real->exact", kreal_to_exact, 0);
-
- /* 12.6.6 with-strict-arithmetic, get-strict-arithmetic? */
- add_applicative(K, ground_env, "with-strict-arithmetic",
- kwith_strict_arithmetic, 0);
- add_applicative(K, ground_env, "get-strict-arithmetic?",
- kget_strict_arithmeticp, 0);
-
- /*
- ** 12.8 Rational features
- */
-
- /* 12.8.1 rational? */
- add_applicative(K, ground_env, "rational?", ftypep, 2, symbol,
- p2tv(krationalp));
-
- /* 12.8.2 / */
- add_applicative(K, ground_env, "/", kdivided, 0);
-
- /* 12.8.3 numerator, denominator */
- add_applicative(K, ground_env, "numerator", knumerator, 0);
- add_applicative(K, ground_env, "denominator", kdenominator, 0);
-
- /* 12.8.4 floor, ceiling, truncate, round */
- add_applicative(K, ground_env, "floor", kreal_to_integer, 2,
- symbol, i2tv((int32_t) K_FLOOR));
- add_applicative(K, ground_env, "ceiling", kreal_to_integer, 2,
- symbol, i2tv((int32_t) K_CEILING));
- add_applicative(K, ground_env, "truncate", kreal_to_integer, 2,
- symbol, i2tv((int32_t) K_TRUNCATE));
- add_applicative(K, ground_env, "round", kreal_to_integer, 2,
- symbol, i2tv((int32_t) K_ROUND_EVEN));
-
- /* 12.8.5 rationalize, simplest-rational */
- add_applicative(K, ground_env, "rationalize", krationalize, 0);
- add_applicative(K, ground_env, "simplest-rational", ksimplest_rational, 0);
-
- /*
- ** 12.9 Real features
- */
-
- /* 12.9.1 real? */
- add_applicative(K, ground_env, "real?", ftypep, 2, symbol,
- p2tv(krealp));
-
- /* 12.9.2 exp, log */
- add_applicative(K, ground_env, "exp", kexp, 0);
- add_applicative(K, ground_env, "log", klog, 0);
-
- /* 12.9.3 sin, cos, tan */
- add_applicative(K, ground_env, "sin", ktrig, 1, sin);
- add_applicative(K, ground_env, "cos", ktrig, 1, cos);
- add_applicative(K, ground_env, "tan", ktrig, 1, tan);
-
- /* 12.9.4 asin, acos, atan */
- add_applicative(K, ground_env, "asin", katrig, 1, asin);
- add_applicative(K, ground_env, "acos", katrig, 1, acos);
- add_applicative(K, ground_env, "atan", katan, 0);
-
- /* 12.9.5 sqrt */
- add_applicative(K, ground_env, "sqrt", ksqrt, 0);
-
- /* 12.9.6 expt */
- add_applicative(K, ground_env, "expt", kexpt, 0);
-
- /*
- **
- ** 13 Strings
- **
- */
-
- /*
- ** This section is still missing from the report. The bindings here are
- ** taken from r5rs scheme and should not be considered standard. They are
- ** provided in the meantime to allow programs to use string features
- ** (ASCII only).
- */
-
- /*
- ** 13.1 Primitive features
- */
-
- /* 13.1.1? string? */
- add_applicative(K, ground_env, "string?", typep, 2, symbol,
- i2tv(K_TSTRING));
-
- /* 13.1.2? make-string */
- add_applicative(K, ground_env, "make-string", make_string, 0);
-
- /* 13.1.3? string-length */
- add_applicative(K, ground_env, "string-length", string_length, 0);
-
- /* 13.1.4? string-ref */
- add_applicative(K, ground_env, "string-ref", string_ref, 0);
-
- /* 13.1.5? string-set! */
- add_applicative(K, ground_env, "string-set!", string_setS, 0);
-
- /*
- ** 13.2 Library features
- */
-
- /* 13.2.1? string */
- add_applicative(K, ground_env, "string", string, 0);
-
- /* 13.2.2? string=?, string-ci=? */
- add_applicative(K, ground_env, "string=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_eqp));
- add_applicative(K, ground_env, "string-ci=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_eqp));
-
- /* 13.2.3? string<?, string<=?, string>?, string>=? */
- add_applicative(K, ground_env, "string<?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ltp));
- add_applicative(K, ground_env, "string<=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_lep));
- add_applicative(K, ground_env, "string>?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_gtp));
- add_applicative(K, ground_env, "string>=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_gep));
-
- /* 13.2.4? string-ci<?, string-ci<=?, string-ci>?, string-ci>=? */
- add_applicative(K, ground_env, "string-ci<?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_ltp));
- add_applicative(K, ground_env, "string-ci<=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_lep));
- add_applicative(K, ground_env, "string-ci>?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_gtp));
- add_applicative(K, ground_env, "string-ci>=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_gep));
-
- /* 13.2.5? substring */
- add_applicative(K, ground_env, "substring", substring, 0);
-
- /* 13.2.6? string-append */
- add_applicative(K, ground_env, "string-append", string_append, 0);
-
- /* 13.2.7? string->list, list->string */
- add_applicative(K, ground_env, "string->list", string_to_list, 0);
- add_applicative(K, ground_env, "list->string", list_to_string, 0);
-
- /* 13.2.8? string-copy */
- add_applicative(K, ground_env, "string-copy", string_copy, 0);
-
- /* 13.2.9? string->immutable-string */
- add_applicative(K, ground_env, "string->immutable-string",
- string_to_immutable_string, 0);
-
- /* TODO: add string-immutable? or general immutable? */
-
- /* 13.2.10? string-fill! */
- add_applicative(K, ground_env, "string-fill!", string_fillS, 0);
-
- /*
- ** 13.3 Symbol Features (this are from section symbol in r5rs)
- */
-
- /* 13.3.1? symbol->string */
- /* TEMP: for now all strings are mutable, this returns a new object
- each time */
- add_applicative(K, ground_env, "symbol->string", symbol_to_string, 0);
-
- /* 13.3.2? string->symbol */
- /* TEMP: for now this can create symbols with no external representation
- this includes all symbols with non identifiers characters.
- */
- /* NOTE:
- Symbols with uppercase alphabetic characters will write as lowercase and
- so, when read again will not compare as either eq? or equal?. This is ok
- because the report only says that read objects when written and read
- again must be equal? which happens here
- */
- add_applicative(K, ground_env, "string->symbol", string_to_symbol, 0);
-
-
- /*
- **
- ** 14 Characters
- **
- */
-
- /*
- ** This section is still missing from the report. The bindings here are
- ** taken from r5rs scheme and should not be considered standard. They are
- ** provided in the meantime to allow programs to use character features
- ** (ASCII only).
- */
-
- /*
- ** 14.1 Primitive features
- */
-
- /* 14.1.1? char? */
- add_applicative(K, ground_env, "char?", typep, 2, symbol,
- i2tv(K_TCHAR));
-
- /* 14.1.2? char-alphabetic?, char-numeric?, char-whitespace? */
- /* unlike in r5rs these take an arbitrary number of chars
- (even cyclical list) */
- add_applicative(K, ground_env, "char-alphabetic?", ftyped_predp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_alphabeticp));
- add_applicative(K, ground_env, "char-numeric?", ftyped_predp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_numericp));
- add_applicative(K, ground_env, "char-whitespace?", ftyped_predp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_whitespacep));
-
- /* 14.1.3? char-upper-case?, char-lower-case? */
- /* unlike in r5rs these take an arbitrary number of chars
- (even cyclical list) */
- add_applicative(K, ground_env, "char-upper-case?", ftyped_predp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_upper_casep));
- add_applicative(K, ground_env, "char-lower-case?", ftyped_predp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_lower_casep));
-
-
- /* 14.1.4? char->integer, integer->char */
- add_applicative(K, ground_env, "char->integer", kchar_to_integer, 0);
- add_applicative(K, ground_env, "integer->char", kinteger_to_char, 0);
-
- /* 14.1.4? char-upcase, char-downcase */
- add_applicative(K, ground_env, "char-upcase", kchar_upcase, 0);
- add_applicative(K, ground_env, "char-downcase", kchar_downcase, 0);
-
- /*
- ** 14.2 Library features
- */
-
- /* 14.2.1? char=? */
- add_applicative(K, ground_env, "char=?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_eqp));
-
- /* 14.2.2? char<?, char<=?, char>?, char>=? */
- add_applicative(K, ground_env, "char<?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_ltp));
- add_applicative(K, ground_env, "char<=?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_lep));
- add_applicative(K, ground_env, "char>?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_gtp));
- add_applicative(K, ground_env, "char>=?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_gep));
-
- /* 14.2.3? char-ci=? */
- add_applicative(K, ground_env, "char-ci=?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_ci_eqp));
-
- /* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */
- add_applicative(K, ground_env, "char-ci<?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_ci_ltp));
- add_applicative(K, ground_env, "char-ci<=?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_ci_lep));
- add_applicative(K, ground_env, "char-ci>?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_ci_gtp));
- add_applicative(K, ground_env, "char-ci>=?", ftyped_bpredp, 3,
- symbol, p2tv(kcharp), p2tv(kchar_ci_gep));
-
- /*
- **
- ** 15 Ports
- **
- */
-
- /*
- ** 15.1 Primitive features
- */
-
- /* 15.1.1 port? */
- add_applicative(K, ground_env, "port?", typep, 2, symbol,
- i2tv(K_TPORT));
-
- /* 15.1.2 input-port?, output-port? */
- add_applicative(K, ground_env, "input-port?", ftypep, 2, symbol,
- p2tv(kis_input_port));
-
- add_applicative(K, ground_env, "output-port?", ftypep, 2, symbol,
- p2tv(kis_output_port));
-
- /* 15.1.3 with-input-from-file, with-ouput-to-file */
- add_applicative(K, ground_env, "with-input-from-file", with_file,
- 3, symbol, b2tv(false), K->kd_in_port_key);
- add_applicative(K, ground_env, "with-output-to-file", with_file,
- 3, symbol, b2tv(true), K->kd_out_port_key);
-
- /* 15.1.4 get-current-input-port, get-current-output-port */
- add_applicative(K, ground_env, "get-current-input-port", get_current_port,
- 2, symbol, K->kd_in_port_key);
- add_applicative(K, ground_env, "get-current-output-port", get_current_port,
- 2, symbol, K->kd_out_port_key);
-
- /* 15.1.5 open-input-file, open-output-file */
- add_applicative(K, ground_env, "open-input-file", open_file, 2, symbol,
- b2tv(false));
-
- add_applicative(K, ground_env, "open-output-file", open_file, 2, symbol,
- b2tv(true));
-
- /* 15.1.6 close-input-file, close-output-file */
- /* ASK John: should this be called close-input-port & close-ouput-port
- like in r5rs? that doesn't seem consistent with open thou */
- add_applicative(K, ground_env, "close-input-file", close_file, 2, symbol,
- b2tv(false));
-
- add_applicative(K, ground_env, "close-output-file", close_file, 2, symbol,
- b2tv(true));
-
- /* 15.1.7 read */
- add_applicative(K, ground_env, "read", read, 0);
-
- /* 15.1.8 write */
- add_applicative(K, ground_env, "write", write, 0);
-
- /*
- ** These are from scheme (r5rs)
- */
-
- /* 15.1.? eof-object? */
- add_applicative(K, ground_env, "eof-object?", typep, 2, symbol,
- i2tv(K_TEOF));
-
- /* 15.1.? newline */
- add_applicative(K, ground_env, "newline", newline, 0);
-
- /* 15.1.? write-char */
- add_applicative(K, ground_env, "write-char", write_char, 0);
-
- /* 15.1.? read-char */
- add_applicative(K, ground_env, "read-char", read_peek_char, 2, symbol,
- b2tv(false));
-
- /* 15.1.? peek-char */
- add_applicative(K, ground_env, "peek-char", read_peek_char, 2, symbol,
- b2tv(true));
-
- /* 15.1.? char-ready? */
- /* XXX: this always return #t, proper behaviour requires platform
- specific code (probably select for posix, a thread for windows
- (at least for files & consoles), I think pipes and sockets may
- have something */
- add_applicative(K, ground_env, "char-ready?", char_readyp, 0);
-
- /*
- ** 15.2 Library features
- */
-
- /* 15.2.1 call-with-input-file, call-with-output-file */
- add_applicative(K, ground_env, "call-with-input-file", call_with_file,
- 2, symbol, b2tv(false));
- add_applicative(K, ground_env, "call-with-output-file", call_with_file,
- 2, symbol, b2tv(true));
-
- /* 15.2.2 load */
- add_applicative(K, ground_env, "load", load, 0);
-
- /* 15.2.3 get-module */
- add_applicative(K, ground_env, "get-module", get_module, 0);
-
- /* 15.2.? display */
- add_applicative(K, ground_env, "display", display, 0);
-
- /* MAYBE: That's all there is in the report combined with r5rs scheme,
- but we will probably need: file-exists?, rename-file and remove-file.
- It would also be good to be able to select between append, truncate and
- error if a file exists, but that would need to be an option in all three
- methods of opening. Also some directory checking, traversing etc */
-
+ ** Initialize the combiners/vars for all supported modules
+ */
+ kinit_booleans_ground_env(K);
+ kinit_eqp_ground_env(K);
+ kinit_equalp_ground_env(K);
+ kinit_symbols_ground_env(K);
+ kinit_control_ground_env(K);
+ kinit_pairs_lists_ground_env(K);
+ kinit_pair_mut_ground_env(K);
+ kinit_environments_ground_env(K);
+ kinit_env_mut_ground_env(K);
+ kinit_combiners_ground_env(K);
+ kinit_continuations_ground_env(K);
+ kinit_encapsulations_ground_env(K);
+ kinit_promises_ground_env(K);
+ kinit_kgkd_vars_ground_env(K);
+ kinit_kgks_vars_ground_env(K);
+ kinit_numbers_ground_env(K);
+ kinit_strings_ground_env(K);
+ kinit_chars_ground_env(K);
+ kinit_ports_ground_env(K);
+
+ /*
+ ** Initialize the names of the continuation used in
+ ** the supported modules to aid in debugging/error msgs
+ */
+ /* MAYBE some/most/all of these could be done in each module */
kinit_cont_names(K);
-
- return;
}
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -420,37 +420,70 @@ void string_fillS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, KINERT);
}
-
-/* 13.3.1? symbol->string */
-/* The strings in symbols are immutable so we can just return that */
-void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+/* init ground */
+void kinit_strings_ground_env(klisp_State *K)
{
- UNUSED(xparams);
- UNUSED(denv);
- bind_1tp(K, ptree, "symbol", ttissymbol, sym);
- TValue str = ksymbol_str(sym);
- kapply_cc(K, str);
-}
-
-/* 13.3.2? string->symbol */
-/* TEMP: for now this can create symbols with no external representation
- this includes all symbols with non identifiers characters.
-*/
-/* NOTE:
- Symbols with uppercase alphabetic characters will write as lowercase and
- so, when read again will not compare as either eq? or equal?. This is ok
- because the report only says that read objects when written and read
- again must be equal? which happens here
-*/
-/* If the string is mutable it is copied */
-void string_to_symbol(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
-{
- UNUSED(xparams);
- UNUSED(denv);
- bind_1tp(K, ptree, "string", ttisstring, str);
- /* TODO si */
- TValue new_sym = ksymbol_new_check_i(K, str, KNIL);
- kapply_cc(K, new_sym);
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /*
+ ** This section is still missing from the report. The bindings here are
+ ** taken from r5rs scheme and should not be considered standard. They are
+ ** provided in the meantime to allow programs to use string features
+ ** (ASCII only).
+ */
+
+ /* 13.1.1? string? */
+ add_applicative(K, ground_env, "string?", typep, 2, symbol,
+ i2tv(K_TSTRING));
+ /* 13.1.2? make-string */
+ add_applicative(K, ground_env, "make-string", make_string, 0);
+ /* 13.1.3? string-length */
+ add_applicative(K, ground_env, "string-length", string_length, 0);
+ /* 13.1.4? string-ref */
+ add_applicative(K, ground_env, "string-ref", string_ref, 0);
+ /* 13.1.5? string-set! */
+ add_applicative(K, ground_env, "string-set!", string_setS, 0);
+ /* 13.2.1? string */
+ add_applicative(K, ground_env, "string", string, 0);
+ /* 13.2.2? string=?, string-ci=? */
+ add_applicative(K, ground_env, "string=?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_eqp));
+ add_applicative(K, ground_env, "string-ci=?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_ci_eqp));
+ /* 13.2.3? string<?, string<=?, string>?, string>=? */
+ add_applicative(K, ground_env, "string<?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_ltp));
+ add_applicative(K, ground_env, "string<=?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_lep));
+ add_applicative(K, ground_env, "string>?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_gtp));
+ add_applicative(K, ground_env, "string>=?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_gep));
+ /* 13.2.4? string-ci<?, string-ci<=?, string-ci>?, string-ci>=? */
+ add_applicative(K, ground_env, "string-ci<?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_ci_ltp));
+ add_applicative(K, ground_env, "string-ci<=?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_ci_lep));
+ add_applicative(K, ground_env, "string-ci>?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_ci_gtp));
+ add_applicative(K, ground_env, "string-ci>=?", ftyped_bpredp, 3,
+ symbol, p2tv(kstringp), p2tv(kstring_ci_gep));
+ /* 13.2.5? substring */
+ add_applicative(K, ground_env, "substring", substring, 0);
+ /* 13.2.6? string-append */
+ add_applicative(K, ground_env, "string-append", string_append, 0);
+ /* 13.2.7? string->list, list->string */
+ add_applicative(K, ground_env, "string->list", string_to_list, 0);
+ add_applicative(K, ground_env, "list->string", list_to_string, 0);
+ /* 13.2.8? string-copy */
+ add_applicative(K, ground_env, "string-copy", string_copy, 0);
+ /* 13.2.9? string->immutable-string */
+ add_applicative(K, ground_env, "string->immutable-string",
+ string_to_immutable_string, 0);
+
+ /* TODO: add string-immutable? or general immutable? */
+
+ /* 13.2.10? string-fill! */
+ add_applicative(K, ground_env, "string-fill!", string_fillS, 0);
}
diff --git a/src/kgstrings.h b/src/kgstrings.h
@@ -85,24 +85,10 @@ void string_to_immutable_string(klisp_State *K, TValue *xparams,
/* 13.2.10? string-fill! */
void string_fillS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
-/* 13.3.1? symbol->string */
-void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
-
-/* 13.3.2? string->symbol */
-/* TEMP: for now this can create symbols with no external representation
- this includes all symbols with non identifiers characters.
-*/
-/* NOTE:
- Symbols with uppercase alphabetic characters will write as lowercase and
- so, when read again will not compare as either eq? or equal?. This is ok
- because the report only says that read objects when written and read
- again must be equal? which happens here
-*/
-void string_to_symbol(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
-
/* Helpers */
bool kstringp(TValue obj);
+/* init ground */
+void kinit_strings_ground_env(klisp_State *K);
+
#endif
diff --git a/src/kgsymbols.c b/src/kgsymbols.c
@@ -24,3 +24,65 @@
/* 4.4.1 symbol? */
/* uses typep */
+
+/* 13.3.1? symbol->string */
+/* The strings in symbols are immutable so we can just return that */
+void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "symbol", ttissymbol, sym);
+ TValue str = ksymbol_str(sym);
+ kapply_cc(K, str);
+}
+
+/* 13.3.2? string->symbol */
+/* TEMP: for now this can create symbols with no external representation
+ this includes all symbols with non identifiers characters.
+*/
+/* NOTE:
+ Symbols with uppercase alphabetic characters will write as lowercase and
+ so, when read again will not compare as either eq? or equal?. This is ok
+ because the report only says that read objects when written and read
+ again must be equal? which happens here
+*/
+/* If the string is mutable it is copied */
+void string_to_symbol(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "string", ttisstring, str);
+ /* TODO si */
+ TValue new_sym = ksymbol_new_check_i(K, str, KNIL);
+ kapply_cc(K, new_sym);
+}
+
+/* init ground */
+void kinit_symbols_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* 4.4.1 symbol? */
+ add_applicative(K, ground_env, "symbol?", typep, 2, symbol,
+ i2tv(K_TSYMBOL));
+ /*
+ ** This section is still missing from the report. The bindings here are
+ ** taken from r5rs scheme and should not be considered standard.
+ */
+ /* ?.?.1? symbol->string */
+ add_applicative(K, ground_env, "symbol->string", symbol_to_string, 0);
+ /* ?.?.2? string->symbol */
+ /* TEMP: for now this can create symbols with no external representation
+ this includes all symbols with non identifiers characters.
+ */
+ /* NOTE:
+ Symbols with uppercase alphabetic characters will write as lowercase and
+ so, when read again will not compare as either eq? or equal?. This is ok
+ because the report only says that read objects when written and read
+ again must be equal? which happens here
+ */
+ add_applicative(K, ground_env, "string->symbol", string_to_symbol, 0);
+}
diff --git a/src/kgsymbols.h b/src/kgsymbols.h
@@ -21,4 +21,24 @@
/* 4.4.1 symbol? */
/* uses typep */
+/* ?.?.1? symbol->string */
+void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
+/* ?.?.2? string->symbol */
+/* TEMP: for now this can create symbols with no external representation
+ this includes all symbols with non identifiers characters.
+*/
+/* NOTE:
+ Symbols with uppercase alphabetic characters will write as lowercase and
+ so, when read again will not compare as either eq? or equal?. This is ok
+ because the report only says that read objects when written and read
+ again must be equal? which happens here
+*/
+void string_to_symbol(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
+/* init ground */
+void kinit_symbols_ground_env(klisp_State *K);
+
#endif
