klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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:
Msrc/Makefile | 5+++--
Msrc/kencapsulation.c | 9---------
Msrc/kencapsulation.h | 8+++++++-
Msrc/kgcontinuations.c | 2+-
Asrc/kgencapsulations.c | 104+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/kgencapsulations.h | 25+++++++++++++++++++++++++
Msrc/kground.c | 16++++++++++++++++
Msrc/kstate.c | 3+++
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);