klisp

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

commit 5a8890a93f3003e9392a9b97c55c3c01cceeda44
parent 22162e9dd6f4ce2fad52ba10f4312a343d9f368f
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Tue,  8 Mar 2011 20:52:03 -0300

Added generalized ptrees (with all the checks) to $define!. ptree copying pending.

Diffstat:
Msrc/kground.c | 202++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---------
Msrc/kobject.h | 7+++++++
2 files changed, 187 insertions(+), 22 deletions(-)

diff --git a/src/kground.c b/src/kground.c @@ -1,10 +1,13 @@ /* -** kground.h +** kground.c ** Bindings in the ground environment ** See Copyright Notice in klisp.h */ /* TODO: split in different files for each module */ + +#include <assert.h> + #include "kstate.h" #include "kobject.h" #include "kground.h" @@ -281,41 +284,196 @@ void make_environment(klisp_State *K, TValue *xparams, TValue ptree, ** 4.9 Environment mutation */ -/* helper */ +/* helpers */ void match(klisp_State *K, TValue *xparams, TValue obj); +inline void ptree_clear_marks(klisp_State *K, TValue sym_ls); +inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree); /* 4.9.1 $define! */ -/* TODO: allow general ptrees */ void SdefineB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) { - (void) xparams; - bind_2p(K, "$define!", ptree, dptree, expr) + /* + ** xparams[0] = define symbol + */ + bind_2p(K, "$define!", ptree, dptree, expr); + + TValue def_sym = xparams[0]; + + dptree = check_copy_ptree(K, "$define!", dptree); + + TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL, + &match, 3, dptree, denv, + def_sym); + kset_cc(K, new_cont); + ktail_call(K, K->eval_op, expr, denv); +} - /* TODO: allow general ptrees */ - if (!ttissymbol(dptree) && !ttisignore(dptree)) { - klispE_throw(K, "$define!: Not a symbol or ignore"); - return; - } else { - TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL, - &match, 2, dptree, denv); - kset_cc(K, new_cont); - ktail_call(K, K->eval_op, expr, denv); +/* helpers */ + +/* +** This checks that ptree is a valid <ptree>: +** 1) <ptree> -> <symbol> | #ignore | () | (<ptree> . <ptree>) +** 2) no symbol appears more than once in ptree +** 3) there is no cycle +** NOTE: there may be diamonds, but no symbol should be reachable by more +** than one path, see rule number 2 +** +** It also copies the ptree so that it can't be mutated +** TODO: if ptree is immutable don't copy it +*/ +inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree) +{ + /* GC: ptree is rooted because it is in the stack at all times */ + TValue copy = ptree; + /* NIL terminated singly linked list of symbols + (using the mark as next pointer) */ + TValue sym_ls = KNIL; + + assert(ks_sisempty(K)); + + /* TODO: copy */ + ks_spush(K, ptree); + + /* last operation was a push */ + bool push = true; + + while(!ks_sisempty(K)) { + TValue top = ks_sget(K); + + if (push) { + /* last operation was a push */ + switch(ttype(top)) { + case K_TIGNORE: + case K_TNIL: + ks_sdpop(K); + push = false; + break; + case K_TSYMBOL: { + if (kis_marked(top)) { + /* TODO add symbol name */ + ks_sdpop(K); + ptree_clear_marks(K, sym_ls); + klispE_throw_extra(K, name, ": repeated symbol in ptree"); + /* avoid warning */ + return KNIL; + } else { + /* add it to the symbol list */ + kset_mark(top, sym_ls); + sym_ls = top; + ks_sdpop(K); + push = false; + } + break; + } + case K_TPAIR: { + if (kis_unmarked(top)) { + kset_mark(top, i2tv(1)); + ks_spush(K, kcar(top)); + push = true; + } else { + /* marked pair means a cycle was found */ + ptree_clear_marks(K, sym_ls); + klispE_throw_extra(K, name, ": cycle detected in ptree"); + /* avoid warning */ + return KNIL; + } + break; + } + default: + ks_sdpop(K); + ptree_clear_marks(K, sym_ls); + klispE_throw_extra(K, name, ": bad object type in ptree"); + /* avoid warning */ + return KNIL; + } + } else { + /* last operation was a pop */ + /* top must be a pair with either 1 or 2 as mark */ + int32_t mark = ivalue(kget_mark(top)); + if (mark == 1) { /* only car was checked, check cdr */ + kset_mark(top, i2tv(2)); + ks_spush(K, kcdr(top)); + push = true; + } else { /* both car & cdr were checked, unmark this pair */ + kunmark(top); + ks_sdpop(K); + push = false; + } + } + } + + ptree_clear_marks(K, sym_ls); + /* TODO: do copy */ + return copy; +} + +/* The stack should contain only pairs, sym_ls should be + as above */ +inline void ptree_clear_marks(klisp_State *K, TValue sym_ls) +{ + while(!ttisnil(sym_ls)) { + TValue first = sym_ls; + sym_ls = kget_mark(first); + kunmark(first); + } + + while(!ks_sisempty(K)) { + kunmark(ks_sget(K)); + ks_sdpop(K); } } -/* helper */ void match(klisp_State *K, TValue *xparams, TValue obj) { /* - ** tparams[0]: ptree - ** tparams[1]: dynamic environment + ** xparams[0]: ptree + ** xparams[1]: dynamic environment + ** xparams[2]: combiner symbol */ TValue ptree = xparams[0]; TValue env = xparams[1]; - - /* TODO: allow general parameter trees */ - if (!ttisignore(ptree)) { - kadd_binding(K, env, ptree, obj); + char *name = ksymbol_buf(xparams[2]); + + assert(ks_sisempty(K)); + ks_spush(K, obj); + ks_spush(K, ptree); + + while(!ks_sisempty(K)) { + ptree = ks_spop(K); + obj = ks_spop(K); + + switch(ttype(ptree)) { + case K_TNIL: + if (!ttisnil(obj)) { + /* TODO show ptree and arguments */ + ks_sclear(K); + klispE_throw_extra(K, name, ": ptree doesn't match arguments"); + return; + } + break; + case K_TIGNORE: + /* do nothing */ + break; + case K_TSYMBOL: + kadd_binding(K, env, ptree, obj); + break; + case K_TPAIR: + if (ttispair(obj)) { + ks_spush(K, kcdr(obj)); + ks_spush(K, kcdr(ptree)); + ks_spush(K, kcar(obj)); + ks_spush(K, kcar(ptree)); + } else { + /* TODO show ptree and arguments */ + ks_sclear(K); + klispE_throw_extra(K, name, ": ptree doesn't match arguments"); + return; + } + break; + default: + /* can't really happen */ + break; + } } kapply_cc(K, KINERT); } @@ -497,7 +655,7 @@ TValue kmake_ground_env(klisp_State *K) /* 4.9.1 $define! */ symbol = ksymbol_new(K, "$define!"); - value = kmake_operative(K, KNIL, KNIL, SdefineB, 0); + value = kmake_operative(K, KNIL, KNIL, SdefineB, 1, symbol); kadd_binding(K, ground_env, symbol, value); /* diff --git a/src/kobject.h b/src/kobject.h @@ -111,6 +111,8 @@ typedef struct __attribute__ ((__packed__)) GCheader { #define K_TEOF 23 #define K_TBOOLEAN 24 #define K_TCHAR 25 +/* user pointer */ +#define K_TUSER 29 #define K_TPAIR 30 #define K_TSTRING 31 @@ -139,6 +141,8 @@ typedef struct __attribute__ ((__packed__)) GCheader { #define K_TAG_BOOLEAN K_MAKE_VTAG(K_TBOOLEAN) #define K_TAG_CHAR K_MAKE_VTAG(K_TCHAR) +#define K_TAG_USER K_MAKE_VTAG(K_TUSER) + #define K_TAG_PAIR K_MAKE_VTAG(K_TPAIR) #define K_TAG_STRING K_MAKE_VTAG(K_TSTRING) #define K_TAG_SYMBOL K_MAKE_VTAG(K_TSYMBOL) @@ -346,11 +350,13 @@ const TValue keminf; #define ch2tv_(ch_) {.tv = {.t = K_TAG_CHAR, .v = { .ch = (ch_) }}} #define i2tv_(i_) {.tv = {.t = K_TAG_FIXINT, .v = { .i = (i_) }}} #define b2tv_(b_) {.tv = {.t = K_TAG_BOOLEAN, .v = { .b = (b_) }}} +#define p2tv_(p_) {.tv = {.t = K_TAG_USER, .v = { .p = (p_) }}} /* Macros to create TValues of non-heap allocated types */ #define ch2tv(ch_) ((TValue) ch2tv_(ch_)) #define i2tv(i_) ((TValue) i2tv_(i_)) #define b2tv(b_) ((TValue) b2tv_(b_)) +#define p2tv(p_) ((TValue) b2tv_(p_)) /* Macros to convert a GCObject * into a tagged value */ /* TODO: add assertions */ @@ -385,6 +391,7 @@ const TValue keminf; #define bvalue(o_) ((o_).tv.v.b) #define chvalue(o_) ((o_).tv.v.ch) #define gcvalue(o_) ((o_).tv.v.gc) +#define pvalue(o_) ((o_).tv.v.p) /* Macro to obtain a string describing the type of a TValue */# #define ttname(tv_) (ktv_names[ttype(tv_)])