commit 7469f9a2f14ee2a40c1d470bbd8c707b9f63897b
parent e859df58d8b166c487b00ce322dff629dce63af5
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 6 Mar 2011 21:26:44 -0300
Moved eval to a new file.
Diffstat:
5 files changed, 169 insertions(+), 135 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -9,7 +9,7 @@ MYLIBS=
CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kwrite.o kstate.o kmem.o kerror.o kauxlib.o kenvironment.o \
- kcontinuation.o koperative.o kapplicative.o
+ kcontinuation.o koperative.o kapplicative.o keval.o
KRN_T= klisp
KRN_O= klisp.o
@@ -54,3 +54,5 @@ kenvironment.o: kenvironment.c kenvironment.h kpair.h kobject.h kerror.h \
kcontinuation.o: kcontinuation.c kcontinuation.h kmem.h kstate.h kobject.h
koperative.o: koperative.c koperative.h kmem.h kstate.h kobject.h
kapplicative.o: kapplicative.c kapplicative.h kmem.h kstate.h kobject.h
+keval.o: keval.c keval.h kcontinuation.h kenvironment.h kstate.h kobject.h \
+ kpair.h kerror.h
+\ No newline at end of file
diff --git a/src/kenvironment.c b/src/kenvironment.c
@@ -77,7 +77,7 @@ TValue kget_binding(klisp_State *K, TValue env, TValue sym)
env = kenv_parents(K, env);
}
- klispE_throw_extra(K, "Unbound symbol ", ksymbol_buf(sym), true);
+ klispE_throw_extra(K, "Unbound symbol", ksymbol_buf(sym), true);
/* avoid warning */
return KINERT;
}
diff --git a/src/keval.c b/src/keval.c
@@ -0,0 +1,150 @@
+/*
+** keval.c
+** klisp eval function
+** See Copyright Notice in klisp.h
+*/
+
+#include "klisp.h"
+#include "kstate.h"
+#include "kobject.h"
+#include "kpair.h"
+#include "kenvironment.h"
+#include "kcontinuation.h"
+#include "kerror.h"
+
+/*
+** Eval helpers
+*/
+void eval_ls_cfn(klisp_State *K, TValue *xparams, TValue obj)
+{
+ /*
+ ** xparams[0]: this argument list pair
+ ** xparams[1]: dynamic environment
+ ** xparams[2]: first-cycle-pair/NIL
+ ** xparams[3]: combiner
+ */
+ TValue apair = xparams[0];
+ TValue rest = kcdr(apair);
+ TValue env = xparams[1];
+ TValue tail = xparams[2];
+ TValue combiner = xparams[3];
+
+ /* save the result of last evaluation and continue with next pair */
+ kset_car(apair, obj);
+ if (ttisnil(rest)) {
+ /* argument evaluation complete */
+ /* this is necessary to recreate the cycle in operand list */
+ kset_cdr(apair, tail);
+ kapply_cc(K, combiner);
+ } else {
+ /* more arguments need to be evaluated */
+ TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ &eval_ls_cfn, 4, rest, env,
+ tail, combiner);
+ kset_cc(K, new_cont);
+ ktail_call(K, K->eval_op, kcar(rest), env);
+ }
+}
+
+/* TODO: move this to another file, to use it elsewhere */
+inline void clear_ls_marks(TValue ls)
+{
+ while (ttispair(ls) && kis_marked(ls)) {
+ kunmark(ls);
+ ls = kcdr(ls);
+ }
+}
+
+/* operands should be a pair */
+inline TValue make_arg_ls(klisp_State *K, TValue operands, TValue *tail)
+{
+ TValue arg_ls = kcons(K, kcar(operands), KNIL);
+ TValue last_pair = arg_ls;
+ kset_mark(operands, last_pair);
+ TValue rem_op = kcdr(operands);
+
+ while(ttispair(rem_op) && kis_unmarked(rem_op)) {
+ TValue new_pair = kcons(K, kcar(rem_op), KNIL);
+ kset_mark(rem_op, new_pair);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ rem_op = kcdr(rem_op);
+ }
+
+ if (ttispair(rem_op)) {
+ /* cyclical list */
+ *tail = kget_mark(rem_op);
+ } else if (ttisnil(rem_op)) {
+ *tail = KNIL;
+ } else {
+ clear_ls_marks(operands);
+ klispE_throw(K, "Not a list in applicative combination", true);
+ return KINERT;
+ }
+ clear_ls_marks(operands);
+ return arg_ls;
+}
+
+void combine_cfn(klisp_State *K, TValue *xparams, TValue obj)
+{
+ /*
+ ** xparams[0]: operand list
+ ** xparams[1]: dynamic environment
+ */
+ TValue operands = xparams[0];
+ TValue env = xparams[1];
+
+ switch(ttype(obj)) {
+ case K_TAPPLICATIVE: {
+ if (ttisnil(operands)) {
+ /* no arguments => no evaluation, just call the operative */
+ /* NOTE: the while is needed because it may be multiply wrapped */
+ while(ttisapplicative(obj))
+ obj = tv2app(obj)->underlying;
+ ktail_call(K, obj, operands, env);
+ } else if (ttispair(operands)) {
+ /* make a copy of the operands (for storing arguments) */
+ TValue tail;
+ TValue arg_ls = make_arg_ls(K, operands, &tail);
+
+ TValue comb_cont = kmake_continuation(
+ K, kget_cc(K), KNIL, KNIL, &combine_cfn, 2, arg_ls, env);
+
+ TValue els_cont = kmake_continuation(
+ K, comb_cont, KNIL, KNIL, &eval_ls_cfn,
+ 4, arg_ls, env, tail, tv2app(obj)->underlying);
+ kset_cc(K, els_cont);
+ ktail_call(K, K->eval_op, kcar(arg_ls), env);
+ }
+ }
+ case K_TOPERATIVE:
+ ktail_call(K, obj, operands, env);
+ default:
+ klispE_throw(K, "Not a combiner in combiner position", true);
+ return;
+ }
+}
+
+/* the underlying function of the eval operative */
+void keval_ofn(klisp_State *K, TValue *xparams, TValue obj, TValue env)
+{
+ (void) xparams;
+
+ switch(ttype(obj)) {
+ case K_TPAIR: {
+ TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ &combine_cfn, 2, kcdr(obj), env);
+ kset_cc(K, new_cont);
+ ktail_call(K, K->eval_op, kcar(obj), env);
+ break;
+ }
+ case K_TSYMBOL:
+ /* error handling happens in kget_binding */
+ kapply_cc(K, kget_binding(K, env, obj));
+ break;
+ default:
+ kapply_cc(K, obj);
+ }
+}
+
+
diff --git a/src/keval.h b/src/keval.h
@@ -0,0 +1,12 @@
+/*
+** keval.h
+** klisp eval function
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef keval_h
+#define keval_h
+
+void keval_ofn(klisp_State *K, TValue *xparams, TValue obj, TValue env);
+
+#endif
diff --git a/src/klisp.c b/src/klisp.c
@@ -20,6 +20,7 @@
#include "kstate.h"
#include "kread.h"
#include "kwrite.h"
+#include "keval.h"
#include "kcontinuation.h"
#include "kenvironment.h"
@@ -41,139 +42,7 @@ void exit_fn(klisp_State *K, TValue *xparams, TValue obj)
return;
}
-/* eval helpers */
-void eval_ls_cfn(klisp_State *K, TValue *xparams, TValue obj)
-{
- /*
- ** xparams[0]: this argument list pair
- ** xparams[1]: dynamic environment
- ** xparams[2]: first-cycle-pair/NIL
- ** xparams[3]: combiner
- */
- TValue apair = xparams[0];
- TValue rest = kcdr(apair);
- TValue env = xparams[1];
- TValue tail = xparams[2];
- TValue combiner = xparams[3];
-
- /* save the result of last evaluation and continue with next pair */
- kset_car(apair, obj);
- if (ttisnil(rest)) {
- /* argument evaluation complete */
- /* this is necessary to recreate the cycle in operand list */
- kset_cdr(apair, tail);
- kapply_cc(K, combiner);
- } else {
- /* more arguments need to be evaluated */
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
- &eval_ls_cfn, 4, rest, env,
- tail, combiner);
- kset_cc(K, new_cont);
- ktail_call(K, K->eval_op, kcar(rest), env);
- }
-}
-
-inline void clear_ls_marks(TValue ls)
-{
- while (ttispair(ls) && kis_marked(ls)) {
- kunmark(ls);
- ls = kcdr(ls);
- }
-}
-
-/* operands should be a pair */
-inline TValue make_arg_ls(klisp_State *K, TValue operands, TValue *tail)
-{
- TValue arg_ls = kcons(K, kcar(operands), KNIL);
- TValue last_pair = arg_ls;
- kset_mark(operands, last_pair);
- TValue rem_op = kcdr(operands);
-
- while(ttispair(rem_op) && kis_unmarked(rem_op)) {
- TValue new_pair = kcons(K, kcar(rem_op), KNIL);
- kset_mark(rem_op, new_pair);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- rem_op = kcdr(rem_op);
- }
-
- if (ttispair(rem_op)) {
- /* cyclical list */
- *tail = kget_mark(rem_op);
- } else if (ttisnil(rem_op)) {
- *tail = KNIL;
- } else {
- clear_ls_marks(operands);
- klispE_throw(K, "Not a list in applicative combination", true);
- return KINERT;
- }
- clear_ls_marks(operands);
- return arg_ls;
-}
-
-void combine_cfn(klisp_State *K, TValue *xparams, TValue obj)
-{
- /*
- ** xparams[0]: operand list
- ** xparams[1]: dynamic environment
- */
- TValue operands = xparams[0];
- TValue env = xparams[1];
-
- switch(ttype(obj)) {
- case K_TAPPLICATIVE: {
- if (ttisnil(operands)) {
- /* no arguments => no evaluation, just call the operative */
- /* NOTE: the while is needed because it may be multiply wrapped */
- while(ttisapplicative(obj))
- obj = tv2app(obj)->underlying;
- ktail_call(K, obj, operands, env);
- } else if (ttispair(operands)) {
- /* make a copy of the operands (for storing arguments) */
- TValue tail;
- TValue arg_ls = make_arg_ls(K, operands, &tail);
-
- TValue comb_cont = kmake_continuation(
- K, kget_cc(K), KNIL, KNIL, &combine_cfn, 2, arg_ls, env);
-
- TValue els_cont = kmake_continuation(
- K, comb_cont, KNIL, KNIL, &eval_ls_cfn,
- 4, arg_ls, env, tail, tv2app(obj)->underlying);
- kset_cc(K, els_cont);
- ktail_call(K, K->eval_op, kcar(arg_ls), env);
- }
- }
- case K_TOPERATIVE:
- ktail_call(K, obj, operands, env);
- default:
- klispE_throw(K, "Not a combiner in combiner position", true);
- return;
- }
-}
-
/* the underlying function of the eval cont */
-void eval_ofn(klisp_State *K, TValue *xparams, TValue obj, TValue env)
-{
- (void) xparams;
-
- switch(ttype(obj)) {
- case K_TPAIR: {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
- &combine_cfn, 2, kcdr(obj), env);
- kset_cc(K, new_cont);
- ktail_call(K, K->eval_op, kcar(obj), env);
- break;
- }
- case K_TSYMBOL:
- /* error handling happens in kget_binding */
- kapply_cc(K, kget_binding(K, env, obj));
- break;
- default:
- kapply_cc(K, obj);
- }
-}
-
-/* the underlying function of the eval operative */
void eval_cfn(klisp_State *K, TValue *xparams, TValue obj)
{
/*
@@ -267,7 +136,7 @@ int main(int argc, char *argv[])
klisp_State *K = klispL_newstate();
/* set up the continuations */
- K->eval_op = kmake_operative(K, KNIL, KNIL, eval_ofn, 0);
+ K->eval_op = kmake_operative(K, KNIL, KNIL, keval_ofn, 0);
TValue ground_env = kmake_empty_environment(K);
TValue g_define = kmake_operative(K, KNIL, KNIL, def_ofn, 0);
