commit b65f6cb7e2f5d9057506a943373af15afed5323c
parent a31c2af3dc858447c2eec06a8037d0b5d4f963e4
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 13 Mar 2011 02:09:00 -0300
Extracted out the pair mutation features from kground.c to a new file kgpair_mut.c (and .h).
Diffstat:
5 files changed, 253 insertions(+), 206 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -11,7 +11,7 @@ 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
+ kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o
KRN_T= klisp
KRN_O= klisp.o
@@ -83,3 +83,5 @@ kgcontrol.o: kgcontrol.c kgcontrol.c kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kpair.h kcontinuation.h
kgpairs_lists.o: kgpairs_lists.c kgpairs_lists.h kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h
+kgpair_mut.o: kgpair_mut.c kgpair_mut.h kghelpers.h kstate.h klisp.h \
+ kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -0,0 +1,211 @@
+/*
+** kgpair_mut.c
+** Pair 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 "kcontinuation.h"
+#include "ksymbol.h"
+#include "kerror.h"
+
+#include "kghelpers.h"
+#include "kgpair_mut.h"
+
+/* 4.7.1 set-car!, set-cdr! */
+void set_carB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ (void) denv;
+ (void) xparams;
+ bind_2tp(K, "set-car!", ptree, "pair", ttispair, pair,
+ "any", anytype, new_car);
+
+ if(!kis_mutable(pair)) {
+ klispE_throw(K, "set-car!: immutable pair");
+ return;
+ }
+ kset_car(pair, new_car);
+ kapply_cc(K, KINERT);
+}
+
+void set_cdrB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ (void) denv;
+ (void) xparams;
+ bind_2tp(K, "set-cdr!", ptree, "pair", ttispair, pair,
+ "any", anytype, new_cdr);
+
+ if(!kis_mutable(pair)) {
+ klispE_throw(K, "set-cdr!: immutable pair");
+ return;
+ }
+ kset_cdr(pair, new_cdr);
+ kapply_cc(K, KINERT);
+}
+
+/* 4.7.2 copy-es-immutable */
+void copy_es_immutable(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ /*
+ ** xparams[0]: copy-es-immutable symbol
+ */
+ char *name = ksymbol_buf(xparams[0]);
+ bind_1p(K, name, ptree, obj);
+
+ TValue copy = copy_es_immutable_h(K, name, obj);
+ kapply_cc(K, copy);
+}
+
+/*
+** This is in a helper method to use it from $lambda, $vau, etc
+**
+** We mark each seen mutable pair with the corresponding copied
+** immutable pair to construct a structure that is isomorphic to
+** the original.
+** All objects that aren't mutable pairs are retained without
+** copying
+** sstack is used to keep track of pairs and tbstack is used
+** 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)
+{
+ /*
+ ** GC: obj is rooted because it is in the stack at all times.
+ ** The copied pair should be kept safe some other way
+ */
+ 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) && 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);
+ 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);
+ return copy;
+}
+
+/* 5.8.1 encycle! */
+void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+/* ASK John: can the object be a cyclic list of length less than k1+k2?
+ the wording of the report seems to indicate that can't be the case,
+ and here it makes sense to forbid it because otherwise the list-metrics
+ of the result would differ with the expected ones (cf list-tail).
+ So here an error is signaled if the improper list cyclic with less pairs
+ than needed */
+ (void) denv;
+ (void) xparams;
+ /* XXX: should be integer instead of fixint, but that's all
+ we have for now */
+ bind_3tp(K, "encycle!", ptree, "any", anytype, obj,
+ "finite integer", ttisfixint, tk1,
+ "finite integer", ttisfixint, tk2);
+
+ int32_t k1 = ivalue(tk1);
+ int32_t k2 = ivalue(tk2);
+
+ if (k1 < 0 || k2 < 0) {
+ klispE_throw(K, "encycle!: negative index");
+ return;
+ }
+
+ TValue tail = obj;
+
+ while(k1) {
+ if (!ttispair(tail)) {
+ unmark_list(K, obj);
+ klispE_throw(K, "encycle!: non pair found while traversing "
+ "object");
+ return;
+ } else if (kis_marked(tail)) {
+ unmark_list(K, obj);
+ klispE_throw(K, "encycle!: too few pairs in cyclic list");
+ return;
+ }
+ kmark(tail);
+ tail = kcdr(tail);
+ --k1;
+ }
+
+ TValue fcp = tail;
+
+ /* if k2 == 0 do nothing (but this still checks that the obj
+ has at least k1 pairs */
+ if (k2 != 0) {
+ --k2; /* to have cycle length k2 we should discard k2-1 pairs */
+ while(k2) {
+ if (!ttispair(tail)) {
+ unmark_list(K, obj);
+ klispE_throw(K, "encycle!: non pair found while traversing "
+ "object");
+ return;
+ } else if (kis_marked(tail)) {
+ unmark_list(K, obj);
+ klispE_throw(K, "encycle!: too few pairs in cyclic list");
+ return;
+ }
+ kmark(tail);
+ tail = kcdr(tail);
+ --k2;
+ }
+ if (!kis_mutable(tail)) {
+ unmark_list(K, obj);
+ klispE_throw(K, "encycle!: immutable pair");
+ return;
+ } else {
+ kset_cdr(tail, fcp);
+ }
+ }
+ unmark_list(K, obj);
+ kapply_cc(K, KINERT);
+}
diff --git a/src/kgpair_mut.h b/src/kgpair_mut.h
@@ -0,0 +1,37 @@
+/*
+** kgpair_mut.h
+** Pair mutation features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgpairs_mut_h
+#define kgpairs_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"
+
+/* Helper (also used by $vau, $lambda, etc) */
+TValue copy_es_immutable_h(klisp_State *K, char *name, TValue ptree);
+
+/* 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);
+
+/* 4.7.2 copy-es-immutable */
+void copy_es_immutable(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv);
+
+/* 5.8.1 encycle! */
+void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
+#endif
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -1,5 +1,5 @@
/*
-** kgpairs_lists.h
+** kgpairs_lists.c
** Pairs and lists features for the ground environment
** See Copyright Notice in klisp.h
*/
diff --git a/src/kground.c b/src/kground.c
@@ -29,6 +29,7 @@
#include "kgsymbols.h"
#include "kgcontrol.h"
#include "kgpairs_lists.h"
+#include "kgpair_mut.h"
/*
** This section will roughly follow the report and will reference the
@@ -37,129 +38,6 @@
/* TODO: split in different files for each module */
/*
-** 4.7 Pair mutation
-*/
-
-/* 4.7.1 set-car!, set-cdr! */
-void set_carB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- (void) denv;
- (void) xparams;
- bind_2tp(K, "set-car!", ptree, "pair", ttispair, pair,
- "any", anytype, new_car);
-
- if(!kis_mutable(pair)) {
- klispE_throw(K, "set-car!: immutable pair");
- return;
- }
- kset_car(pair, new_car);
- kapply_cc(K, KINERT);
-}
-
-void set_cdrB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- (void) denv;
- (void) xparams;
- bind_2tp(K, "set-cdr!", ptree, "pair", ttispair, pair,
- "any", anytype, new_cdr);
-
- if(!kis_mutable(pair)) {
- klispE_throw(K, "set-cdr!: immutable pair");
- return;
- }
- kset_cdr(pair, new_cdr);
- kapply_cc(K, KINERT);
-}
-
-/* 4.7.2 copy-es-immutable */
-
-/* Helper (also used by $vau, $lambda, etc) */
-TValue copy_es_immutable_h(klisp_State *K, char *name, TValue ptree);
-
-void copy_es_immutable(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
-{
- /*
- ** xparams[0]: copy-es-immutable symbol
- */
- char *name = ksymbol_buf(xparams[0]);
- bind_1p(K, name, ptree, obj);
-
- TValue copy = copy_es_immutable_h(K, name, obj);
- kapply_cc(K, copy);
-}
-
-/*
-** This is in a helper method to use it from $lambda, $vau, etc
-**
-** We mark each seen mutable pair with the corresponding copied
-** immutable pair to construct a structure that is isomorphic to
-** the original.
-** All objects that aren't mutable pairs are retained without
-** copying
-** sstack is used to keep track of pairs and tbstack is used
-** 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)
-{
- /*
- ** GC: obj is rooted because it is in the stack at all times.
- ** The copied pair should be kept safe some other way
- */
- 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) && 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);
- 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);
- return copy;
-}
-
-
-/*
** 4.8 Environments
*/
@@ -624,87 +502,6 @@ void apply(klisp_State *K, TValue *xparams, TValue ptree,
}
/*
-** 5.8 Pair mutation
-*/
-
-/* 5.8.1 encycle! */
-/* ASK John: can the object be a cyclic list of length less than k1+k2?
- the wording of the report seems to indicate that can't be the case,
- and here it makes sense to forbid it because otherwise the list-metrics
- of the result would differ with the expected ones (cf list-tail).
- So here an error is signaled if the improper list cyclic with less pairs
- than needed */
-void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
-{
- (void) denv;
- (void) xparams;
- /* XXX: should be integer instead of fixint, but that's all
- we have for now */
- bind_3tp(K, "encycle!", ptree, "any", anytype, obj,
- "finite integer", ttisfixint, tk1,
- "finite integer", ttisfixint, tk2);
-
- int32_t k1 = ivalue(tk1);
- int32_t k2 = ivalue(tk2);
-
- if (k1 < 0 || k2 < 0) {
- klispE_throw(K, "encycle!: negative index");
- return;
- }
-
- TValue tail = obj;
-
- while(k1) {
- if (!ttispair(tail)) {
- unmark_list(K, obj);
- klispE_throw(K, "encycle!: non pair found while traversing "
- "object");
- return;
- } else if (kis_marked(tail)) {
- unmark_list(K, obj);
- klispE_throw(K, "encycle!: too few pairs in cyclic list");
- return;
- }
- kmark(tail);
- tail = kcdr(tail);
- --k1;
- }
-
- TValue fcp = tail;
-
- /* if k2 == 0 do nothing (but this still checks that the obj
- has at least k1 pairs */
- if (k2 != 0) {
- --k2; /* to have cycle length k2 we should discard k2-1 pairs */
- while(k2) {
- if (!ttispair(tail)) {
- unmark_list(K, obj);
- klispE_throw(K, "encycle!: non pair found while traversing "
- "object");
- return;
- } else if (kis_marked(tail)) {
- unmark_list(K, obj);
- klispE_throw(K, "encycle!: too few pairs in cyclic list");
- return;
- }
- kmark(tail);
- tail = kcdr(tail);
- --k2;
- }
- if (!kis_mutable(tail)) {
- unmark_list(K, obj);
- klispE_throw(K, "encycle!: immutable pair");
- return;
- } else {
- kset_cdr(tail, fcp);
- }
- }
- unmark_list(K, obj);
- kapply_cc(K, KINERT);
-}
-
-/*
** 5.9 Combiners
*/
