commit 8fcae1880075ee63492dc1dff4e623ffce0cf89f
parent 7f0c0edec457fc1c374b5e5ef105cd2ba6b2d801
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 13 Mar 2011 02:39:35 -0300
Extracted out the combiners features from kground.c to a new file kgcombiners.c (and .h).
Diffstat:
| M | src/Makefile | | | 11 | +++++++---- |
| A | src/kgcombiners.c | | | 159 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/kgcombiners.h | | | 50 | ++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | src/kground.c | | | 170 | +------------------------------------------------------------------------------ |
4 files changed, 217 insertions(+), 173 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -12,7 +12,7 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kcontinuation.o koperative.o kapplicative.o keval.o krepl.o \
kground.o kghelpers.o kgbooleans.o kgeqp.o kgequalp.o \
kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o kgenvironments.o \
- kgenv_mut.o
+ kgenv_mut.o kgcombiners.o
KRN_T= klisp
KRN_O= klisp.o
@@ -68,9 +68,9 @@ keval.o: keval.c keval.h kcontinuation.h kenvironment.h kstate.h kobject.h \
krepl.o: krepl.c krepl.h kcontinuation.h kstate.h kobject.h keval.h klisp.h \
kread.h kwrite.h kenvironment.h
kground.o: kground.c kground.h kstate.h kobject.h klisp.h kenvironment.h \
- kpair.h kapplicative.h koperative.h ksymbol.h kerror.h kghelpers.h \
+ kapplicative.h koperative.h ksymbol.h kerror.h kghelpers.h \
kgbooleans.h kgeqp.h kgequalp.h kgsymbols.h kgpairs_lists.h \
- kgpair_mut.h kgenvironments.h kgenv_mut.h
+ kgpair_mut.h kgenvironments.h kgenv_mut.h kgcombiners.h
kghelpers.o: kghelpers.c kghelpers.h kstate.h kstate.h klisp.h kpair.h \
kapplicative.h koperative.h kerror.h kobject.h ksymbol.h
kgbooleans.o: kgbooleans.c kgbooleans.c kghelpers.h kstate.h klisp.h \
@@ -90,6 +90,9 @@ kgpair_mut.o: kgpair_mut.c kgpair_mut.h kghelpers.h kstate.h klisp.h \
kgenvironments.o: kgenvironments.c kgenvironments.h kghelpers.h kstate.h \
klisp.h kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h \
kenvironment.h
-kgenv_mut.o: kgenvironments.c kgenvironments.h kghelpers.h kstate.h \
+kgenv_mut.o: kgenv_mut.c kgenv_mut.h kghelpers.h kstate.h \
klisp.h kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h \
kenvironment.h
+kgcombiners.o: kgcombiners.c kgenvironments.h kghelpers.h kstate.h \
+ klisp.h kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h \
+ kenvironment.h kapplicative.h koperative.h
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -0,0 +1,159 @@
+/*
+** kgcombiners.c
+** Combiners features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "kpair.h"
+#include "kenvironment.h"
+#include "kcontinuation.h"
+#include "ksymbol.h"
+#include "koperative.h"
+#include "kapplicative.h"
+#include "kerror.h"
+
+#include "kghelpers.h"
+#include "kgpair_mut.h" /* for copy_es_immutable_h */
+#include "kgenv_mut.h" /* for match */
+#include "kgcontrol.h" /* for do_seq */
+#include "kgcombiners.h"
+
+/* Helper (used by $vau & $lambda) */
+void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv);
+
+/* 4.10.1 operative? */
+/* uses typep */
+
+/* 4.10.2 applicative? */
+/* uses typep */
+
+/* 4.10.3 $vau */
+/* 5.3.1 $vau */
+void Svau(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ (void) xparams;
+ bind_al2p(K, "$vau", ptree, vptree, vpenv, vbody);
+
+ /* The ptree & body are copied to avoid mutation */
+ vptree = check_copy_ptree(K, "$vau", vptree, vpenv);
+ /* the body should be a list */
+ (void)check_list(K, "$vau", vbody);
+ vbody = copy_es_immutable_h(K, "$vau", vbody);
+
+ TValue new_op = make_operative(K, do_vau, 4, vptree, vpenv, vbody, denv);
+ kapply_cc(K, new_op);
+}
+
+void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv)
+{
+ /*
+ ** xparams[0]: ptree
+ ** xparams[1]: penv
+ ** xparams[2]: body
+ ** xparams[3]: senv
+ */
+ TValue ptree = xparams[0];
+ TValue penv = xparams[1];
+ TValue body = xparams[2];
+ TValue senv = xparams[3];
+
+ /* bindings in an operative are in a child of the static env */
+ TValue env = kmake_environment(K, senv);
+ /* TODO use name from operative */
+ match(K, "[user-operative]", env, ptree, obj);
+ kadd_binding(K, env, penv, denv);
+
+ if (ttisnil(body)) {
+ kapply_cc(K, KINERT);
+ } else {
+ /* this is needed because seq continuation doesn't check for
+ nil sequence */
+ TValue tail = kcdr(body);
+ if (ttispair(tail)) {
+ TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ do_seq, 2, tail, env);
+ kset_cc(K, new_cont);
+ }
+ ktail_eval(K, kcar(body), env);
+ }
+}
+
+/* 4.10.4 wrap */
+void wrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ (void) denv;
+ (void) xparams;
+ bind_1tp(K, "wrap", ptree, "combiner", ttiscombiner, comb);
+ TValue new_app = kwrap(K, comb);
+ kapply_cc(K, new_app);
+}
+
+/* 4.10.5 unwrap */
+void unwrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ (void) denv;
+ (void) xparams;
+ bind_1tp(K, "unwrap", ptree, "applicative", ttisapplicative, app);
+ TValue underlying = kunwrap(K, app);
+ kapply_cc(K, underlying);
+}
+
+/* 5.3.1 $vau */
+/* DONE: above, together with 4.10.4 */
+
+/* 5.3.2 $lambda */
+void Slambda(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ (void) xparams;
+ bind_al2p(K, "$lambda", ptree, vptree, vpenv, vbody);
+
+ /* The ptree & body are copied to avoid mutation */
+ vptree = check_copy_ptree(K, "$lambda", vptree, vpenv);
+ /* the body should be a list */
+ (void)check_list(K, "$lambda", vbody);
+ vbody = copy_es_immutable_h(K, "$lambda", vbody);
+
+ TValue new_app = make_applicative(K, do_vau, 4, vptree, vpenv, vbody, denv);
+ kapply_cc(K, new_app);
+}
+
+/* 5.5.1 apply */
+void apply(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ (void) denv;
+ (void) xparams;
+ bind_al2p(K, "apply", ptree, app, obj, maybe_env);
+
+ if(!ttisapplicative(app)) {
+ klispE_throw(K, "apply: Bad type on first argument "
+ "(expected applicative)");
+ return;
+ }
+ TValue env;
+ /* TODO move to an inlinable function */
+ if (ttisnil(maybe_env)) {
+ env = kmake_empty_environment(K);
+ } else if (ttispair(maybe_env) && ttisnil(kcdr(maybe_env))) {
+ env = kcar(maybe_env);
+ if (!ttisenvironment(env)) {
+ klispE_throw(K, "apply: Bad type on optional argument "
+ "(expected environment)");
+ }
+ } else {
+ klispE_throw(K, "apply: Bad ptree structure (in optional argument)");
+ }
+ TValue expr = kcons(K, kunwrap(K, app), obj);
+ ktail_eval(K, expr, env);
+}
+
+/* 5.9.1 map */
+/* TODO */
diff --git a/src/kgcombiners.h b/src/kgcombiners.h
@@ -0,0 +1,50 @@
+/*
+** kgcombiners.h
+** Combiners features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgcombiners_h
+#define kgcombiners_h
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kobject.h"
+#include "klisp.h"
+#include "kstate.h"
+#include "kghelpers.h"
+
+/* 4.10.1 operative? */
+/* uses typep */
+
+/* 4.10.2 applicative? */
+/* uses typep */
+
+/* 4.10.3 $vau */
+/* 5.3.1 $vau */
+void Svau(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 4.10.4 wrap */
+void wrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 4.10.5 unwrap */
+void unwrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 5.3.1 $vau */
+/* DONE: above, together with 4.10.4 */
+
+/* 5.3.2 $lambda */
+void Slambda(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 5.5.1 apply */
+void apply(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
+/* 5.9.1 map */
+/* TODO */
+
+#endif
diff --git a/src/kground.c b/src/kground.c
@@ -13,10 +13,7 @@
#include "kstate.h"
#include "kobject.h"
#include "kground.h"
-#include "kpair.h"
-#include "kstring.h"
#include "kenvironment.h"
-#include "kcontinuation.h"
#include "ksymbol.h"
#include "koperative.h"
#include "kapplicative.h"
@@ -32,167 +29,7 @@
#include "kgpair_mut.h"
#include "kgenvironments.h"
#include "kgenv_mut.h"
-
-/*
-** This section will roughly follow the report and will reference the
-** section in which each symbol is defined
-*/
-/* TODO: split in different files for each module */
-
-/*
-** 4.10 Combiners
-*/
-
-/* 4.10.1 operative? */
-/* uses typep */
-
-/* 4.10.2 applicative? */
-/* uses typep */
-
-/* 4.10.3 $vau */
-/* 5.3.1 $vau */
-
-/* Helper (also used by $lambda) */
-void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv);
-
-void Svau(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- (void) xparams;
- bind_al2p(K, "$vau", ptree, vptree, vpenv, vbody);
-
- /* The ptree & body are copied to avoid mutation */
- vptree = check_copy_ptree(K, "$vau", vptree, vpenv);
- /* the body should be a list */
- (void)check_list(K, "$vau", vbody);
- vbody = copy_es_immutable_h(K, "$vau", vbody);
-
- TValue new_op = make_operative(K, do_vau, 4, vptree, vpenv, vbody, denv);
- kapply_cc(K, new_op);
-}
-
-void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv)
-{
- /*
- ** xparams[0]: ptree
- ** xparams[1]: penv
- ** xparams[2]: body
- ** xparams[3]: senv
- */
- TValue ptree = xparams[0];
- TValue penv = xparams[1];
- TValue body = xparams[2];
- TValue senv = xparams[3];
-
- /* bindings in an operative are in a child of the static env */
- TValue env = kmake_environment(K, senv);
- /* TODO use name from operative */
- match(K, "[user-operative]", env, ptree, obj);
- kadd_binding(K, env, penv, denv);
-
- if (ttisnil(body)) {
- kapply_cc(K, KINERT);
- } else {
- /* this is needed because seq continuation doesn't check for
- nil sequence */
- TValue tail = kcdr(body);
- if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
- do_seq, 2, tail, env);
- kset_cc(K, new_cont);
- }
- ktail_eval(K, kcar(body), env);
- }
-}
-
-/* 4.10.4 wrap */
-void wrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- (void) denv;
- (void) xparams;
- bind_1tp(K, "wrap", ptree, "combiner", ttiscombiner, comb);
- TValue new_app = kwrap(K, comb);
- kapply_cc(K, new_app);
-}
-
-/* 4.10.5 unwrap */
-void unwrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- (void) denv;
- (void) xparams;
- bind_1tp(K, "unwrap", ptree, "applicative", ttisapplicative, app);
- TValue underlying = kunwrap(K, app);
- kapply_cc(K, underlying);
-}
-
-/*
-**
-** 5 Core library features (I)
-**
-*/
-
-/*
-** 5.3 Combiners
-*/
-
-/* 5.3.1 $vau */
-/* DONE: above, together with 4.10.4 */
-
-/* 5.3.2 $lambda */
-void Slambda(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- (void) xparams;
- bind_al2p(K, "$lambda", ptree, vptree, vpenv, vbody);
-
- /* The ptree & body are copied to avoid mutation */
- vptree = check_copy_ptree(K, "$lambda", vptree, vpenv);
- /* the body should be a list */
- (void)check_list(K, "$lambda", vbody);
- vbody = copy_es_immutable_h(K, "$lambda", vbody);
-
- TValue new_app = make_applicative(K, do_vau, 4, vptree, vpenv, vbody, denv);
- kapply_cc(K, new_app);
-}
-
-/*
-** 5.5 Combiners
-*/
-
-/* 5.5.1 apply */
-void apply(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
-{
- (void) denv;
- (void) xparams;
- bind_al2p(K, "apply", ptree, app, obj, maybe_env);
-
- if(!ttisapplicative(app)) {
- klispE_throw(K, "apply: Bad type on first argument "
- "(expected applicative)");
- return;
- }
- TValue env;
- /* TODO move to an inlinable function */
- if (ttisnil(maybe_env)) {
- env = kmake_empty_environment(K);
- } else if (ttispair(maybe_env) && ttisnil(kcdr(maybe_env))) {
- env = kcar(maybe_env);
- if (!ttisenvironment(env)) {
- klispE_throw(K, "apply: Bad type on optional argument "
- "(expected environment)");
- }
- } else {
- klispE_throw(K, "apply: Bad ptree structure (in optional argument)");
- }
- TValue expr = kcons(K, kunwrap(K, app), obj);
- ktail_eval(K, expr, env);
-}
-
-/*
-** 5.9 Combiners
-*/
-
-/* 5.9.1 map */
-/* TODO */
+#include "kgcombiners.h"
/*
** BEWARE: this is highly unhygienic, it assumes variables "symbol" and
@@ -218,11 +55,6 @@ TValue kmake_ground_env(klisp_State *K)
TValue symbol, value;
- /*
- ** TODO: this pattern could be abstracted away with a
- ** non-hygienic macro (that inserted names "symbol" and "value")
- */
-
/*
** This section will roughly follow the report and will reference the
** section in which each symbol is defined
