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:
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
