klisp

commit 60e982b9e3efeef6c181e206aa0e3a6019495125
parent 91501ab76d413c4def9670f95cea678197e78638
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Wed,  9 Mar 2011 04:47:12 -0300

Added pair mutability and k[ad]+r helpers up to four levels.

Diffstat:
M
src/kground.c
 | 
11
+++++------
M
src/kobject.h
 | 
7
+++++++
M
src/kpair.c
 | 
5
++---
M
src/kpair.h
 | 
41
++++++++++++++++++++++++++++++++++++++---

4 files changed, 52 insertions(+), 12 deletions(-)
diff --git a/src/kground.c b/src/kground.c
@@ -54,12 +54,12 @@
 		 tstr2_, t2_, v2_)			\
     TValue v1_, v2_;					\
     if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \
-	    !ttisnil(kcdr(kcdr(ptree_)))) {		\
+	    !ttisnil(kcddr(ptree_))) {		\
 	klispE_throw(K_, n_ ": Bad ptree (expected two arguments)"); \
 	return; \
     } \
     v1_ = kcar(ptree_); \
-    v2_ = kcar(kcdr(ptree_)); \
+    v2_ = kcadr(ptree_); \
     if (!t1_(v1_)) { \
 	klispE_throw(K_, n_ ": Bad type on first argument (expected " \
 		     tstr1_ ")");				     \
@@ -73,14 +73,13 @@
 #define bind_3p(K_, n_, ptree_, v1_, v2_, v3_)		\
     TValue v1_, v2_, v3_;					\
     if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \
-	  !ttispair(kcdr (kcdr (ptree_))) ||  \
-	  !ttisnil(kcdr(kcdr(kcdr(ptree_))))) {			     \
+	  !ttispair(kcddr (ptree_)) || !ttisnil(kcdddr(ptree_))) {  \
 	klispE_throw(K_, n_ ": Bad ptree (expected tree arguments)"); \
 	return; \
     } \
     v1_ = kcar(ptree_); \
-    v2_ = kcar(kcdr(ptree_)); \
-    v3_ = kcar(kcdr(kcdr(ptree_)))
+    v2_ = kcadr(ptree_); \
+    v3_ = kcaddr(ptree_)
 
 /* TODO: add name and source info */
 #define kmake_applicative(K_, fn_, ...) \
diff --git a/src/kobject.h b/src/kobject.h
@@ -408,6 +408,13 @@ extern char *ktv_names[];
 #define kis_marked(p_) (!kis_unmarked(p_))
 #define kis_unmarked(p_) (tv_equal(kget_mark(p_), KFALSE))
 
+/* Macros to access mutability flag */
+#define K_FLAG_IMMUTABLE 0x0100
+#define kget_flags(o_) (tv2mgch(o_)->tt)
+
+#define kis_mutable(o_) ((kget_flags(o_) & K_FLAG_IMMUTABLE) == 0)
+#define kis_immutable(o_) (!kis_mutable(o_))
+
 /* Macro to test the most basic equality on TValues */
 #define tv_equal(tv1_, tv2_) ((tv1_).raw == (tv2_).raw)
 
diff --git a/src/kpair.c b/src/kpair.c
@@ -9,8 +9,7 @@
 #include "kstate.h"
 #include "kmem.h"
 
-/* TEMP: for now all pairs are mutable */
-TValue kcons(klisp_State *K, TValue car, TValue cdr) 
+TValue kcons_g(klisp_State *K, bool m, TValue car, TValue cdr) 
 {
     Pair *new_pair = klispM_new(K, Pair);
 
@@ -18,7 +17,7 @@ TValue kcons(klisp_State *K, TValue car, TValue cdr)
     new_pair->next = K->root_gc;
     K->root_gc = (GCObject *)new_pair;
     new_pair->gct = 0;
-    new_pair->tt = K_TPAIR;
+    new_pair->tt = K_TPAIR | (m? 0 : K_FLAG_IMMUTABLE);
 
     /* pair specific fields */
     new_pair->si = KNIL;
diff --git a/src/kpair.h b/src/kpair.h
@@ -11,17 +11,52 @@
 #include "kstate.h"
 
 /* TODO: add type assertions */
-/* TODO: add more kc[ad]*r combinations */
 #define kcar(p_) (tv2pair(p_)->car)
 #define kcdr(p_) (tv2pair(p_)->cdr)
 
+#define kcaar(p_) (kcar(kcar(p_)))
+#define kcadr(p_) (kcar(kcdr(p_)))
+#define kcdar(p_) (kcdr(kcar(p_)))
+#define kcddr(p_) (kcdr(kcdr(p_)))
+
+#define kcaaar(p_) (kcar(kcar(kcar(p_))))
+#define kcaadr(p_) (kcar(kcar(kcdr(p_))))
+#define kcadar(p_) (kcar(kcdr(kcar(p_))))
+#define kcaddr(p_) (kcar(kcdr(kcdr(p_))))
+#define kcdaar(p_) (kcdr(kcar(kcar(p_))))
+#define kcdadr(p_) (kcdr(kcar(kcdr(p_))))
+#define kcddar(p_) (kcdr(kcdr(kcar(p_))))
+#define kcdddr(p_) (kcdr(kcdr(kcdr(p_))))
+
+#define kcaaaar(p_) (kcar(kcar(kcar(kcar(p_)))))
+#define kcaaadr(p_) (kcar(kcar(kcar(kcdr(p_)))))
+#define kcaadar(p_) (kcar(kcar(kcdr(kcar(p_)))))
+#define kcaaddr(p_) (kcar(kcar(kcdr(kcdr(p_)))))
+#define kcadaar(p_) (kcar(kcdr(kcar(kcar(p_)))))
+#define kcadadr(p_) (kcar(kcdr(kcar(kcdr(p_)))))
+#define kcaddar(p_) (kcar(kcdr(kcdr(kcar(p_)))))
+#define kcadddr(p_) (kcar(kcdr(kcdr(kcdr(p_)))))
+
+#define kcdaaar(p_) (kcdr(kcar(kcar(kcar(p_)))))
+#define kcdaadr(p_) (kcdr(kcar(kcar(kcdr(p_)))))
+#define kcdadar(p_) (kcdr(kcar(kcdr(kcar(p_)))))
+#define kcdaddr(p_) (kcdr(kcar(kcdr(kcdr(p_)))))
+#define kcddaar(p_) (kcdr(kcdr(kcar(kcar(p_)))))
+#define kcddadr(p_) (kcdr(kcdr(kcar(kcdr(p_)))))
+#define kcdddar(p_) (kcdr(kcdr(kcdr(kcar(p_)))))
+#define kcddddr(p_) (kcdr(kcdr(kcdr(kcdr(p_)))))
+
+/* these will also work with immutable pairs */
 #define kset_car(p_, v_) (kcar(p_) = (v_))
 #define kset_cdr(p_, v_) (kcdr(p_) = (v_))
 
 #define kdummy_cons(st_) (kcons(st_, KNIL, KNIL))
+#define kdummy_imm_cons(st_) (kimm_cons(st_, KNIL, KNIL))
+
+TValue kcons_g(klisp_State *K, bool m, TValue car, TValue cdr);
 
-/* TEMP: for now all pairs are mutable */
-TValue kcons(klisp_State *K, TValue car, TValue cdr);
+#define kcons(K_, car_, cdr_) (kcons_g(K_, true, car_, cdr_))
+#define kimm_cons(K_, car_, cdr_) (kcons_g(K_, false, car_, cdr_))
 
 #define kget_source_info(p_) (tv2pair(p_)->si)
 #define kset_source_info(p_, si_) (kget_source_info(p_) = (si_))