klisp

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

commit 7f0c0edec457fc1c374b5e5ef105cd2ba6b2d801
parent 7f2a6e59d8bec64b7fbdff8901eff9c258189851
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Sun, 13 Mar 2011 02:30:16 -0300

Extracted out the environment mutation features from kground.c to a new file kgenv_mut.c (and .h).

Diffstat:
Msrc/Makefile | 8++++++--
Asrc/kgenv_mut.c | 57+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/kgenv_mut.h | 235+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Msrc/kgenvironments.c | 2+-
Msrc/kgenvironments.h | 4++--
Msrc/kground.c | 325+------------------------------------------------------------------------------
6 files changed, 303 insertions(+), 328 deletions(-)

diff --git a/src/Makefile b/src/Makefile @@ -11,7 +11,8 @@ 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 \ kground.o kghelpers.o kgbooleans.o kgeqp.o kgequalp.o \ - kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o + kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o kgenvironments.o \ + kgenv_mut.o KRN_T= klisp KRN_O= klisp.o @@ -69,7 +70,7 @@ krepl.o: krepl.c krepl.h kcontinuation.h kstate.h kobject.h keval.h klisp.h \ kground.o: kground.c kground.h kstate.h kobject.h klisp.h kenvironment.h \ kpair.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 + kgpair_mut.h kgenvironments.h kgenv_mut.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 \ @@ -89,3 +90,6 @@ kgpair_mut.o: kgpair_mut.c kgpair_mut.h kghelpers.h kstate.h klisp.h \ kgenvironments.o: kgenvironments.c kgenvironments.h kghelpers.h kstate.h \ klisp.h kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h \ kenvironment.h +kgenv_mut.o: kgenvironments.c kgenvironments.h kghelpers.h kstate.h \ + klisp.h kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h \ + kenvironment.h diff --git a/src/kgenv_mut.c b/src/kgenv_mut.c @@ -0,0 +1,57 @@ +/* +** kgenv_mut.c +** Environment mutation 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 "kpair.h" +#include "kenvironment.h" +#include "kcontinuation.h" +#include "ksymbol.h" +#include "kerror.h" + +#include "kghelpers.h" +#include "kgenv_mut.h" + +/* 4.9.1 $define! */ +void SdefineB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) +{ + /* + ** xparams[0] = define symbol + */ + bind_2p(K, "$define!", ptree, dptree, expr); + + TValue def_sym = xparams[0]; + + dptree = check_copy_ptree(K, "$define!", dptree, KIGNORE); + + TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL, + do_match, 3, dptree, denv, + def_sym); + kset_cc(K, new_cont); + ktail_eval(K, expr, denv); +} + +/* helper */ +void do_match(klisp_State *K, TValue *xparams, TValue obj) +{ + /* + ** xparams[0]: ptree + ** xparams[1]: dynamic environment + ** xparams[2]: combiner symbol + */ + TValue ptree = xparams[0]; + TValue env = xparams[1]; + char *name = ksymbol_buf(xparams[2]); + + match(K, name, env, ptree, obj); + kapply_cc(K, KINERT); +} diff --git a/src/kgenv_mut.h b/src/kgenv_mut.h @@ -0,0 +1,235 @@ +/* +** kgenv_mut.h +** Environment mutation features for the ground environment +** See Copyright Notice in klisp.h +*/ + +#ifndef kgenv_mut_h +#define kgenv_mut_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" + +/* helpers */ +inline void match(klisp_State *K, char *name, TValue env, TValue ptree, + TValue obj); +void do_match(klisp_State *K, TValue *xparams, TValue obj); +inline void ptree_clear_all(klisp_State *K, TValue sym_ls); +inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree, + TValue penv); +/* 4.9.1 $define! */ +void SdefineB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv); + +/* MAYBE: don't make these inline */ +/* +** Clear all the marks (symbols + pairs) & stacks. +** The stack should contain only pairs, sym_ls should be +** as above +*/ +inline void ptree_clear_all(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); + } + + ks_tbclear(K); +} + +inline void match(klisp_State *K, char *name, TValue env, TValue ptree, + TValue obj) +{ + 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; + } + } +} + +inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree, + TValue penv) +{ + /* + ** GC: ptree is rooted because it is in the stack at all times. + ** The copied pair should be kept safe some other way + ** the same for ptree + */ + + /* copy is only valid if the state isn't ST_PUSH */ + /* but init anyways to avoid warning */ + TValue copy = ptree; + + /* + ** NIL terminated singly linked list of symbols + ** (using the mark as next pointer) + */ + TValue sym_ls = KNIL; + + assert(ks_sisempty(K)); + assert(ks_tbisempty(K)); + + ks_tbpush(K, ST_PUSH); + ks_spush(K, ptree); + + while(!ks_sisempty(K)) { + char state = ks_tbpop(K); + TValue top = ks_spop(K); + + if (state == ST_PUSH) { + switch(ttype(top)) { + case K_TIGNORE: + case K_TNIL: + copy = top; + break; + case K_TSYMBOL: { + if (kis_marked(top)) { + /* TODO add symbol name */ + ptree_clear_all(K, sym_ls); + klispE_throw_extra(K, name, ": repeated symbol in ptree"); + /* avoid warning */ + return KNIL; + } else { + copy = top; + /* add it to the symbol list */ + kset_mark(top, sym_ls); + sym_ls = top; + } + break; + } + case K_TPAIR: { + if (kis_unmarked(top)) { + if (kis_immutable(top)) { + /* don't copy mutable pairs, just use them */ + /* NOTE: immutable pairs can't have mutable + car or cdr */ + /* we have to continue thou, because there could be a + cycle */ + kset_mark(top, top); + } else { + /* create a new pair as copy, save it in the mark */ + TValue new_pair = kdummy_imm_cons(K); + kset_mark(top, new_pair); + } + /* keep the old pair and continue with the car */ + ks_tbpush(K, ST_CAR); + ks_spush(K, top); + + ks_tbpush(K, ST_PUSH); + ks_spush(K, kcar(top)); + } else { + /* marked pair means a cycle was found */ + /* NOTE: the pair should be in the stack already so + it isn't necessary to push it again to clear the mark */ + ptree_clear_all(K, sym_ls); + klispE_throw_extra(K, name, ": cycle detected in ptree"); + /* avoid warning */ + return KNIL; + } + break; + } + default: + ptree_clear_all(K, sym_ls); + klispE_throw_extra(K, name, ": bad object type in ptree"); + /* avoid warning */ + return KNIL; + } + } else { + /* last operation was a pop */ + /* top is a marked pair, the mark is the copied obj */ + /* NOTE: if top is immutable the mark is also top + we could still do the set-car/set-cdr because the + copy would be the same as the car/cdr, but why bother */ + if (state == ST_CAR) { + /* only car was checked (not yet copied) */ + if (kis_mutable(top)) { + TValue copied_pair = kget_mark(top); + kset_car(copied_pair, copy); + } + /* put the copied pair again, continue with the cdr */ + ks_tbpush(K, ST_CDR); + ks_spush(K, top); + + ks_tbpush(K, ST_PUSH); + ks_spush(K, kcdr(top)); + } else { + /* both car & cdr were checked (cdr not yet copied) */ + TValue copied_pair = kget_mark(top); + /* the unmark is needed to allow diamonds */ + kunmark(top); + + if (kis_mutable(top)) { + kset_cdr(copied_pair, copy); + } + copy = copied_pair; + } + } + } + + if (ttissymbol(penv)) { + if (kis_marked(penv)) { + /* TODO add symbol name */ + ptree_clear_all(K, sym_ls); + klispE_throw_extra(K, name, ": same symbol in both ptree and " + "environment parmameter"); + } + } else if (!ttisignore(penv)) { + /* TODO add symbol name */ + ptree_clear_all(K, sym_ls); + klispE_throw_extra(K, name, ": symbol or #ignore expected as " + "environment parmameter"); + } + ptree_clear_all(K, sym_ls); + return copy; +} + +#endif diff --git a/src/kgenvironments.c b/src/kgenvironments.c @@ -1,5 +1,5 @@ /* -** kgenvironments.h +** kgenvironments.c ** Environments features for the ground environment ** See Copyright Notice in klisp.h */ diff --git a/src/kgenvironments.h b/src/kgenvironments.h @@ -4,8 +4,8 @@ ** See Copyright Notice in klisp.h */ -#ifndef kgpairs_lists_h -#define kgpairs_lists_h +#ifndef kgenvironments_h +#define kgenvironments_h #include <assert.h> #include <stdio.h> diff --git a/src/kground.c b/src/kground.c @@ -30,6 +30,8 @@ #include "kgcontrol.h" #include "kgpairs_lists.h" #include "kgpair_mut.h" +#include "kgenvironments.h" +#include "kgenv_mut.h" /* ** This section will roughly follow the report and will reference the @@ -38,322 +40,6 @@ /* TODO: split in different files for each module */ /* -** 4.8 Environments -*/ - -/* 4.8.1 environment? */ -/* uses typep */ - -/* 4.8.2 ignore? */ -/* uses typep */ - -/* 4.8.3 eval */ -void eval(klisp_State *K, TValue *xparams, TValue ptree, - TValue denv) -{ - (void) denv; - bind_2tp(K, "eval", ptree, "any", anytype, expr, - "environment", ttisenvironment, env); - - ktail_eval(K, expr, env); -} - -/* 4.8.4 make-environment */ -/* TODO: let it accept any number of parameters */ -void make_environment(klisp_State *K, TValue *xparams, TValue ptree, - TValue denv) -{ - (void) denv; - (void) xparams; - TValue new_env; - if (ttisnil(ptree)) { - new_env = kmake_empty_environment(K); - kapply_cc(K, new_env); - } else if (ttispair(ptree) && ttisnil(kcdr(ptree))) { - /* special common case of one parent, don't keep a list */ - TValue parent = kcar(ptree); - if (ttisenvironment(parent)) { - new_env = kmake_environment(K, parent); - kapply_cc(K, new_env); - } else { - klispE_throw(K, "make-environment: not an environment in " - "parent list"); - return; - } - } else { - /* this is the general case, copy the list but without the - cycle if there is any */ - TValue parents = check_copy_env_list(K, "make-environment", ptree); - new_env = kmake_environment(K, parents); - kapply_cc(K, new_env); - } -} - -/* -** 4.9 Environment mutation -*/ - -/* helpers */ -inline void match(klisp_State *K, char *name, TValue env, TValue ptree, - TValue obj); -void do_match(klisp_State *K, TValue *xparams, TValue obj); -inline void ptree_clear_all(klisp_State *K, TValue sym_ls); -inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree, - TValue penv); - -/* 4.9.1 $define! */ -void SdefineB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) -{ - /* - ** xparams[0] = define symbol - */ - bind_2p(K, "$define!", ptree, dptree, expr); - - TValue def_sym = xparams[0]; - - dptree = check_copy_ptree(K, "$define!", dptree, KIGNORE); - - TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL, - do_match, 3, dptree, denv, - def_sym); - kset_cc(K, new_cont); - ktail_eval(K, expr, denv); -} - -/* helpers */ - -/* -** This checks that the ptree parameter is a valid ptree and checks that the -** environment parameter is either a symbol that is not also in ptree. or -** #ignore. It also copies the ptree so that it can't be mutated. -** -** A valid ptree must comply with the following: -** 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 -** -*/ -inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree, - TValue penv) -{ - /* - ** GC: ptree is rooted because it is in the stack at all times. - ** The copied pair should be kept safe some other way - ** the same for ptree - */ - - /* copy is only valid if the state isn't ST_PUSH */ - /* but init anyways to avoid warning */ - TValue copy = ptree; - - /* - ** NIL terminated singly linked list of symbols - ** (using the mark as next pointer) - */ - TValue sym_ls = KNIL; - - assert(ks_sisempty(K)); - assert(ks_tbisempty(K)); - - ks_tbpush(K, ST_PUSH); - ks_spush(K, ptree); - - while(!ks_sisempty(K)) { - char state = ks_tbpop(K); - TValue top = ks_spop(K); - - if (state == ST_PUSH) { - switch(ttype(top)) { - case K_TIGNORE: - case K_TNIL: - copy = top; - break; - case K_TSYMBOL: { - if (kis_marked(top)) { - /* TODO add symbol name */ - ptree_clear_all(K, sym_ls); - klispE_throw_extra(K, name, ": repeated symbol in ptree"); - /* avoid warning */ - return KNIL; - } else { - copy = top; - /* add it to the symbol list */ - kset_mark(top, sym_ls); - sym_ls = top; - } - break; - } - case K_TPAIR: { - if (kis_unmarked(top)) { - if (kis_immutable(top)) { - /* don't copy mutable pairs, just use them */ - /* NOTE: immutable pairs can't have mutable - car or cdr */ - /* we have to continue thou, because there could be a - cycle */ - kset_mark(top, top); - } else { - /* create a new pair as copy, save it in the mark */ - TValue new_pair = kdummy_imm_cons(K); - kset_mark(top, new_pair); - } - /* keep the old pair and continue with the car */ - ks_tbpush(K, ST_CAR); - ks_spush(K, top); - - ks_tbpush(K, ST_PUSH); - ks_spush(K, kcar(top)); - } else { - /* marked pair means a cycle was found */ - /* NOTE: the pair should be in the stack already so - it isn't necessary to push it again to clear the mark */ - ptree_clear_all(K, sym_ls); - klispE_throw_extra(K, name, ": cycle detected in ptree"); - /* avoid warning */ - return KNIL; - } - break; - } - default: - ptree_clear_all(K, sym_ls); - klispE_throw_extra(K, name, ": bad object type in ptree"); - /* avoid warning */ - return KNIL; - } - } else { - /* last operation was a pop */ - /* top is a marked pair, the mark is the copied obj */ - /* NOTE: if top is immutable the mark is also top - we could still do the set-car/set-cdr because the - copy would be the same as the car/cdr, but why bother */ - if (state == ST_CAR) { - /* only car was checked (not yet copied) */ - if (kis_mutable(top)) { - TValue copied_pair = kget_mark(top); - kset_car(copied_pair, copy); - } - /* put the copied pair again, continue with the cdr */ - ks_tbpush(K, ST_CDR); - ks_spush(K, top); - - ks_tbpush(K, ST_PUSH); - ks_spush(K, kcdr(top)); - } else { - /* both car & cdr were checked (cdr not yet copied) */ - TValue copied_pair = kget_mark(top); - /* the unmark is needed to allow diamonds */ - kunmark(top); - - if (kis_mutable(top)) { - kset_cdr(copied_pair, copy); - } - copy = copied_pair; - } - } - } - - if (ttissymbol(penv)) { - if (kis_marked(penv)) { - /* TODO add symbol name */ - ptree_clear_all(K, sym_ls); - klispE_throw_extra(K, name, ": same symbol in both ptree and " - "environment parmameter"); - } - } else if (!ttisignore(penv)) { - /* TODO add symbol name */ - ptree_clear_all(K, sym_ls); - klispE_throw_extra(K, name, ": symbol or #ignore expected as " - "environment parmameter"); - } - ptree_clear_all(K, sym_ls); - return copy; -} - -/* -** Clear all the marks (symbols + pairs) & stacks. -** The stack should contain only pairs, sym_ls should be -** as above -*/ -inline void ptree_clear_all(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); - } - - ks_tbclear(K); -} - -inline void match(klisp_State *K, char *name, TValue env, TValue ptree, - TValue obj) -{ - 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; - } - } -} - -void do_match(klisp_State *K, TValue *xparams, TValue obj) -{ - /* - ** xparams[0]: ptree - ** xparams[1]: dynamic environment - ** xparams[2]: combiner symbol - */ - TValue ptree = xparams[0]; - TValue env = xparams[1]; - char *name = ksymbol_buf(xparams[2]); - - match(K, name, env, ptree, obj); - kapply_cc(K, KINERT); -} - -/* ** 4.10 Combiners */ @@ -509,13 +195,6 @@ void apply(klisp_State *K, TValue *xparams, TValue ptree, /* TODO */ /* -** 5.10 Environments -*/ - -/* 5.10.1 $let */ -/* TODO */ - -/* ** BEWARE: this is highly unhygienic, it assumes variables "symbol" and ** "value", both of type TValue. symbol will be bound to a symbol named by ** "n_" and can be referrenced in the var_args