diff --git a/regression/x86only/orig/test007.log b/regression/x86only/orig/test007.log new file mode 100644 index 000000000..38c9e0579 --- /dev/null +++ b/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 diff --git a/regression/x86only/test007.expr b/regression/x86only/test007.expr new file mode 100644 index 000000000..55d16b87f --- /dev/null +++ b/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]]})) + + + diff --git a/regression/x86only/test007.i b/regression/x86only/test007.i new file mode 100644 index 000000000..517e120ae --- /dev/null +++ b/regression/x86only/test007.i @@ -0,0 +1 @@ +I,Std; diff --git a/runtime/Std.i b/runtime/Std.i index 1e8945def..1c993d73a 100644 --- a/runtime/Std.i +++ b/runtime/Std.i @@ -1,6 +1,7 @@ F,printf; F,read; F,write; +F,compare; F,i__Infix_4343; L,"++",T,"+"; diff --git a/runtime/runtime.c b/runtime/runtime.c index efe6b7de1..c498ab3ed 100644 --- a/runtime/runtime.c +++ b/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 (; icontents)[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) { diff --git a/src/Language.ml b/src/Language.ml index 1ad4b4b07..b47669ce0 100644 --- a/src/Language.ml +++ 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 , ["*" ; "/"; "%"]; |]