Generic compare

regression/x86only/orig/test007.log

@@ -0,0 +1,24 @@
+-1
+1
+0
+-1
+1
+0
+-1
+1
+0
+0
+-1
+1
+-1
+1
+0
+-51
+51
+0
+-1
+3
+0
+0
+31
+-1

regression/x86only/test007.expr

@@ -0,0 +1,31 @@
+fun f (x) {
+  return fun (y) {return x + y}
+}
+
+write (compare (1, 2));
+write (compare (2, 1));
+write (compare (3, 3));
+write (compare (2, "abc")); 
+write (compare ("abc", 2)); 
+write (compare ("abc", "abc"));
+write (compare ("ab", "abc"));
+write (compare ("abc", "ab"));
+write (compare ([], []));
+write (compare (A, A));
+write (compare (A, B));
+write (compare (B, A));
+write (compare (A (1), A (1, 1)));
+write (compare (A (1, 1), A (1)));
+write (compare (f, f));
+write (compare (f, f(5)));
+write (compare (f(5), f)); 
+write (compare (f(5), f(5)));
+write (compare (f(5), f(6)));
+write (compare (f(6), f(5)));
+write (compare ({1, 2, 3}, {1, 2, 3}));
+write (compare ({1, [2], [[3]]}, {1, [2], [[3]]}));
+write (compare ({1, [2], [[3]]}, {1, [2], [3]}));
+write (compare ({1, [2], [3]}, {1, [2], [[3]]}))
+
+
+

regression/x86only/test007.i

@@ -0,0 +1 @@
+I,Std;

runtime/Std.i

@@ -1,6 +1,7 @@
 F,printf;
 F,read;
 F,write;
+F,compare;
 F,i__Infix_4343;
 L,"++",T,"+";
  

runtime/runtime.c

@@ -13,7 +13,7 @@
 # define alloc malloc
 # endif
 
-/* # define DEBUG_PRINT 1 */
+/*# define DEBUG_PRINT 1 */
 
 /* GC pool structure and data; declared here in order to allow debug print */
 typedef struct {
@@ -228,6 +228,62 @@ static void printValue (void *p) {
   }
 }
 
+int Lcompare (void *p, void *q) {
+# define COMPARE_AND_RETURN(x,y) do if (x != y) return BOX(x - y); while (0)
+  if (UNBOXED(p)) {
+    if (UNBOXED(q)) return BOX(UNBOX(p) - UNBOX(q));    
+    else return BOX(-1);
+  }
+  else if (UNBOXED(q)) return BOX(1);
+  else {
+    data *a = TO_DATA(p), *b = TO_DATA(q);
+    int ta = TAG(a->tag), tb = TAG(b->tag);
+    int la = LEN(a->tag), lb = LEN(b->tag);
+    int i;
+    
+    COMPARE_AND_RETURN (ta, tb);
+      
+    switch (ta) {
+    case STRING_TAG:
+      return BOX(strcmp (a->contents, b->contents));
+      
+    case CLOSURE_TAG:
+      COMPARE_AND_RETURN (((void**) a->contents)[0], ((void**) b->contents)[0]);
+      COMPARE_AND_RETURN (la, lb);
+      i = 1;
+      break;
+      
+    case ARRAY_TAG:
+      COMPARE_AND_RETURN (la, lb);
+      i = 0;
+      break;
+
+    case SEXP_TAG: {
+#ifndef DEBUG_PRINT
+      int ta = TO_SEXP(p)->tag, tb = TO_SEXP(q)->tag;      
+#else
+      int ta = GET_SEXP_TAG(TO_SEXP(p)->tag), tb = GET_SEXP_TAG(TO_SEXP(q)->tag);
+#endif      
+      COMPARE_AND_RETURN (ta, tb);
+      COMPARE_AND_RETURN (la, lb);
+      i = 0;
+      break;
+    }
+
+    default:
+      fprintf (stderr, "***** INTERNAL ERROR: invalid tag %d in compare *****\n", ta);
+      exit (255);
+    }
+
+    for (; i<la; i++) {
+      int c = Lcompare (((void**) a->contents)[i], ((void**) b->contents)[i]);
+      if (c != BOX(0)) return BOX(c);
+    }
+    
+    return BOX(0);
+  }
+}
+
 extern void* Belem (void *p, int i) {
   data *a = (data *)BOX(NULL);
   a = TO_DATA(p);
@@ -552,8 +608,8 @@ extern void __gc_root_scan_stack ();
 /*           Mark-and-copy                  */
 /* ======================================== */
 
-static size_t SPACE_SIZE = 128;
-//static size_t SPACE_SIZE = 1280;
+//static size_t SPACE_SIZE = 128;
+static size_t SPACE_SIZE = 1280;
 # define POOL_SIZE (2*SPACE_SIZE)
 
 static void swap (size_t ** a, size_t ** b) {

src/Language.ml

@@ -589,7 +589,6 @@ module Expr =
     ignore atr (
        match s with
        | ":"  -> Sexp   ("cons", [x; y])
-       (*| "++" -> Call   (Var "strcat", [x; y]) *)
        | ":=" -> Assign (x, y)
        | _ -> Binop  (s, x, y)
     )
@@ -770,7 +769,7 @@ module Infix =
 	`Lefta , ["!!"];
 	`Lefta , ["&&"];
 	`Nona  , ["=="; "!="; "<="; "<"; ">="; ">"];
-	`Lefta , [(*"++";*) "+" ; "-"];
+	`Lefta , ["+" ; "-"];
 	`Lefta , ["*" ; "/"; "%"];
       |]