shithub: MicroHs

Download patch

ref: 457e7f63ee14bf2932f2cc98e5eb4d8fa434a7d3
parent: 7f7c5ed91ee14971a0aaa012d4cb434a5530da95
author: Lennart Augustsson <lennart@augustsson.net>
date: Thu Nov 2 16:07:41 EDT 2023 

Primitive to convert Int to Double


--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
 v4.0
-1212
-((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _122) ((B _12) _1)) _239))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _238))) ((A :10 (((S' P) _2) (((C' _13) _1) _973))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _119) _12) _111))) ((A :20 (((S' B) _14) (((C' _122) _12) _112))) ((A :21 _1045) ((A :22 ((B _1088) _21)) ((A :23 (((S' _1088) _21) I)) ((A :24 _1015) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1044) ((C _110) _26))) ((A :28 (((C' _27) ((_118 _1058) _91)) ((_110 (_34 _1060)) _90))) ((A :29 ((B ((S _1088) (_34 _1060))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _238)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _239)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _973)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _973))) ((A :46 ((C _43) _111)) ((A :47 ((B _113) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _113) _48)) ((A :50 T) ((A :51 ((_117 ((B (B (_108 _50))) ((B ((C' C) _54)) (B P)))) (_121 _51))) ((A :52 (((((_11 _51) ((B (_108 _50)) P)) (_38 _53)) ((B (B (_108 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_108 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_110 _293)) _54)) ((A :56 ((B (_108 _50)) (B (P _973)))) ((A :57 ((B (_108 _50)) (BK (P _973)))) ((A :58 ((_108 _50) ((S P) I))) ((A :59 ((B (_108 _50)) ((C (S' P)) I))) ((A :60 ((_95 ((C ((C S') _64)) I)) (_99 _60))) ((A :61 (((_1186 (K ((P (_1195 "False")) (_1195 "True")))) (_1191 _61)) (_1192 _61))) ((A :62 (R _67)) ((A :63 (T _66)) ((A :64 ((P _67) _66)) ((A :65 _67) ((A :66 K) ((A :67 A) ((A :68 ((_95 _1009) _1010)) ((A :69 ((((((((_271 _68) (_280 _69)) _1011) _1012) _1013) _1014) (_285 _69)) (_286 _69))) ((A :70 ((_95 _1019) (_99 _70))) ((A :71 ((((((((_271 _70) _1018) (((C' (C' (_96 _287))) _1018) _290)) (((C' (C' (_97 _287))) _1018) _292)) (((C' (C' (_96 _287))) _1018) _292)) (((C' (C' (_97 _287))) _1018) _292)) (_285 _71)) (_286 _71))) ((A :72 _1020) ((A :73 _1021) ((A :74 (((S' _63) (_1012 #97)) ((C _1012) #122))) ((A :75 (((S' _63) (_1012 #65)) ((C _1012) #90))) ((A :76 (((S' _62) _74) _75)) ((A :77 (((S' _63) (_1012 #48)) ((C _1012) #57))) ((A :78 (((S' _62) _76) _77)) ((A :79 (((S' _63) (_1012 #32)) ((C _1012) #126))) ((A :80 (((S' _62) ((C (_96 _68)) #32)) (((S' _62) ((C (_96 _68)) #9)) ((C (_96 _68)) #10)))) ((A :81 ((S ((S (((S' _63) (_1012 #65)) ((C _1012) #90))) (_67 (((noMatch "lib/Data/Char.hs") #80) #9)))) ((B _72) (((C' (_256 _123)) (((C' (_257 _123)) _73) (_73 #65))) (_73 #97))))) ((A :82 ((S ((S (((S' _63) (_1012 #97)) ((C _1012) #97))) (_67 (((noMatch "lib/Data/Char.hs") #84) #9)))) ((B _72) (((C' (_256 _123)) (((C' (_257 _123)) _73) (_73 #97))) (_73 #65))))) ((A :83 (((_1186 (K ((C ((S ((C ==) #39)) ((B (_110 (_1194 #39))) (((C' _110) ((B _1195) _84)) (_1194 #39))))) (_1195 "'\92&''")))) (_1191 _83)) ((B (_110 (_1194 #34))) (Y ((B (P (_1194 #34))) (((S' C) ((B ((S' S') ((C (_96 _68)) #34))) ((C' B) ((B _110) ((B _1195) _84))))) (B (_110 (_1195 "\92&\34&"))))))))) ((A :84 (((C' Y) (((S' B) ((B P) ((S ((S _79) ((B (_240 "'\92&")) (((C' _240) ((B (_1188 _127)) _73)) (
\ No newline at end of file
+1213
+((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _122) ((B _12) _1)) _239))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _238))) ((A :10 (((S' P) _2) (((C' _13) _1) _973))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _119) _12) _111))) ((A :20 (((S' B) _14) (((C' _122) _12) _112))) ((A :21 _1046) ((A :22 ((B _1089) _21)) ((A :23 (((S' _1089) _21) I)) ((A :24 _1016) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1045) ((C _110) _26))) ((A :28 (((C' _27) ((_118 _1059) _91)) ((_110 (_34 _1061)) _90))) ((A :29 ((B ((S _1089) (_34 _1061))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _238)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _239)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _973)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _973))) ((A :46 ((C _43) _111)) ((A :47 ((B _113) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _113) _48)) ((A :50 T) ((A :51 ((_117 ((B (B (_108 _50))) ((B ((C' C) _54)) (B P)))) (_121 _51))) ((A :52 (((((_11 _51) ((B (_108 _50)) P)) (_38 _53)) ((B (B (_108 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_108 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_110 _293)) _54)) ((A :56 ((B (_108 _50)) (B (P _973)))) ((A :57 ((B (_108 _50)) (BK (P _973)))) ((A :58 ((_108 _50) ((S P) I))) ((A :59 ((B (_108 _50)) ((C (S' P)) I))) ((A :60 ((_95 ((C ((C S') _64)) I)) (_99 _60))) ((A :61 (((_1187 (K ((P (_1196 "False")) (_1196 "True")))) (_1192 _61)) (_1193 _61))) ((A :62 (R _67)) ((A :63 (T _66)) ((A :64 ((P _67) _66)) ((A :65 _67) ((A :66 K) ((A :67 A) ((A :68 ((_95 _1010) _1011)) ((A :69 ((((((((_271 _68) (_280 _69)) _1012) _1013) _1014) _1015) (_285 _69)) (_286 _69))) ((A :70 ((_95 _1020) (_99 _70))) ((A :71 ((((((((_271 _70) _1019) (((C' (C' (_96 _287))) _1019) _290)) (((C' (C' (_97 _287))) _1019) _292)) (((C' (C' (_96 _287))) _1019) _292)) (((C' (C' (_97 _287))) _1019) _292)) (_285 _71)) (_286 _71))) ((A :72 _1021) ((A :73 _1022) ((A :74 (((S' _63) (_1013 #97)) ((C _1013) #122))) ((A :75 (((S' _63) (_1013 #65)) ((C _1013) #90))) ((A :76 (((S' _62) _74) _75)) ((A :77 (((S' _63) (_1013 #48)) ((C _1013) #57))) ((A :78 (((S' _62) _76) _77)) ((A :79 (((S' _63) (_1013 #32)) ((C _1013) #126))) ((A :80 (((S' _62) ((C (_96 _68)) #32)) (((S' _62) ((C (_96 _68)) #9)) ((C (_96 _68)) #10)))) ((A :81 ((S ((S (((S' _63) (_1013 #65)) ((C _1013) #90))) (_67 (((noMatch "lib/Data/Char.hs") #80) #9)))) ((B _72) (((C' (_256 _123)) (((C' (_257 _123)) _73) (_73 #65))) (_73 #97))))) ((A :82 ((S ((S (((S' _63) (_1013 #97)) ((C _1013) #97))) (_67 (((noMatch "lib/Data/Char.hs") #84) #9)))) ((B _72) (((C' (_256 _123)) (((C' (_257 _123)) _73) (_73 #97))) (_73 #65))))) ((A :83 (((_1187 (K ((C ((S ((C ==) #39)) ((B (_110 (_1195 #39))) (((C' _110) ((B _1196) _84)) (_1195 #39))))) (_1196 "'\92&''")))) (_1192 _83)) ((B (_110 (_1195 #34))) (Y ((B (P (_1195 #34))) (((S' C) ((B ((S' S') ((C (_96 _68)) #34))) ((C' B) ((B _110) ((B _1196) _84))))) (B (_110 (_1196 "\92&\34&"))))))))) ((A :84 (((C' Y) (((S' B) ((B P) ((S ((S _79) ((B (_240 "'\92&")) (((C' _240) ((B (_1189 _127)) _73)) (
\ No newline at end of file
--- a/ghc/Primitives.hs
+++ b/ghc/Primitives.hs
@@ -167,6 +167,9 @@
 primDoubleRead :: [Char] -> Double
 primDoubleRead = read
 
+primDoubleFromInt :: Int -> Double
+primDoubleFromInt = fromIntegral
+
 ------
 
 primBind         :: IO a -> (a -> IO b) -> IO b
--- a/lib/Data/Double.hs
+++ b/lib/Data/Double.hs
@@ -20,7 +20,7 @@
       LT -> -1.0
       EQ ->  0.0
       GT ->  1.0
-  fromInt x = error "Double.fromInt unimplemented"
+  fromInt = primDoubleFromInt
 
 instance Fractional Double where
   (/) = primDoubleDiv
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -59,6 +59,8 @@
 primDoubleShow = primitive "fshow"
 primDoubleRead :: [Char] -> Double
 primDoubleRead = primitive "fread"
+primDoubleFromInt :: Int -> Double
+primDoubleFromInt = primitive "itof"
 
 primWordAdd :: Word -> Word -> Word
 primWordAdd  = primitive "+"
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -93,6 +93,7 @@
   ("fge", primitive "fge"),
   ("fshow", primitive "fshow"),
   ("fread", primitive "fread"),
+  ("itof", primitive "itof"),
   ("seq", primitive "seq"),
   ("error", primitive "error"),
   ("equal", primitive "equal"),
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -149,7 +149,7 @@
 enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_DOUBLE, T_HDL, T_S, T_K, T_I, T_B, T_C,
                 T_A, T_Y, T_SS, T_BB, T_CC, T_P, T_R, T_O, T_T, T_BK, T_ADD, T_SUB, T_MUL,
                 T_QUOT, T_REM, T_SUBR, T_UQUOT, T_UREM,
-                T_FADD, T_FSUB, T_FMUL, T_FDIV,
+                T_FADD, T_FSUB, T_FMUL, T_FDIV, T_ITOF,
                 T_FEQ, T_FNE, T_FLT, T_FLE, T_FGT, T_FGE, T_FSHOW, T_FREAD,
                 T_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ULT, T_ULE, T_UGT, T_UGE,
                 T_ERROR, T_NODEFAULT, T_NOMATCH, T_SEQ, T_EQUAL, T_COMPARE, T_RNF,
@@ -652,6 +652,7 @@
   { "fsub" , T_FSUB},
   { "fmul" , T_FMUL},
   { "fdiv", T_FDIV},
+  { "itof", T_ITOF},
   { "feq", T_FEQ},
   { "fne", T_FNE},
   { "flt", T_FLT},
@@ -1383,6 +1384,7 @@
   case T_FSUB: fprintf(f, "fsub"); break;
   case T_FMUL: fprintf(f, "fmul"); break;
   case T_FDIV: fprintf(f, "fdiv"); break;
+  case T_ITOF: fprintf(f, "itof"); break;
   case T_FEQ: fprintf(f, "feq"); break;
   case T_FNE: fprintf(f, "fne"); break;
   case T_FLT: fprintf(f, "flt"); break;
@@ -1761,6 +1763,7 @@
 #define SETINT(n,r)    do { SETTAG((n), T_INT); SETVALUE((n), (r)); } while(0)
 #define SETDOUBLE(n,d) do { SETTAG((n), T_DOUBLE); SETDOUBLEVALUE((n), (d)); } while(0)
 #define OPINT2(e)      do { CHECK(2); xi = evalint(ARG(TOP(0))); yi = evalint(ARG(TOP(1))); e; POP(2); n = TOP(-1); } while(0);
+#define OPINT1(e)      do { CHECK(1); xi = evalint(ARG(TOP(0))); e; POP(1); n = TOP(-1); } while(0);
 #define OPDOUBLE2(e)   do { CHECK(2); xd = evaldouble(ARG(TOP(0))); yd = evaldouble(ARG(TOP(1))); e; POP(2); n = TOP(-1); } while(0);
 #define ARITHBIN(op)   do { OPINT2(r = xi op yi); SETINT(n, r); RET; } while(0)
 #define ARITHBINU(op)  do { OPINT2(r = (value_t)((uvalue_t)xi op (uvalue_t)yi)); SETINT(n, r); RET; } while(0)
@@ -1828,6 +1831,7 @@
     case T_FSUB: FARITHBIN(-);
     case T_FMUL: FARITHBIN(*);
     case T_FDIV: FARITHBIN(/);
+    case T_ITOF: OPINT1(rd = (double)xi); SETDOUBLE(n, rd); RET;
     case T_FEQ: CMPF(==);
     case T_FNE: CMPF(!=);
     case T_FLT: CMPF(<);
-- 
⑨