commit e859df58d8b166c487b00ce322dff629dce63af5
parent c9bda1d52762c113481d855f395f3c41170367c3
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 6 Mar 2011 02:05:48 -0300
Added applicatives and their rule of evaluation. eval is, more or less, complete.
Diffstat:
5 files changed, 170 insertions(+), 10 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
+ kcontinuation.o koperative.o kapplicative.o
KRN_T= klisp
KRN_O= klisp.o
@@ -34,7 +34,8 @@ clean:
.PHONY: all default o clean
klisp.o: klisp.c klisp.h kobject.h kread.h kwrite.h klimits.h kstate.h kmem.h \
- kerror.h kauxlib.h koperative.h kenvironment.h kcontinuation.h
+ kerror.h kauxlib.h koperative.h kenvironment.h kcontinuation.h \
+ kapplicative.h koperative.h
kobject.o: kobject.c kobject.h
ktoken.o: ktoken.c ktoken.h kobject.h kstate.h kpair.h kstring.h ksymbol.h \
kerror.h
@@ -52,3 +53,4 @@ kenvironment.o: kenvironment.c kenvironment.h kpair.h kobject.h kerror.h \
kmem.h kstate.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
diff --git a/src/kapplicative.c b/src/kapplicative.c
@@ -0,0 +1,28 @@
+/*
+** kapplicative.c
+** Kernel Applicatives
+** See Copyright Notice in klisp.h
+*/
+
+#include "kobject.h"
+#include "kstate.h"
+#include "kapplicative.h"
+#include "kmem.h"
+
+TValue kwrap(klisp_State *K, TValue underlying)
+{
+ return kmake_applicative(K, KNIL, KNIL, underlying);
+}
+
+TValue kmake_applicative(klisp_State *K, TValue name, TValue si,
+ TValue underlying)
+{
+ Applicative *new_app = klispM_new(K, Applicative);
+ new_app->next = NULL;
+ new_app->gct = 0;
+ new_app->tt = K_TAPPLICATIVE;
+ new_app->name = name;
+ new_app->si = si;
+ new_app->underlying = underlying;
+ return gc2app(new_app);
+}
diff --git a/src/kapplicative.h b/src/kapplicative.h
@@ -0,0 +1,17 @@
+/*
+** kapplicative.h
+** Kernel Applicatives
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kapplicative_h
+#define kapplicative_h
+
+#include "kobject.h"
+#include "kstate.h"
+
+TValue kwrap(klisp_State *K, TValue underlying);
+TValue kmake_applicative(klisp_State *K, TValue name, TValue si,
+ TValue underlying);
+
+#endif
diff --git a/src/klisp.c b/src/klisp.c
@@ -24,6 +24,7 @@
#include "kcontinuation.h"
#include "kenvironment.h"
#include "koperative.h"
+#include "kapplicative.h"
#include "kpair.h"
#include "ksymbol.h"
#include "kerror.h"
@@ -40,24 +41,110 @@ void exit_fn(klisp_State *K, TValue *xparams, TValue obj)
return;
}
-/* eval helper */
+/* 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)
{
/*
- ** tparams[0]: operand list
- ** tparams[1]: dynamic environment
+ ** xparams[0]: operand list
+ ** xparams[1]: dynamic environment
*/
TValue operands = xparams[0];
TValue env = xparams[1];
switch(ttype(obj)) {
- case K_TAPPLICATIVE:
- /* TODO */
- kapply_cc(K, KINERT);
- break;
+ 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);
- break;
default:
klispE_throw(K, "Not a combiner in combiner position", true);
return;
@@ -141,6 +228,7 @@ void match_cfn(klisp_State *K, TValue *xparams, TValue obj)
/* the underlying function of a simple define */
void def_ofn(klisp_State *K, TValue *xparams, TValue obj, TValue env)
{
+ (void) xparams;
if (!ttispair(obj) || !ttispair(kcdr(obj)) || !ttisnil(kcdr(kcdr(obj)))) {
klispE_throw(K, "Bad syntax ($define!)", true);
return;
@@ -159,6 +247,19 @@ void def_ofn(klisp_State *K, TValue *xparams, TValue obj, TValue env)
}
}
+/* the underlying function of cons */
+void cons_ofn(klisp_State *K, TValue *xparams, TValue obj, TValue env)
+{
+ if (!ttispair(obj) || !ttispair(kcdr(obj)) || !ttisnil(kcdr(kcdr(obj)))) {
+ klispE_throw(K, "Bad syntax (cons)", true);
+ return;
+ }
+ TValue car = kcar(obj);
+ TValue cdr = kcar(kcdr(obj));
+ TValue new_pair = kcons(K, car, cdr);
+ kapply_cc(K, new_pair);
+}
+
int main(int argc, char *argv[])
{
printf("Read/Write Test\n");
@@ -168,9 +269,15 @@ int main(int argc, char *argv[])
/* set up the continuations */
K->eval_op = kmake_operative(K, KNIL, KNIL, eval_ofn, 0);
TValue ground_env = kmake_empty_environment(K);
+
TValue g_define = kmake_operative(K, KNIL, KNIL, def_ofn, 0);
TValue s_define = ksymbol_new(K, "$define!");
kadd_binding(K, ground_env, s_define, g_define);
+
+ TValue g_cons = kwrap(K, kmake_operative(K, KNIL, KNIL, cons_ofn, 0));
+ TValue s_cons = ksymbol_new(K, "cons");
+ kadd_binding(K, ground_env, s_cons, g_cons);
+
TValue std_env = kmake_environment(K, ground_env);
TValue root_cont = kmake_continuation(K, KNIL, KNIL, KNIL,
exit_fn, 0);
diff --git a/src/kobject.h b/src/kobject.h
@@ -178,6 +178,10 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttisstring(o) (tbasetype_(o) == K_TAG_STRING)
#define ttissymbol(o) (tbasetype_(o) == K_TAG_SYMBOL)
#define ttispair(o) (tbasetype_(o) == K_TAG_PAIR)
+#define ttisoperative(o) (tbasetype_(o) == K_TAG_OPERATIVE)
+#define ttisapplicative(o) (tbasetype_(o) == K_TAG_APPLICATIVE)
+#define ttisenvironment(o) (tbasetype_(o) == K_TAG_ENVIRONMENT)
+#define ttiscontinuation(o) (tbasetype_(o) == K_TAG_CONTINUATION)
/*
@@ -357,6 +361,7 @@ const TValue keminf;
#define gc2env(o_) (gc2tv(K_TAG_ENVIRONMENT, o_))
#define gc2cont(o_) (gc2tv(K_TAG_CONTINUATION, o_))
#define gc2op(o_) (gc2tv(K_TAG_OPERATIVE, o_))
+#define gc2app(o_) (gc2tv(K_TAG_APPLICATIVE, o_))
/* Macro to convert a TValue into a specific heap allocated object */
#define tv2pair(v_) ((Pair *) gcvalue(v_))
@@ -365,6 +370,7 @@ const TValue keminf;
#define tv2env(v_) ((Environment *) gcvalue(v_))
#define tv2cont(v_) ((Continuation *) gcvalue(v_))
#define tv2op(v_) ((Operative *) gcvalue(v_))
+#define tv2app(v_) ((Applicative *) gcvalue(v_))
#define tv2mgch(v_) ((MGCheader *) gcvalue(v_))
