ref: 623dfe528656c058603993aa3b5cd017b08b9e9e
parent: 3a8fc35efee110baffffb20adf49feb8d9769aa4
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Mon Sep 18 10:31:45 EDT 2023
Add getraw and flush primitives.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.4
-822
-(($A :0 ((_622 _575) (($B ((($S' ($C ((($C' ($S' _622)) (($B ($C _2)) _560)) (($B ($B (_622 _650))) ((($C' ($C' $C)) ((($C' ($S' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $S)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' $C))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($C' ($C' ($S' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($S' $B) ($B' ($B' (($B ($S' $B)) (($B ($B _623)) ((($C' $B) (($B _717) (($B _640) ((($C' _754) _8) 0)))) (($B (_717 _643)) (($B (_656 "top level defns: ")) _604)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _623)) ((($C' $B) (($B _717) (($B _640) ((($C' _754) _8) 1)))) (_639 ($T (($B ($B (_717 _643))) ((($C' $B) (($B _656) ((($C' _656) _565) " = "))) _392)))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _623))) ((($C' $B) ($B' (($B _717) (($B _645) _11)))) (($B _656) ((($C' _656) (($B (_656 _1)) _604)) (($O 10) $K)))))) (($B ($B (_622 _650))) ((($C' $B) ($B' (($B _717) (($B _640) ((($C' _754) _8) 0))))) (($B ($B (_717 _643))) ((($C' ($C' _656)) (($B ($B (_656 "final pass "))) (($B ($B (_617 6))) (($B ($B _604)) _748)))) "ms"))))))) _3))))) (($B (($C' $C) (($B ($C _661)) _392))) (($C _674) (_691 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) ((($C' ($C' ($C' ($C' _656)))) (($B ($C' ($C' _656))) ((($C' ($C' ($C' _656))) (($B (($C' $B) (($B _656) ((($C' _656) (($B (_656 "(($A :")) _604)) (($O 32) $K))))) ($B _392))) ") "))) (($O 41) $K)))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _368)) $I))) ($BK $K))) $K))))) (($B (($S' _717) (($B _714) (($B (_717 _761)) (($B (_656 "main: findIdent: ")) _565))))) (($C' _594) _562)))) _601))) (($B ($B _598)) ((($C' $B) (($B _658) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _562))) $K)))))) (($C _674) (_691 0))))))) ($T $A))) ($T $K))) $I)) (($B (_717 _367)) (($B (_717 _560)) (($B (_656 (($O 95) $K))) _604)))))))) (($S (($S ((($S' _7) (($B _673) (_660 (_615 "-v")))) ((_690 _615) "-r"))) (($B (_654 (($O 46) $K))) (($B _716) (_659 ((_678 _739) "-i")))))) (($B (_717 _685)) ((($C' _656) (($B _716) (_659 ((_678 _739) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _750) _673) 1)) (_761 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _685)) (_660 ((_718 _759) ((_718 (_615 (($O 45) $K))) (_671 1))))))) (_681 ((_718 _759) (_615 "--")))))) (($A :1 "v3.4\10&") (($A :2 ((($S' ($S' _622)) _16) (($B ($B ($B (_622 _650)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _623) (($B (_717 _641)) (($B (_717 (_672 1000000))) _192)))))) (($B ($B ($B ($B (_622 _650))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _623))) ((($C' $B) ($B' (($B _717) (($B _640) ((($C' _754) _8) 0))))) (($B ($B (_717 _643))) ((($C' ($C' _656)) (($B ($B (_656 "combinator conversion "))) (($B ($B (_617 6))) (($B ($B _604)) _748)))) "ms")))))) (($B ($B _624)) (($B $P) (($C _568) (_560 "main")))))))) (_658 ($T ((($C' ($C' $O)) ((($C' $B) $P) _395)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_622 _575)))) (($B ($B ($B (($C' _576) ((($C' _743) (($B _673) (_681 ((_718 _759) (_615 "--"))))) 1))))) (($B ($B ($B (_717 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _551))) (($C' ($C' _658)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _717) (($B _714) (($B (_717 _761)) (($B (_656 "not found ")) _565))))) ($C _552))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _394))) (($B (_717 (_714 (_761 "primlookup")))) (($C (_696 _615)) _5)))) $K))) (_761 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "
\ No newline at end of file
+824
+(($A :0 ((_622 _575) (($B ((($S' ($C ((($C' ($S' _622)) (($B ($C _2)) _560)) (($B ($B (_622 _651))) ((($C' ($C' $C)) ((($C' ($S' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $S)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' $C))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($C' ($C' ($S' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($S' $B) ($B' ($B' (($B ($S' $B)) (($B ($B _623)) ((($C' $B) (($B _718) (($B _641) ((($C' _755) _8) 0)))) (($B (_718 _644)) (($B (_657 "top level defns: ")) _604)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _623)) ((($C' $B) (($B _718) (($B _641) ((($C' _755) _8) 1)))) (_640 ($T (($B ($B (_718 _644))) ((($C' $B) (($B _657) ((($C' _657) _565) " = "))) _392)))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _623))) ((($C' $B) ($B' (($B _718) (($B _646) _11)))) (($B _657) ((($C' _657) (($B (_657 _1)) _604)) (($O 10) $K)))))) (($B ($B (_622 _651))) ((($C' $B) ($B' (($B _718) (($B _641) ((($C' _755) _8) 0))))) (($B ($B (_718 _644))) ((($C' ($C' _657)) (($B ($B (_657 "final pass "))) (($B ($B (_617 6))) (($B ($B _604)) _749)))) "ms"))))))) _3))))) (($B (($C' $C) (($B ($C _662)) _392))) (($C _675) (_692 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) ((($C' ($C' ($C' ($C' _657)))) (($B ($C' ($C' _657))) ((($C' ($C' ($C' _657))) (($B (($C' $B) (($B _657) ((($C' _657) (($B (_657 "(($A :")) _604)) (($O 32) $K))))) ($B _392))) ") "))) (($O 41) $K)))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _368)) $I))) ($BK $K))) $K))))) (($B (($S' _718) (($B _715) (($B (_718 _762)) (($B (_657 "main: findIdent: ")) _565))))) (($C' _594) _562)))) _601))) (($B ($B _598)) ((($C' $B) (($B _659) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _562))) $K)))))) (($C _675) (_692 0))))))) ($T $A))) ($T $K))) $I)) (($B (_718 _367)) (($B (_718 _560)) (($B (_657 (($O 95) $K))) _604)))))))) (($S (($S ((($S' _7) (($B _674) (_661 (_615 "-v")))) ((_691 _615) "-r"))) (($B (_655 (($O 46) $K))) (($B _717) (_660 ((_679 _740) "-i")))))) (($B (_718 _686)) ((($C' _657) (($B _717) (_660 ((_679 _740) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _751) _674) 1)) (_762 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _686)) (_661 ((_719 _760) ((_719 (_615 (($O 45) $K))) (_672 1))))))) (_682 ((_719 _760) (_615 "--")))))) (($A :1 "v3.4\10&") (($A :2 ((($S' ($S' _622)) _16) (($B ($B ($B (_622 _651)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _623) (($B (_718 _642)) (($B (_718 (_673 1000000))) _192)))))) (($B ($B ($B ($B (_622 _651))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _623))) ((($C' $B) ($B' (($B _718) (($B _641) ((($C' _755) _8) 0))))) (($B ($B (_718 _644))) ((($C' ($C' _657)) (($B ($B (_657 "combinator conversion "))) (($B ($B (_617 6))) (($B ($B _604)) _749)))) "ms")))))) (($B ($B _624)) (($B $P) (($C _568) (_560 "main")))))))) (_659 ($T ((($C' ($C' $O)) ((($C' $B) $P) _395)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_622 _575)))) (($B ($B ($B (($C' _576) ((($C' _744) (($B _674) (_682 ((_719 _760) (_615 "--"))))) 1))))) (($B ($B ($B (_718 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _551))) (($C' ($C' _659)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _718) (($B _715) (($B (_718 _762)) (($B (_657 "not found ")) _565))))) ($C _552))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _394))) (($B (_718 (_715 (_762 "primlookup")))) (($C (_697 _615)) _5)))) $K))) (_762 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "
\ No newline at end of file
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -150,6 +150,7 @@
primHDeserialize = undefined
primHPrint = undefined
primHClose = hClose
+primHFlush = hFlush
primStdin = stdin
primStdout = stdout
primStderr = stderr
@@ -164,3 +165,5 @@
-- Current time (since 1970-01-01T00:00:00UTC) in ms
primGetTimeMilli :: IO Int
primGetTimeMilli = floor . (1000 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds <$> getCurrentTime
+primGetRaw :: IO Int
+primGetRaw = return (-1) -- not implemented
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -122,6 +122,8 @@
primHDeserialize = primitive "IO.deserialize"
primHClose :: Handle -> IO ()
primHClose = primitive "IO.close"
+primHFlush :: Handle -> IO ()
+primHFlush = primitive "IO.flush"
primStdin :: Handle
primStdin = primitive "IO.stdin"
primStdout :: Handle
@@ -136,6 +138,8 @@
primPerformIO = primitive "IO.performIO"
primGetTimeMilli :: IO Int
primGetTimeMilli = primitive "IO.getTimeMilli"
+primGetRaw :: IO Int
+primGetRaw = primitive "IO.getRaw"
primWithDropArgs :: forall a . Int -> IO a -> IO a
primWithDropArgs i ioa = primThen (primDropArgs i) ioa
--- a/lib/System/IO.hs
+++ b/lib/System/IO.hs
@@ -31,6 +31,8 @@
hDeserialize = primHDeserialize
hClose :: Handle -> IO ()
hClose = primHClose
+hFlush :: Handle -> IO ()
+hFlush = primHFlush
stdin :: Handle
stdin = primStdin
stdout :: Handle
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -83,11 +83,13 @@
("IO.>>", primitive "IO.>>"), ("IO.return", primitive "IO.return"), ("IO.getChar", primitive "IO.getChar"),+ ("IO.getRaw", primitive "IO.getRaw"), ("IO.putChar", primitive "IO.putChar"), ("IO.serialize", primitive "IO.serialize"), ("IO.deserialize", primitive "IO.deserialize"), ("IO.open", primitive "IO.open"), ("IO.close", primitive "IO.close"),+ ("IO.flush", primitive "IO.flush"), ("IO.isNullHandle", primitive "IO.isNullHandle"), ("IO.stdin", primitive "IO.stdin"), ("IO.stdout", primitive "IO.stdout"),--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -14,6 +14,7 @@
#define INTTABLE 1 /* use fixed table of small INT nodes */
#define SANITY 1 /* do some sanity checks */
#define STACKOVL 1 /* check for stack overflow */
+#define GETRAW 1 /* implement raw character get */
typedef intptr_t value_t; /* Make value the same size as pointers, since they are in a union */
#define PRIvalue PRIdPTR
@@ -79,6 +80,12 @@
return 0;
}
+int
+getraw()
+{+ return -1; /* too tedious */
+}
+
#else /* defined(_MSC_VER) */
#include <sys/time.h>
@@ -85,8 +92,48 @@
#define PCOMMA "'"
+#if GETRAW
+#include <termios.h>
+#include <unistd.h>
+
+/*
+ * Set the terminal in raw mode and read a single character.
+ * Return this character, or -1 on any kind of failure.
+ */
+int
+getraw(void)
+{+ struct termios old, new;
+ char c;
+ int r;
+
+ if (tcgetattr(0, &old))
+ return -1;
+ cfmakeraw(&new);
+ if (tcsetattr(0, TCSANOW, &new))
+ return -1;
+ r = read(0, &c, 1);
+ (void)tcsetattr(0, TCSANOW, &old);
+ if (r == 1)
+ return c;
+ else
+ return -1;
+}
+#else /* GETRAW */
+
+int
+getraw()
+{+ return -1; /* not implemented */
+}
+
+#endif /* GETRAW */
+
#endif /* !defined(_MSC_VER) */
+
+/***************************************/
+
#define VERSION "v3.4\n"
/* Keep permanent nodes for LOW_INT <= i < HIGH_INT */
@@ -108,7 +155,7 @@
T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_IO_GETARGS, T_IO_DROPARGS,
T_IO_PERFORMIO,
T_IO_GETTIMEMILLI, T_IO_PRINT,
- T_IO_CCALL,
+ T_IO_CCALL, T_IO_GETRAW, T_IO_FLUSH,
T_STR,
T_LAST_TAG,
};
@@ -395,6 +442,7 @@
{ "IO.>>", T_IO_THEN }, { "IO.return", T_IO_RETURN }, { "IO.getChar", T_IO_GETCHAR },+ { "IO.getRaw", T_IO_GETRAW }, { "IO.putChar", T_IO_PUTCHAR }, { "IO.serialize", T_IO_SERIALIZE }, { "IO.print", T_IO_PRINT },@@ -401,6 +449,7 @@
{ "IO.deserialize", T_IO_DESERIALIZE }, { "IO.open", T_IO_OPEN }, { "IO.close", T_IO_CLOSE },+ { "IO.flush", T_IO_FLUSH }, { "IO.isNullHandle", T_IO_ISNULLHANDLE }, { "IO.stdin", T_IO_STDIN }, { "IO.stdout", T_IO_STDOUT },@@ -1072,6 +1121,7 @@
case T_IO_THEN: fprintf(f, "$IO.>>"); break;
case T_IO_RETURN: fprintf(f, "$IO.return"); break;
case T_IO_GETCHAR: fprintf(f, "$IO.getChar"); break;
+ case T_IO_GETRAW: fprintf(f, "$IO.getRaw"); break;
case T_IO_PUTCHAR: fprintf(f, "$IO.putChar"); break;
case T_IO_SERIALIZE: fprintf(f, "$IO.serialize"); break;
case T_IO_PRINT: fprintf(f, "$IO.print"); break;
@@ -1078,6 +1128,7 @@
case T_IO_DESERIALIZE: fprintf(f, "$IO.deserialize"); break;
case T_IO_OPEN: fprintf(f, "$IO.open"); break;
case T_IO_CLOSE: fprintf(f, "$IO.close"); break;
+ case T_IO_FLUSH: fprintf(f, "$IO.flush"); break;
case T_IO_ISNULLHANDLE: fprintf(f, "$IO.isNullHandle"); break;
case T_IO_GETARGS: fprintf(f, "$IO.getArgs"); break;
case T_IO_DROPARGS: fprintf(f, "$IO.dropArgs"); break;
@@ -1426,6 +1477,7 @@
case T_IO_THEN:
case T_IO_RETURN:
case T_IO_GETCHAR:
+ case T_IO_GETRAW:
case T_IO_PUTCHAR:
case T_IO_SERIALIZE:
case T_IO_PRINT:
@@ -1432,6 +1484,7 @@
case T_IO_DESERIALIZE:
case T_IO_OPEN:
case T_IO_CLOSE:
+ case T_IO_FLUSH:
case T_IO_GETARGS:
case T_IO_DROPARGS:
case T_IO_GETTIMEMILLI:
@@ -1522,6 +1575,11 @@
c = getc(hdl);
n = mkInt(c);
RETIO(n);
+ case T_IO_GETRAW:
+ CHECKIO(0);
+ c = getraw();
+ n = mkInt(c);
+ RETIO(n);
case T_IO_PUTCHAR:
CHECKIO(2);
hdl = evalhandle(ARG(TOP(1)));
@@ -1553,6 +1611,13 @@
n = evali(ARG(TOP(1)));
HANDLE(n) = 0;
fclose(hdl);
+ RETIO(combUnit);
+ case T_IO_FLUSH:
+ CHECKIO(1);
+ hdl = evalhandle(ARG(TOP(1)));
+ n = evali(ARG(TOP(1)));
+ HANDLE(n) = 0;
+ fflush(hdl);
RETIO(combUnit);
case T_IO_OPEN:
CHECKIO(2);
--
⑨