ref: 0a75bcd517c4550cee58a41ef2bb773eb6d4f95a
parent: db36f3938a3056c360396c8bf8663f846dd153b9
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Thu Sep 21 15:01:40 EDT 2023
Add a compare primtive. Should probably be changed.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
-v3.4
-885
-(($A :0 ((_674 _623) (($B ((($S' ($C (($C (($C $S') _3)) ((($C' ($C' $P)) ((($C' $B) _1) _606)) ($K ($K (_820 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] [ModuleName]"))))))) (($S (($S ((($S' _27) (($B _728) (_715 (_666 "-v")))) ((_745 _666) "-r"))) (($B (_709 (($O 46) $K))) (($B _774) (_714 ((_733 _796) "-i")))))) (($B (_775 _741)) ((($C' _711) (($B _774) (_714 ((_733 _796) "-o")))) (($O "out.comb") $K))))) (_715 ((_776 _816) ((_776 (_666 (($O 45) $K))) (_726 1)))))) (_737 ((_776 _816) (_666 "--")))))) (($A :1 ((($S' ($S' _674)) _39) (($B ($B ($B (_674 _705)))) ((($C' ($C' ($C' $C))) ((($C' $B) (($B ($C' $C)) ((($C' ($S' ($C' $C'))) (($B ($B ($B $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($S' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($S' ($C' ($C' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($C' ($S' ($C' $B))) (($B ($B ($B $C))) ((($S' $B) ($B' (($B ($S' $C')) (($B $B') (($B ($B _675)) ((($C' $B) (($B _775) (($B _695) ((($C' _811) _28) 0)))) (($B (_775 _698)) (($B (_711 "top level defns: ")) _654)))))))) ((($S' ($C' $B)) (($B $B') (($B $B') (($B $B') (($B ($B _675)) ((($C' $B) (($B _775) (($B _695) ((($C' _811) _28) 1)))) (_694 ($T (($B ($B (_775 _698))) ((($C' $B) (($B _711) ((($C' _711) _612) " = "))) (($C _431) $K))))))))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' _29))) ((($S' $B) (($B ($C' ($C' _675))) ((($C' $B) ($B' (($B _775) (($B _700) _31)))) (($B _711) ((($C' _711) (($B (_711 _2)) _654)) (($O 10) $K)))))) (($B ($B (_674 _705))) ((($C' $B) ($B' (($B _775) (($B _695) ((($C' _811) _28) 0))))) (($B ($B (_775 _698))) ((($C' ($C' _711)) (($B ($B (_711 "final pass "))) (($B ($B (_668 6))) (($B ($B _654)) _805)))) "ms"))))))) _22))))) ($C $P)))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($C _716)) _431))) (($C _729) (_746 0)))) $K))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B (($C' $B) (($B _776) (($B _711) ((($C' _711) (($B (_711 "(($A :")) _654)) (($O 32) $K))))))) ((($C' $B) (($B ($C' _776)) ($B _431))) (($B (_776 (_711 ") "))) (($C _776) (_711 (($O 41) $K))))))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _406)) $I))) ($BK $K))) $K))))) (($B (($S' _775) (($B _772) (($B (_775 _820)) (($B (_711 "main: findIdent: ")) _612))))) (($C' _642) _609)))) _649))) (($B ($B _646)) (($B (($C' _713) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _609))) $K)))))) (($C _729) (_746 0))))))) (($C _615) (_606 "main")))) (($B (_775 _405)) (($B (_775 _606)) (($B (_711 (($O 95) $K))) _654))))))) (($A :2 "v3.4\10&") (($A :3 (($B (_675 (_698 "Welcome to interactive MicroHs!"))) (($B (_675 (_698 "Type ':quit' to quit"))) ((($C' _674) (($B (_579 _5)) ((($C' $C) ($P _4)) _36))) ($K (_676 _822)))))) (($A :4 ((_711 ((_711 ((_711 ((_711 "module ") _7)) "(module ")) _7)) ") where\10&import Prelude\10&import Unsafe.Coerce\10&")) (($A :5 ((_580 ((_775 _589) ((_15 ".mhsi") "> "))) (($P _5) (($C (($S (($C $equal) ":quit")) (($C (($S (($C $equal) ":clear")) (($C (($S ((_733 _796) ":del ")) ((($C' _581) _11) _5))) ((($C' _581) (($B _6) (($B (_776 _664)) ((($C' _776) (($B _715) (($B (_776 _816)) (_734 _796)))) _663)))) _5)))) ((_581 (_6 (_778 _4))) _5)))) ((_775 _589) (_698 "Bye")))))) (($A :6 (($B (_775 _586)) (($B $T) (($B ($B ($B $C))) ($B $P))))) (($A :7 "Interactive") (($A :8 "_it") (($A :9 ((($C' _711) (_711 ((_711 ((_711 ((_711 _8) " :: Any\10&")) _8)) " = unsafeCoerce ("))) ")\10&")) (($A :10 (($B (_775 _698)) (_711 "Error: "))) (($A :11 (($B (_580 _588)) (($B $T) (($B $BK) (($B $BK) (($S ((($S' $S') ((_47 _50) $K)) (($B $BK) (($B ($B ((($S' _580) _12) (($B ($P (($B (_775 _589)) _10))) ($BK (($B _6) _778)))))) ((($C' ($C' _711)) ($C _711)) (($O 10) $K)))))) (($B $BK) ((($C' ($C' _580)) (($B ($B _12)) (($B (($C' _711) (($C _711) (($O 10) $K)))) _9))) (($P (($B (_775 _589)) _10)) _13))))))))) (($A :12 (($B (_580 _588)) (($B $T) (($C ((($C' $C') (($B $C') (($B $C') ($B' (($B _581) (($B (_775 _589)) (_700 ((_711 _7) ".hs")))))))) (($B (($S' ($C' ($S' _\ No newline at end of file
+v3.5
+886
+(($A :0 ((_674 _623) (($B ((($S' ($C (($C (($C $S') _3)) ((($C' ($C' $P)) ((($C' $B) _1) _606)) ($K ($K (_820 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] [ModuleName]"))))))) (($S (($S ((($S' _27) (($B _728) (_715 (_666 "-v")))) ((_745 _666) "-r"))) (($B (_709 (($O 46) $K))) (($B _774) (_714 ((_733 _796) "-i")))))) (($B (_775 _741)) ((($C' _711) (($B _774) (_714 ((_733 _796) "-o")))) (($O "out.comb") $K))))) (_715 ((_776 _816) ((_776 (_666 (($O 45) $K))) (_726 1)))))) (_737 ((_776 _816) (_666 "--")))))) (($A :1 ((($S' ($S' _674)) _39) (($B ($B ($B (_674 _705)))) ((($C' ($C' ($C' $C))) ((($C' $B) (($B ($C' $C)) ((($C' ($S' ($C' $C'))) (($B ($B ($B $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($S' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($S' ($C' ($C' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($C' ($S' ($C' $B))) (($B ($B ($B $C))) ((($S' $B) ($B' (($B ($S' $C')) (($B $B') (($B ($B _675)) ((($C' $B) (($B _775) (($B _695) ((($C' _811) _28) 0)))) (($B (_775 _698)) (($B (_711 "top level defns: ")) _654)))))))) ((($S' ($C' $B)) (($B $B') (($B $B') (($B $B') (($B ($B _675)) ((($C' $B) (($B _775) (($B _695) ((($C' _811) _28) 1)))) (_694 ($T (($B ($B (_775 _698))) ((($C' $B) (($B _711) ((($C' _711) _612) " = "))) (($C _431) $K))))))))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' _29))) ((($S' $B) (($B ($C' ($C' _675))) ((($C' $B) ($B' (($B _775) (($B _700) _31)))) (($B _711) ((($C' _711) (($B (_711 _2)) _654)) (($O 10) $K)))))) (($B ($B (_674 _705))) ((($C' $B) ($B' (($B _775) (($B _695) ((($C' _811) _28) 0))))) (($B ($B (_775 _698))) ((($C' ($C' _711)) (($B ($B (_711 "final pass "))) (($B ($B (_668 6))) (($B ($B _654)) _805)))) "ms"))))))) _22))))) ($C $P)))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($C _716)) _431))) (($C _729) (_746 0)))) $K))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B (($C' $B) (($B _776) (($B _711) ((($C' _711) (($B (_711 "(($A :")) _654)) (($O 32) $K))))))) ((($C' $B) (($B ($C' _776)) ($B _431))) (($B (_776 (_711 ") "))) (($C _776) (_711 (($O 41) $K))))))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _406)) $I))) ($BK $K))) $K))))) (($B (($S' _775) (($B _772) (($B (_775 _820)) (($B (_711 "main: findIdent: ")) _612))))) (($C' _642) _609)))) _649))) (($B ($B _646)) (($B (($C' _713) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _609))) $K)))))) (($C _729) (_746 0))))))) (($C _615) (_606 "main")))) (($B (_775 _405)) (($B (_775 _606)) (($B (_711 (($O 95) $K))) _654))))))) (($A :2 "v3.5\10&") (($A :3 (($B (_675 (_698 "Welcome to interactive MicroHs!"))) (($B (_675 (_698 "Type ':quit' to quit"))) ((($C' _674) (($B (_579 _5)) ((($C' $C) ($P _4)) _36))) ($K (_676 _822)))))) (($A :4 ((_711 ((_711 ((_711 ((_711 "module ") _7)) "(module ")) _7)) ") where\10&import Prelude\10&import Unsafe.Coerce\10&")) (($A :5 ((_580 ((_775 _589) ((_15 ".mhsi") "> "))) (($P _5) (($C (($S (($C $equal) ":quit")) (($C (($S (($C $equal) ":clear")) (($C (($S ((_733 _796) ":del ")) ((($C' _581) _11) _5))) ((($C' _581) (($B _6) (($B (_776 _664)) ((($C' _776) (($B _715) (($B (_776 _816)) (_734 _796)))) _663)))) _5)))) ((_581 (_6 (_778 _4))) _5)))) ((_775 _589) (_698 "Bye")))))) (($A :6 (($B (_775 _586)) (($B $T) (($B ($B ($B $C))) ($B $P))))) (($A :7 "Interactive") (($A :8 "_it") (($A :9 ((($C' _711) (_711 ((_711 ((_711 ((_711 _8) " :: Any\10&")) _8)) " = unsafeCoerce ("))) ")\10&")) (($A :10 (($B (_775 _698)) (_711 "Error: "))) (($A :11 (($B (_580 _588)) (($B $T) (($B $BK) (($B $BK) (($S ((($S' $S') ((_47 _50) $K)) (($B $BK) (($B ($B ((($S' _580) _12) (($B ($P (($B (_775 _589)) _10))) ($BK (($B _6) _778)))))) ((($C' ($C' _711)) ($C _711)) (($O 10) $K)))))) (($B $BK) ((($C' ($C' _580)) (($B ($B _12)) (($B (($C' _711) (($C _711) (($O 10) $K)))) _9))) (($P (($B (_775 _589)) _10)) _13))))))))) (($A :12 (($B (_580 _588)) (($B $T) (($C ((($C' $C') (($B $C') (($B $C') ($B' (($B _581) (($B (_775 _589)) (_700 ((_711 _7) ".hs")))))))) (($B (($S' ($C' ($S' _\ No newline at end of file
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -89,6 +89,9 @@
--primEqual :: forall a . a -> a -> Bool
--primEqual = primitive "equal"
+primCompare :: forall a . a -> a -> Int
+primCompare = primitive "compare"
+
primEqString :: [Char] -> [Char] -> Bool
primEqString = primitive "equal"
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -68,4 +68,4 @@
putStrLn $ "final pass " ++ padLeft 6 (showInt (t2-t1)) ++ "ms"
version :: String
-version = "v3.4\n"
+version = "v3.5\n"
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -83,6 +83,7 @@
("seq", primitive "seq"), ("error", primitive "error"), ("equal", primitive "equal"),+ ("compare", primitive "compare"), ("IO.>>=", primitive "IO.>>="), ("IO.>>", primitive "IO.>>"), ("IO.return", primitive "IO.return"),--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -135,7 +135,7 @@
/***************************************/
-#define VERSION "v3.4\n"
+#define VERSION "v3.5\n"
/* Keep permanent nodes for LOW_INT <= i < HIGH_INT */
#define LOW_INT (-10)
@@ -150,7 +150,7 @@
T_A, T_Y, T_SS, T_BB, T_CC, T_P, T_O, T_T, T_BK, T_ADD, T_SUB, T_MUL,
T_QUOT, T_REM, T_SUBR, T_UQUOT, T_UREM,
T_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ULT, T_ULE, T_UGT, T_UGE,
- T_ERROR, T_SEQ, T_EQUAL,
+ T_ERROR, T_SEQ, T_EQUAL, T_COMPARE,
T_IO_BIND, T_IO_THEN, T_IO_RETURN, T_IO_GETCHAR, T_IO_PUTCHAR,
T_IO_SERIALIZE, T_IO_DESERIALIZE, T_IO_OPEN, T_IO_CLOSE, T_IO_ISNULLHANDLE,
T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_IO_GETARGS, T_IO_DROPARGS,
@@ -446,6 +446,7 @@
{ "seq", T_SEQ }, { "error", T_ERROR }, { "equal", T_EQUAL },+ { "compare", T_COMPARE },/* IO primops */
{ "IO.>>=", T_IO_BIND }, { "IO.>>", T_IO_THEN },@@ -1130,6 +1131,7 @@
case T_UGE: fprintf(f, "$u>="); break;
case T_ERROR: fprintf(f, "$error"); break;
case T_EQUAL: fprintf(f, "$equal"); break;
+ case T_COMPARE: fprintf(f, "$compare"); break;
case T_SEQ: fprintf(f, "$seq"); break;
case T_IO_BIND: fprintf(f, "$IO.>>="); break;
case T_IO_THEN: fprintf(f, "$IO.>>"); break;
@@ -1338,9 +1340,18 @@
return name;
}
+/* Compares anything, but really only works well on strings.
+ * if p < q return -1
+ * if p > q return 1
+ * if p == q return 0
+ */
int
-equal(NODEPTR p, NODEPTR q)
+compare(NODEPTR p, NODEPTR q)
{+ int r;
+ value_t x, y;
+ FILE *f, *g;
+
top:
PUSH(q); /* save for GC */
p = evali(p);
@@ -1349,14 +1360,15 @@
enum node_tag ptag = GETTAG(p);
enum node_tag qtag = GETTAG(q);
if (ptag != qtag)
- return 0;
+ return ptag < qtag ? -1 : 1;
switch (ptag) {case T_AP:
PUSH(ARG(p));
PUSH(ARG(q));
- if (!equal(FUN(p), FUN(q))) {+ r = compare(FUN(p), FUN(q));
+ if (r != 0) {POP(2);
- return 0;
+ return r;
}
q = TOP(0);
p = TOP(1);
@@ -1364,11 +1376,15 @@
goto top;
case T_INT:
case T_IO_CCALL:
- return GETVALUE(p) == GETVALUE(q);
+ x = GETVALUE(p);
+ y = GETVALUE(q);
+ return x < y ? -1 : x > y ? 1 : 0;
case T_HDL:
- return HANDLE(p) == HANDLE(q);
+ f = HANDLE(p);
+ g = HANDLE(q);
+ return f < g ? -1 : f > g ? 1 : 0;
default:
- return 1;
+ return 0;
}
}
@@ -1496,7 +1512,8 @@
}
case T_SEQ: CHECK(2); eval(ARG(TOP(0))); POP(2); n = TOP(-1); y = ARG(n); GOIND(y); /* seq x y = eval(x); y */
- case T_EQUAL: r = equal(ARG(TOP(0)), ARG(TOP(1))); POP(2); n = TOP(-1); GOIND(r ? comTrue : combFalse);
+ case T_EQUAL: r = compare(ARG(TOP(0)), ARG(TOP(1))); POP(2); n = TOP(-1); GOIND(r==0 ? comTrue : combFalse);
+ case T_COMPARE: r = compare(ARG(TOP(0)), ARG(TOP(1))); POP(2); n = TOP(-1); SETINT(n, r); RET;
case T_IO_ISNULLHANDLE: CHKARGEV1(hdl = evalhandleN(x)); GOIND(hdl == 0 ? comTrue : combFalse);
--
⑨