commit d8f513d76e2391c47e64fc420257329a56b42add
parent 0e108784893d491e6c1071adb25a2fa50df7de96
Author: Andres Navarro <canavarro82@gmail.com>
Date: Thu, 24 Mar 2011 20:13:22 -0300
Merged code for copy-es-immutable & copy-es.
Diffstat:
5 files changed, 30 insertions(+), 74 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -108,7 +108,7 @@ kgenv_mut.o: kgenv_mut.c kgenv_mut.h kghelpers.h kstate.h \
kenvironment.h
kgcombiners.o: kgcombiners.c kgenvironments.h kghelpers.h kstate.h \
klisp.h kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h \
- kenvironment.h kapplicative.h koperative.h
+ kenvironment.h kapplicative.h koperative.h kgpair_mut.h
kgcontinuations.o: kgcontinuations.c kgcontinuations.h kghelpers.h kstate.h \
klisp.h kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h \
kenvironment.h kapplicative.h koperative.h
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -46,7 +46,7 @@ void Svau(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
vptree = check_copy_ptree(K, "$vau", vptree, vpenv);
/* the body should be a list */
(void)check_list(K, "$vau", vbody);
- vbody = copy_es_immutable_h(K, "$vau", vbody);
+ vbody = copy_es_immutable_h(K, "$vau", vbody, false);
TValue new_op = make_operative(K, do_vau, 4, vptree, vpenv, vbody, denv);
kapply_cc(K, new_op);
@@ -119,7 +119,7 @@ void Slambda(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
vptree = check_copy_ptree(K, "$lambda", vptree, KIGNORE);
/* the body should be a list */
(void)check_list(K, "$lambda", vbody);
- vbody = copy_es_immutable_h(K, "$lambda", vbody);
+ vbody = copy_es_immutable_h(K, "$lambda", vbody, false);
TValue new_app = make_applicative(K, do_vau, 4, vptree, KIGNORE, vbody,
denv);
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -51,20 +51,25 @@ void set_cdrB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, KINERT);
}
-/* 4.7.2 copy-es-immutable */
-void copy_es_immutable(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+/* Helper for copy-es-immutable & copy-es */
+void copy_es(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
{
/*
** xparams[0]: copy-es-immutable symbol
+ ** xparams[1]: boolean (#t: use mutable pairs, #f: use immutable pairs)
*/
char *name = ksymbol_buf(xparams[0]);
+ bool mut_flag = bvalue(xparams[1]);
bind_1p(K, name, ptree, obj);
- TValue copy = copy_es_immutable_h(K, name, obj);
+ TValue copy = copy_es_immutable_h(K, name, obj, mut_flag);
kapply_cc(K, copy);
}
+/* 4.7.2 copy-es-immutable */
+/* uses copy_es */
+
/*
** This is in a helper method to use it from $lambda, $vau, etc
**
@@ -77,7 +82,8 @@ void copy_es_immutable(klisp_State *K, TValue *xparams,
** to keep track of which of car or cdr we were copying,
** 0 means just pushed, 1 means return from car, 2 means return from cdr
*/
-TValue copy_es_immutable_h(klisp_State *K, char *name, TValue obj)
+TValue copy_es_immutable_h(klisp_State *K, char *name, TValue obj,
+ bool mut_flag)
{
/*
** GC: obj is rooted because it is in the stack at all times.
@@ -96,12 +102,14 @@ TValue copy_es_immutable_h(klisp_State *K, char *name, TValue obj)
TValue top = ks_spop(K);
if (state == ST_PUSH) {
- if (ttispair(top) && kis_mutable(top)) {
+ /* if the pair is immutable & we are constructing immutable
+ pairs there is no need to copy */
+ if (ttispair(top) && (mut_flag || kis_mutable(top))) {
if (kis_marked(top)) {
/* this pair was already seen, use the same */
copy = kget_mark(top);
} else {
- TValue new_pair = kdummy_imm_cons(K);
+ TValue new_pair = kcons_g(K, mut_flag, KINERT, KINERT);
kset_mark(top, new_pair);
/* leave the pair in the stack, continue with the car */
ks_spush(K, top);
@@ -215,63 +223,7 @@ void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
/* TODO */
/* 6.4.2 copy-es */
-void copy_es(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- /*
- ** GC: obj is rooted because it is in the stack at all times.
- ** The copied pair should be kept safe some other way
- */
- bind_1p(K, "copy-es", ptree, obj);
-
- TValue copy = obj;
-
- assert(ks_sisempty(K));
- assert(ks_tbisempty(K));
-
- ks_spush(K, obj);
- ks_tbpush(K, ST_PUSH);
-
- while(!ks_sisempty(K)) {
- char state = ks_tbpop(K);
- TValue top = ks_spop(K);
-
- if (state == ST_PUSH) {
- if (ttispair(top)) {
- if (kis_marked(top)) {
- /* this pair was already seen, use the same */
- copy = kget_mark(top);
- } else {
- TValue new_pair = kdummy_cons(K);
- kset_mark(top, new_pair);
- /* leave the pair in the stack, continue with the car */
- ks_spush(K, top);
- ks_tbpush(K, ST_CAR);
-
- ks_spush(K, kcar(top));
- ks_tbpush(K, ST_PUSH);
- }
- } else {
- copy = top;
- }
- } else { /* last action was a pop */
- TValue new_pair = kget_mark(top);
- if (state == ST_CAR) {
- kset_car(new_pair, copy);
- /* leave the pair on the stack, continue with the cdr */
- ks_spush(K, top);
- ks_tbpush(K, ST_CDR);
-
- ks_spush(K, kcdr(top));
- ks_tbpush(K, ST_PUSH);
- } else {
- kset_cdr(new_pair, copy);
- copy = new_pair;
- }
- }
- }
- unmark_tree(K, obj);
- kapply_cc(K, copy);
-}
+/* uses copy_es helper (above copy-es-immutable) */
/* 6.4.3 assq */
/* TODO */
diff --git a/src/kgpair_mut.h b/src/kgpair_mut.h
@@ -19,16 +19,20 @@
#include "kghelpers.h"
/* Helper (also used by $vau, $lambda, etc) */
-TValue copy_es_immutable_h(klisp_State *K, char *name, TValue ptree);
+TValue copy_es_immutable_h(klisp_State *K, char *name, TValue ptree,
+ bool mut_flag);
/* 4.7.1 set-car!, set-cdr! */
void set_carB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
void set_cdrB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+/* Helper for copy-es & copy-es-immutable */
+void copy_es(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
/* 4.7.2 copy-es-immutable */
-void copy_es_immutable(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv);
+/* uses copy_es helper */
+
/* 5.8.1 encycle! */
void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
@@ -38,7 +42,7 @@ void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
/* TODO */
/* 6.4.2 copy-es */
-void copy_es(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+/* uses copy_es helper */
/* 6.4.3 assq */
/* TODO */
diff --git a/src/kground.c b/src/kground.c
@@ -139,8 +139,8 @@ void kinit_ground_env(klisp_State *K)
add_applicative(K, ground_env, "set-cdr!", set_cdrB, 0);
/* 4.7.2 copy-es-immutable */
- add_applicative(K, ground_env, "copy-es-immutable", copy_es_immutable,
- 1, symbol);
+ add_applicative(K, ground_env, "copy-es-immutable", copy_es, 2, symbol,
+ b2tv(false));
/*
** 4.8 Environments
@@ -413,7 +413,7 @@ void kinit_ground_env(klisp_State *K)
/* TODO */
/* 6.4.2 copy-es */
- add_applicative(K, ground_env, "copy-es", copy_es, 0);
+ add_applicative(K, ground_env, "copy-es", copy_es, 2, symbol, b2tv(true));
/* 6.4.3 assq */
/* TODO */
