[plt-scheme] equal? for native extension types [patch]

Hi,

equal? knows about some built-in types and structs -- and that's about it.
If you happen to define extension types with meaningful equality tests,
then you are stuck. Quite frustrating.

The attached patch adds "scheme_set_type_equalp" to allow extensions to
register per-type equality functions and extends scheme_equal to treat
them accordingly. It applies against svn revision 5592.

The attached test.c is a trivial extension that uses it:
> (load-extension "test.so")
> (define x1 (make-dummy 1))
> (define x2 (make-dummy 1))
> (define x3 (make-dummy 2))
> (equal? x1 x2)
#t
> (equal? x1 x3)
#f
> (eq? x1 x2)
#f

-- vyzo
-------------- next part --------------
Index: src/mzscheme/include/scheme.h
===================================================================
--- src/mzscheme/include/scheme.h	(revision 5592)
+++ src/mzscheme/include/scheme.h	(working copy)
@@ -325,6 +325,8 @@
 typedef struct Scheme_Print_Params Scheme_Print_Params;
 typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Print_Params *pp);
 
+typedef int (*Scheme_Type_Equal)(Scheme_Object *obj1, Scheme_Object *obj2);
+
 /* This file defines all the built-in types */
 #ifdef INCLUDE_WITHOUT_PATHS
 # include "stypes.h"
Index: src/mzscheme/src/schemef.h
===================================================================
--- src/mzscheme/src/schemef.h	(revision 5592)
+++ src/mzscheme/src/schemef.h	(working copy)
@@ -1023,3 +1023,5 @@
 MZ_EXTERN void scheme_signal_received(void);
 
 MZ_EXTERN int scheme_char_strlen(const mzchar *s);
+
+MZ_EXTERN void scheme_set_type_equalp(Scheme_Type type, Scheme_Type_Equal f);
Index: src/mzscheme/src/type.c
===================================================================
--- src/mzscheme/src/type.c	(revision 5592)
+++ src/mzscheme/src/type.c	(working copy)
@@ -27,6 +27,7 @@
 
 Scheme_Type_Reader *scheme_type_readers;
 Scheme_Type_Writer *scheme_type_writers;
+Scheme_Type_Equal *scheme_type_equalps;
 
 static char **type_names;
 static Scheme_Type maxtype, allocmax;
@@ -42,6 +43,7 @@
   REGISTER_SO(type_names);
   REGISTER_SO(scheme_type_readers);
   REGISTER_SO(scheme_type_writers);
+  REGISTER_SO(scheme_type_equalps);
   
   maxtype = _scheme_last_type_;
   allocmax = maxtype + 10;
@@ -60,6 +62,10 @@
   n = allocmax * sizeof(Scheme_Type_Writer);
   memset((char *)scheme_type_writers, 0, n);
 
+  scheme_type_equalps = MALLOC_N_ATOMIC(Scheme_Type_Equal, allocmax);
+  n = allocmax * sizeof(Scheme_Type_Equal);
+  memset((char *)scheme_type_equalps, 0, n);
+
 #ifdef MEMORY_COUNTING_ON
   scheme_type_table_count += n;
 #endif  
@@ -270,6 +276,11 @@
     memcpy(naya, scheme_type_writers, maxtype * sizeof(Scheme_Type_Writer));
     scheme_type_writers = (Scheme_Type_Writer *)naya;
 
+    naya = scheme_malloc_atomic(n = allocmax * sizeof(Scheme_Type_Equal));
+    memset((char *)naya, 0, n);
+    memcpy(naya, scheme_type_equalps, maxtype * sizeof(Scheme_Type_Equal));
+    scheme_type_equalps = (Scheme_Type_Equal *)naya;
+
 #ifdef MEMORY_COUNTING_ON
   scheme_type_table_count += 20 * (sizeof(Scheme_Type_Reader)
 				   + sizeof(Scheme_Type_Writer));
@@ -309,6 +320,14 @@
   scheme_type_writers[t] = f;
 }
 
+void scheme_set_type_equalp(Scheme_Type t, Scheme_Type_Equal f)
+{
+  if (t < 0 || t >= maxtype)
+    return;
+
+  scheme_type_equalps[t] = f;
+}
+
 int scheme_num_types(void)
 {
   return maxtype;
Index: src/mzscheme/src/schpriv.h
===================================================================
--- src/mzscheme/src/schpriv.h	(revision 5592)
+++ src/mzscheme/src/schpriv.h	(working copy)
@@ -2743,4 +2743,7 @@
 #define SCHEME_SYM_PARALLELP(o) (MZ_OPT_HASH_KEY(&((Scheme_Symbol *)(o))->iso) & 0x2)
 #define SCHEME_SYM_WEIRDP(o) (MZ_OPT_HASH_KEY(&((Scheme_Symbol *)(o))->iso) & 0x3)
 
+/* extension type equality */
+extern Scheme_Type_Equal *scheme_type_equalps;
+
 #endif /* __mzscheme_private__ */
Index: src/mzscheme/src/bool.c
===================================================================
--- src/mzscheme/src/bool.c	(revision 5592)
+++ src/mzscheme/src/bool.c	(working copy)
@@ -272,6 +272,8 @@
     return scheme_bucket_table_equal((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2);
   } else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_wrap_chunk_type)) {
     return vector_equal(obj1, obj2);
+  } else if (scheme_type_equalps[SCHEME_TYPE(obj1)]) {
+    return scheme_type_equalps[SCHEME_TYPE(obj1)](obj1, obj2);
   } else
     return 0;
 }
-------------- next part --------------
#include "escheme.h"

typedef struct {
  Scheme_Type type;
  int x;
} dummy;

static Scheme_Type dummy_type;

static Scheme_Object *make_dummy( int argc, Scheme_Object **argv ) {
  dummy *v;
  v = (dummy*)scheme_malloc_tagged( sizeof(dummy) );
  v->type = dummy_type;
  v->x = SCHEME_INT_VAL( argv[0] );
  return (Scheme_Object*)v;
}

static int dummy_equalp( Scheme_Object *o1, Scheme_Object* o2 ) {
  return ((dummy*)o1)->x == ((dummy*)o2)->x;
}

Scheme_Object *scheme_reload(Scheme_Env *env) {
  scheme_add_global( "make-dummy",
   scheme_make_prim_w_arity( make_dummy,
                             "make-dummy",
                             1, 1),
                     env );

  return scheme_void;
}


Scheme_Object *scheme_initialize(Scheme_Env *env) {
  dummy_type = scheme_make_type("<dummy>");
  scheme_set_type_equalp( dummy_type, dummy_equalp );
  return scheme_reload( env );
}

Scheme_Object *scheme_module_name() {
  return scheme_false;
}