klisp

commit 0e108784893d491e6c1071adb25a2fa50df7de96
parent 04c8ff469bb0d7de4eded9a9b8c587395519970d
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Thu, 24 Mar 2011 19:45:57 -0300

Added copy-es to the ground environment.

Diffstat:
M
src/kgpair_mut.c
 | 
69
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
M
src/kgpair_mut.h
 | 
12
++++++++++++
M
src/kground.c
 | 
2
+-

3 files changed, 82 insertions(+), 1 deletion(-)
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -209,3 +209,72 @@ void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
     unmark_list(K, obj);
     kapply_cc(K, KINERT);
 }
+
+
+/* 6.4.1 append! */
+/* 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);
+}
+
+/* 6.4.3 assq */
+/* TODO */
+
+/* 6.4.3 memq */
+/* TODO */
diff --git a/src/kgpair_mut.h b/src/kgpair_mut.h
@@ -34,4 +34,16 @@ void copy_es_immutable(klisp_State *K, TValue *xparams,
 void encycleB(klisp_State *K, TValue *xparams, TValue ptree, 
 	      TValue denv);
 
+/* 6.4.1 append! */
+/* TODO */
+
+/* 6.4.2 copy-es */
+void copy_es(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 6.4.3 assq */
+/* TODO */
+
+/* 6.4.3 memq */
+/* TODO */
+
 #endif
diff --git a/src/kground.c b/src/kground.c
@@ -413,7 +413,7 @@ void kinit_ground_env(klisp_State *K)
     /* TODO */
 
     /* 6.4.2 copy-es */
-    /* TODO */
+    add_applicative(K, ground_env, "copy-es", copy_es, 0);
 
     /* 6.4.3 assq */
     /* TODO */