commit 5b3a758e511562b8c6fe34ae427f1791945f829f
parent 9143e35a925a81608a1e229924ff8c2ced82ff85
Author: Andres Navarro <canavarro82@gmail.com>
Date: Wed, 16 Mar 2011 02:29:30 -0300
Added make-encapsulation-type to the ground environment.
Diffstat:
8 files changed, 159 insertions(+), 13 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -10,9 +10,10 @@ 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 keval.o krepl.o \
+ kencapsulation.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 kgcombiners.o kgcontinuations.o kencapsulation.o
+ kgenv_mut.o kgcombiners.o kgcontinuations.o kgencapsulations.o
KRN_T= klisp
KRN_O= klisp.o
@@ -73,7 +74,7 @@ kground.o: kground.c kground.h kstate.h kobject.h klisp.h kenvironment.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 kgcombiners.h \
- kgcontinuations.h
+ kgcontinuations.h kgencapsulations.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 \
diff --git a/src/kencapsulation.c b/src/kencapsulation.c
@@ -35,12 +35,3 @@ TValue kmake_encapsulation_key(klisp_State *K)
{
return kcons(K, KINERT, KINERT);
}
-
-bool kis_encapsulation_type(klisp_State *K, TValue enc, TValue key)
-{
- return ttisencapsulation(enc) && tv_equal(kget_enc_key(enc), key);
-}
-
-#define kget_enc_val(e_)(tv2enc(e_)->value)
-#define kget_enc_key(e_)(tv2enc(e_)->key)
-
diff --git a/src/kencapsulation.h b/src/kencapsulation.h
@@ -13,9 +13,15 @@
TValue kmake_encapsulation(klisp_State *K, TValue name, TValue si,
TValue key, TValue val);
TValue kmake_encapsulation_key(klisp_State *K);
-bool kis_encapsulation_type(klisp_State *K, TValue enc, TValue key);
+inline bool kis_encapsulation_type(TValue enc, TValue key);
#define kget_enc_val(e_)(tv2enc(e_)->value)
#define kget_enc_key(e_)(tv2enc(e_)->key)
+inline bool kis_encapsulation_type(TValue enc, TValue key)
+{
+ return ttisencapsulation(enc) && tv_equal(kget_enc_key(enc), key);
+}
+
+
#endif
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -1,5 +1,5 @@
/*
-** kgcontinuations.h
+** kgcontinuations.c
** Continuations features for the ground environment
** See Copyright Notice in klisp.h
*/
diff --git a/src/kgencapsulations.c b/src/kgencapsulations.c
@@ -0,0 +1,104 @@
+/*
+** kgencapsulations.c
+** Encapsulations 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 "kencapsulation.h"
+#include "kapplicative.h"
+#include "koperative.h"
+#include "kerror.h"
+
+#include "kghelpers.h"
+#include "kgencapsulations.h"
+
+/* Helpers for make-encapsulation-type */
+
+/* Type predicate for encapsulations */
+void enc_typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: encapsulation key
+ */
+ TValue key = xparams[0];
+
+ /* check the ptree is a list while checking the predicate.
+ Keep going even if the result is false to catch errors in
+ ptree structure */
+ bool res = true;
+
+ TValue tail = ptree;
+ while(ttispair(tail) && kis_unmarked(tail)) {
+ kmark(tail);
+ res &= kis_encapsulation_type(kcar(tail), key);
+ tail = kcdr(tail);
+ }
+ unmark_list(K, ptree);
+
+ if (ttispair(tail) || ttisnil(tail)) {
+ kapply_cc(K, b2tv(res));
+ } else {
+ /* try to get name from encapsulation */
+ klispE_throw(K, "encapsulation?: expected list");
+ return;
+ }
+}
+
+/* Constructor for encapsulations */
+void enc_wrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ bind_1p(K, "encapsulate", ptree, obj);
+ UNUSED(denv);
+ /*
+ ** xparams[0]: encapsulation key
+ */
+ TValue key = xparams[0];
+ TValue enc = kmake_encapsulation(K, KNIL, KNIL, key, obj);
+ kapply_cc(K, enc);
+}
+
+/* Accessor for encapsulations */
+void enc_unwrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ bind_1p(K, "decapsulate", ptree, enc);
+ UNUSED(denv);
+ /*
+ ** xparams[0]: encapsulation key
+ */
+ TValue key = xparams[0];
+
+ if (!kis_encapsulation_type(enc, key)) {
+ klispE_throw(K, "decapsulate: object doesn't belong to this "
+ "encapsulation type");
+ return;
+ }
+ TValue obj = kget_enc_val(enc);
+ kapply_cc(K, obj);
+}
+
+/* 8.1.1 make-encapsulation-type */
+void make_encapsulation_type(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ check_0p(K, "make-encapsulation-type", ptree);
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ /* GC: root intermediate values & pairs */
+ TValue key = kmake_encapsulation_key(K);
+ TValue e = make_applicative(K, enc_wrap, 1, key);
+ TValue p = make_applicative(K, enc_typep, 1, key);
+ TValue d = make_applicative(K, enc_unwrap, 1, key);
+
+ TValue ls = kcons(K, e, kcons(K, p, kcons(K, d, KNIL)));
+ kapply_cc(K, ls);
+}
diff --git a/src/kgencapsulations.h b/src/kgencapsulations.h
@@ -0,0 +1,25 @@
+/*
+** kgencapsulations.h
+** Encapsulations features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgencapsulations_h
+#define kgencapsulations_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"
+
+/* 8.1.1 make-encapsulation-type */
+void make_encapsulation_type(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
+#endif
diff --git a/src/kground.c b/src/kground.c
@@ -31,6 +31,7 @@
#include "kgenv_mut.h"
#include "kgcombiners.h"
#include "kgcontinuations.h"
+#include "kgencapsulations.h"
/*
** BEWARE: this is highly unhygienic, it assumes variables "symbol" and
@@ -396,5 +397,20 @@ void kinit_ground_env(klisp_State *K)
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);
+
return;
}
diff --git a/src/kstate.c b/src/kstate.c
@@ -454,6 +454,9 @@ void klisp_close (klisp_State *K)
case K_TAPPLICATIVE:
klispM_free(K, (Applicative *)obj);
break;
+ case K_TENCAPSULATION:
+ klispM_free(K, (Encapsulation *)obj);
+ break;
default:
/* shouldn't happen */
fprintf(stderr, "Unknown GCObject type: %d\n", type);
