commit 1a83162c930cf69884edf3b9003f5f16f81265ab
parent c35909811fc2b67b65d639d36ca348881dfd178a
Author: Andres Navarro <canavarro82@gmail.com>
Date: Thu, 10 Mar 2011 22:52:09 -0300
Added equal? to the ground environment.
Diffstat:
4 files changed, 214 insertions(+), 8 deletions(-)
diff --git a/src/kground.c b/src/kground.c
@@ -12,6 +12,7 @@
#include "kobject.h"
#include "kground.h"
#include "kpair.h"
+#include "kstring.h"
#include "kenvironment.h"
#include "kcontinuation.h"
#include "ksymbol.h"
@@ -115,6 +116,7 @@
*/
inline void unmark_list(klisp_State *K, TValue obj)
{
+ (void) K; /* not needed, it's here for consistency */
while(ttispair(obj) && kis_marked(obj)) {
kunmark(obj);
obj = kcdr(obj);
@@ -168,15 +170,27 @@ void booleanp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
*/
/* 4.2.1 eq? */
+
+/* Helper (also used in equal?) */
+inline bool eq2p(klisp_State *K, TValue obj1, TValue obj2);
+
/* TEMP: for now it takes only two argument */
void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
(void) denv;
(void) xparams;
- bind_2p(K, "eq?", ptree, o1, o2);
- /* TEMP: for now this is the same as
- later it will change with numbers and immutable objects */
- kapply_cc(K, b2tv(tv_equal(o1, o2)));
+
+ bind_2p(K, "eq?", ptree, obj1, obj2);
+
+ bool res = eq2p(K, obj1, obj2);
+ kapply_cc(K, b2tv(res));
+}
+
+/* TEMP: for now this is the same as tv_equal,
+ later it will change with numbers and immutable objects */
+inline bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
+{
+ return (tv_equal(obj1, obj2));
}
/*
@@ -184,8 +198,178 @@ void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
*/
/* 4.3.1 equal? */
+
/* TEMP: for now it takes only two argument */
-/* TODO */
+/*
+** equal? is O(n) where n is the number of pairs.
+** Based on [1] "A linear algorithm for testing equivalence of finite automata"
+** by J.E. Hopcroft and R.M.Karp
+** List merging from [2] "A linear list merging algorithm"
+** by J.E. Hopcroft and J.D. Ullman
+** Idea to look up these papers from srfi 85:
+** "Recursive Equivalence Predicates" by William D. Clinger
+*/
+
+/* Helper */
+/* compare two objects and check to see if they are "equal?". */
+inline bool equal2p(klisp_State *K, TValue obj1, TValue obj2);
+
+void equalp(klisp_State *K, TValue *xparas, TValue ptree, TValue denv)
+{
+ (void) denv;
+ bind_2p(K, "equal?", ptree, obj1, obj2);
+ bool res = equal2p(K, obj1, obj2);
+ kapply_cc(K, b2tv(res));
+}
+
+
+/*
+** Helpers
+**
+** See [2] for details of the list merging algorithm.
+** Here are the implementation details:
+** The marks of the pairs are used to store the nodes of the trees
+** that represent the set of previous comparations of each pair.
+** They serve the function of the array in [2].
+** If a pair is unmarked, it was never compared (empty comparison set).
+** If a pair is marked, the mark object is either (#f . parent-node)
+** if the node is not the root, and (#t . n) where n is the number
+** of elements in the set, if the node is the root.
+** This pair also doubles as the "name" of the set in [2].
+*/
+
+/* find "name" of the set of this obj, if there isn't one create it,
+ if there is one, flatten its branch */
+inline TValue equal_find(klisp_State *K, TValue obj)
+{
+ /* GC: should root obj */
+ if (kis_unmarked(obj)) {
+ /* object wasn't compared before, create new set */
+ TValue new_node = kcons(K, KTRUE, i2tv(1));
+ kset_mark(obj, new_node);
+ return new_node;
+ } else {
+ TValue node = kget_mark(obj);
+
+ /* First obtain the root and a list of all the other objects in this
+ branch, as said above the root is the one with #t in its car */
+ /* NOTE: the stack is being used, so we must remember how many pairs we
+ push, we can't just pop 'till is empty */
+ int np = 0;
+ while(kis_false(kcar(node))) {
+ ks_spush(K, node);
+ node = kcdr(node);
+ ++np;
+ }
+ TValue root = node;
+
+ /* set all parents to root, to flatten the branch */
+ while(np--) {
+ node = ks_spop(K);
+ kset_cdr(node, root);
+ }
+ return root;
+ }
+}
+
+/* merge the smaller set into the big one, if both are equal just pick one */
+inline void equal_merge(klisp_State *K, TValue root1, TValue root2)
+{
+ /* K isn't needed but added for consistency */
+ (void)K;
+ int32_t size1 = ivalue(kcdr(root1));
+ int32_t size2 = ivalue(kcdr(root2));
+ TValue new_size = i2tv(size1 + size2);
+
+ if (size1 < size2) {
+ /* add root1 set (the smaller one) to root2 */
+ kset_cdr(root2, new_size);
+ kset_car(root1, KFALSE);
+ kset_cdr(root1, root2);
+ } else {
+ /* add root2 set (the smaller one) to root1 */
+ kset_cdr(root1, new_size);
+ kset_car(root2, KFALSE);
+ kset_cdr(root2, root1);
+ }
+}
+
+/* check to see if two objects were already compared, and return that. If they
+ weren't compared yet, merge their sets (and flatten their branches) */
+inline bool equal_find2_mergep(klisp_State *K, TValue obj1, TValue obj2)
+{
+ /* GC: should root root1 and root2 */
+ TValue root1 = equal_find(K, obj1);
+ TValue root2 = equal_find(K, obj2);
+ if (tv_equal(root1, root2)) {
+ /* they are in the same set => they were already compared */
+ return true;
+ } else {
+ equal_merge(K, root1, root2);
+ return false;
+ }
+}
+
+/*
+** See [1] for details, in this case the pairs form a possibly infinite "tree"
+** structure, and that can be seen as a finite automata, where each node is a
+** state, the car and the cdr are the transitions from that state to others,
+** and the leaves (the non-pair objects) are the final states.
+** Other way to see it is that, the key for determining equalness of two pairs
+** is: Check to see if they were already compared to each other.
+** If so, return #t, otherwise, mark them as compared to each other and
+** recurse on both cars and both cdrs.
+** The idea is that if assuming obj1 and obj2 are equal their components are
+** equal then they are effectively equal to each other.
+*/
+inline bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
+{
+ assert(ks_sisempty(K));
+
+ /* the stack has the elements to be compaired, always in pairs.
+ So the top should be compared with the one below, the third with
+ the fourth and so on */
+ ks_spush(K, obj1);
+ ks_spush(K, obj2);
+
+ /* if the stacks becomes empty, all pairs of elements were equal */
+ bool result = true;
+
+ while(!ks_sisempty(K)) {
+ obj2 = ks_spop(K);
+ obj1 = ks_spop(K);
+
+ if (!eq2p(K, obj1, obj2)) {
+ if (ttispair(obj1) && ttispair(obj2)) {
+ /* if they were already compaired, consider equal for now
+ otherwise they are equal if both their cars and cdrs are */
+ if (!equal_find2_mergep(K, obj1, obj2)) {
+ ks_spush(K, kcdr(obj1));
+ ks_spush(K, kcdr(obj2));
+ ks_spush(K, kcar(obj1));
+ ks_spush(K, kcar(obj2));
+ }
+ } else if (ttisstring(obj1) && ttisstring(obj2)) {
+ if (!kstring_equalp(obj1, obj2)) {
+ result = false;
+ break;
+ }
+ } else {
+ result = false;
+ break;
+ }
+ }
+ }
+
+ /* if result is false, the stack may not be empty */
+ ks_sclear(K);
+
+ unmark_tree(K, obj1);
+ unmark_tree(K, obj2);
+
+ return result;
+}
+
/*
** 4.4 Symbols
@@ -788,7 +972,7 @@ TValue kmake_ground_env(klisp_State *K)
*/
/* 4.3.1 equal? */
- /* TODO */
+ add_applicative(K, ground_env, "equal?", equalp, 0);
/*
** 4.4 Symbols
diff --git a/src/kobject.h b/src/kobject.h
@@ -189,6 +189,9 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttisenvironment(o) (tbasetype_(o) == K_TAG_ENVIRONMENT)
#define ttiscontinuation(o) (tbasetype_(o) == K_TAG_CONTINUATION)
+/* macros to easily check boolean values */
+#define kis_true(o_) (tv_equal((o_), KTRUE))
+#define kis_false(o_) (tv_equal((o_), KFALSE))
/*
** Union of all Kernel non heap-allocated values (except doubles)
diff --git a/src/kstring.c b/src/kstring.c
@@ -5,6 +5,7 @@
*/
#include <string.h>
+#include <stdbool.h>
#include "kstring.h"
#include "kobject.h"
@@ -61,3 +62,16 @@ TValue kstring_new(klisp_State *K, const char *buf, uint32_t size)
return gc2str(new_str);
}
+
+/* both obj1 and obj2 should be strings! */
+bool kstring_equalp(TValue obj1, TValue obj2)
+{
+ String *str1 = tv2str(obj1);
+ String *str2 = tv2str(obj2);
+
+ if (str1->size == str2->size) {
+ return (memcmp(str1->b, str2->b, str1->size) == 0);
+ } else {
+ return false;
+ }
+}
diff --git a/src/kstring.h b/src/kstring.h
@@ -7,6 +7,8 @@
#ifndef kstring_h
#define kstring_h
+#include <stdbool.h>
+
#include "kobject.h"
#include "kstate.h"
@@ -14,9 +16,12 @@
TValue kstring_new_empty(klisp_State *K);
TValue kstring_new(klisp_State *K, const char *buf, uint32_t size);
-#define kstring_buf(tv_) (((Symbol *) ((tv_).tv.v.gc))->b)
-#define kstring_size(tv_) (((Symbol *) ((tv_).tv.v.gc))->size)
+#define kstring_buf(tv_) (((String *) ((tv_).tv.v.gc))->b)
+#define kstring_size(tv_) (((String *) ((tv_).tv.v.gc))->size)
#define kstring_is_empty(tv_) (kstring_size(tv_) == 0)
+/* both obj1 and obj2 should be strings! */
+bool kstring_equalp(TValue obj1, TValue obj2);
+
#endif
