shithub: MicroHs

Download patch

ref: 0318f82986c6c2522a232f8b248017e8a5dc533d
parent: a1ecc5c8c33a2fb69047602eb03410bc61adbabb
author: Rewbert <krookr@chalmers.se>
date: Wed Sep 20 10:08:24 EDT 2023 

i broke it, the evaluator reaches ERR valio tag 17


--- /dev/null
+++ b/Main.hs
@@ -1,0 +1,9 @@
+module Main (main) where
+
+import Prelude
+
+y :: Double
+y = -1.37
+
+main :: IO ()
+main = putStrLn $ showDouble y
--- a/Makefile
+++ b/Makefile
@@ -29,7 +29,7 @@
 	@mkdir -p bin
 	$(GCC) -Wall -O3 src/runtime/eval.c -o $(EVAL)
 
-$(BIN)/$(MHS):	src/*.hs src/*/*.hs $(TOOLS)/convertX.sh
+$(BIN)/$(MHS):	src/*.hs src/*/*.hs lib/Primitives.hs $(TOOLS)/convertX.sh
 	$(GHCE) -isrc -Wall -O src/MicroHs/Main.hs -main-is MicroHs.Main -o $(BIN)/$(MHS)
 
 $(BIN)/boot$(MHS):	$(ALLSRC) $(TOOLS)/convertY.sh
--- a/TODO
+++ b/TODO
@@ -25,6 +25,6 @@
   - maybe?
   - could be used instead of derived when all is derived
 * use pointer stack during GC instead of recursion.
-* add Double primitive type
+ROBERT * add Double primitive type
 * implement Data.Integer
 * add pretty printing library
--- /dev/null
+++ b/lib/Data/Double.hs
@@ -1,0 +1,49 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
+module Data.Double(module Data.Double) where
+import Primitives
+import Data.Bool_Type
+
+--Yinfixl 6 +,-
+--Yinfixl 7 *
+
+-- Arithmetic
+(+) :: Double -> Double -> Double
+(+)  = primDoubleAdd
+(-) :: Double -> Double -> Double
+(-)  = primDoubleSub
+(*) :: Double -> Double -> Double
+(*)  = primDoubleMul
+
+negate :: Double -> Double
+negate x = 0.0 - x
+
+--------------------------------
+
+--Yinfix 4 ==,/=,<,<=,>,>=
+
+-- Comparison
+(==) :: Double -> Double -> Bool
+(==) = primDoubleEQ
+(/=) :: Double -> Double -> Bool
+(/=) = primDoubleNE
+
+(<)  :: Double -> Double -> Bool
+(<)  = primDoubleLT
+(<=) :: Double -> Double -> Bool
+(<=) = primDoubleLE
+(>)  :: Double -> Double -> Bool
+(>)  = primDoubleGT
+(>=) :: Double -> Double -> Bool
+(>=) = primDoubleGE
+
+eqDouble :: Double -> Double -> Bool
+eqDouble = (==)
+
+ltDouble :: Double -> Double -> Bool
+ltDouble = (<)
+
+showDouble :: Double -> String
+showDouble = primDoubleShow
+
+--------------------------------
--- a/lib/Prelude.hs
+++ b/lib/Prelude.hs
@@ -7,6 +7,7 @@
   module Data.Either,
   module Data.Function,
   module Data.Int,
+  module Data.Double,
   module Data.List,
   module Data.Maybe,
   module Data.Tuple,
@@ -19,6 +20,7 @@
 import Data.Either
 import Data.Function
 import Data.Int
+import Data.Double
 import Data.List
 import Data.Maybe
 import Data.Tuple
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -16,6 +16,27 @@
 primIntSubR :: Int -> Int -> Int
 primIntSubR = primitive "subtract"
 
+primDoubleAdd :: Double -> Double -> Double
+primDoubleAdd  = primitive "fadd"
+primDoubleSub :: Double -> Double -> Double
+primDoubleSub  = primitive "fsub"
+primDoubleMul :: Double -> Double -> Double
+primDoubleMul  = primitive "fmul"
+primDoubleEQ :: Double -> Double -> Bool
+primDoubleEQ = primitive "feq"
+primDoubleNE :: Double -> Double -> Bool
+primDoubleNE = primitive "fne"
+primDoubleLT :: Double -> Double -> Bool
+primDoubleLT = primitive "flt"
+primDoubleLE :: Double -> Double -> Bool
+primDoubleLE = primitive "fle"
+primDoubleGT :: Double -> Double -> Bool
+primDoubleGT = primitive "fgt"
+primDoubleGE :: Double -> Double -> Bool
+primDoubleGE = primitive "fge"
+primDoubleShow :: Double -> String
+primDoubleShow = primitive "fshow"
+
 primWordAdd :: Word -> Word -> Word
 primWordAdd  = primitive "+"
 primWordSub :: Word -> Word -> Word
--- a/lib/Text/String.hs
+++ b/lib/Text/String.hs
@@ -5,6 +5,7 @@
 import Data.Char
 import Data.Either
 import Data.Int
+import qualified Data.Double as DD
 import Data.List
 import Data.Maybe
 import Data.Tuple
--- a/src/Compat.hs
+++ b/src/Compat.hs
@@ -30,8 +30,14 @@
 readInt :: String -> Int
 readInt = read
 
+readDouble :: String -> Double
+readDouble = read
+
 showInt :: Int -> String
 showInt = show
+
+showDouble :: Double -> String
+showDouble = show
 
 showChar :: Char -> String
 showChar = show
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -107,7 +107,7 @@
 eqCon (ConLit    l) (ConLit    k) = eqLit   l k
 eqCon _             _             = False
 
-data Lit = LInt Int | LChar Char | LStr String | LPrim String
+data Lit = LInt Int | LDouble Double | LChar Char | LStr String | LPrim String
   --Xderiving (Show, Eq)
 
 eqLit :: Lit -> Lit -> Bool
@@ -358,6 +358,9 @@
 showLit l =
   case l of
     LInt i -> showInt i
+    LDouble d -> case showDouble d of
+      '-':xs -> '-':'f':xs
+      xs -> 'f':xs
     LChar c -> showChar c
     LStr s -> showString s
     LPrim s -> '$':s
--- a/src/MicroHs/Lex.hs
+++ b/src/MicroHs/Lex.hs
@@ -14,6 +14,7 @@
   | TString Loc String
   | TChar   Loc Char
   | TInt    Loc Int
+  | TDouble Loc Double
   | TSpec   Loc Char
   | TError  Loc String
   | TBrace  Loc
@@ -25,6 +26,7 @@
 showToken (TString _ s) = showString s
 showToken (TChar _ c) = showChar c
 showToken (TInt _ i) = showInt i
+showToken (TDouble _ d) = showDouble d
 showToken (TSpec _ c) = [c]
 showToken (TError _ s) = "ERROR " ++ s
 showToken (TBrace _) = "TBrace"
@@ -72,6 +74,7 @@
          --take 10 .
          lex (mkLoc 1 1)
 
+-- | Take a location and string and produce a list of tokens
 lex :: Loc -> String -> [Token]
 lex loc (' ':cs)  = lex (addCol loc 1) cs
 lex loc ('\n':cs) = tIndent (lex (incrLine loc) cs)
@@ -89,10 +92,14 @@
 lex loc cs@(d:_) | isUpper d = upperIdent loc loc [] cs
 lex loc ('-':d:cs) | isDigit d =
   case span isDigit cs of
-    (ds, rs) -> TInt loc (readInt ('-':d:ds)) : lex (addCol loc $ 2 + length ds) rs
+    (ds, rs) | null rs || not (eqChar (head rs) '.') -> TInt loc (readInt ('-':d:ds)) : lex (addCol loc $ 2 + length ds) rs
+             | otherwise -> case span isDigit (tail rs) of
+      (ns, rs') -> TDouble loc (readDouble ('-':d:ds ++ '.':ns)) : lex (addCol loc $ 3 + length ds + length ns) rs'
 lex loc (d:cs) | isDigit d =
   case span isDigit cs of
-    (ds, rs) -> TInt loc (readInt (d:ds)) : lex (addCol loc $ 1 + length ds) rs
+    (ds, rs) | null rs || not (eqChar (head rs) '.') -> TInt loc (readInt (d:ds)) : lex (addCol loc $ 1 + length ds) rs
+             | otherwise -> case span isDigit (tail rs) of
+      (ns, rs') -> TDouble loc (readDouble (d:ds ++ '.':ns)) : lex (addCol loc $ 2 + length ds + length ns) rs' 
 lex loc (d:cs) | isOperChar d  =
   case span isOperChar cs of
     (ds, rs) -> TIdent loc [] (d:ds) : lex (addCol loc $ 1 + length ds) rs
@@ -122,6 +129,9 @@
 skipLine loc (_:cs)      = skipLine loc cs
 skipLine   _ []          = []
 
+-- | Takes a list of tokens and produces a list of tokens. If the first token in
+-- the input list is a TIndent, the input is returned unaltered. Otherwise, a
+-- TIndent is prepended to the input list        
 tIndent :: [Token] -> [Token]
 tIndent ts@(TIndent _ : _) = ts
 tIndent ts = TIndent (tokensLoc ts) : ts
@@ -178,6 +188,7 @@
 tokensLoc (TString loc _  :_) = loc
 tokensLoc (TChar   loc _  :_) = loc
 tokensLoc (TInt    loc _  :_) = loc
+tokensLoc (TDouble loc _ : _) = loc
 tokensLoc (TSpec   loc _  :_) = loc
 tokensLoc (TError  loc _  :_) = loc
 tokensLoc (TBrace  loc    :_) = loc
@@ -184,6 +195,7 @@
 tokensLoc (TIndent loc    :_) = loc
 tokensLoc []                  = mkLoc 0 1
 
+-- | This appears to be the magical layout resolver, I wondered where it was...
 layout :: [Int] -> [Token] -> [Token]
 layout mms@(m : ms) tts@(TIndent x       : ts) | n == m = TSpec (tokensLoc ts) ';' : layout    mms  ts
                                                | n <  m = TSpec (tokensLoc ts) '}' : layout     ms tts where {n = getCol x}
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -194,6 +194,7 @@
     is (TString (l, c) s) = Just (ELit (SLoc fn l c) (LStr s))
     is (TChar   (l, c) a) = Just (ELit (SLoc fn l c) (LChar a))
     is (TInt    (l, c) i) = Just (ELit (SLoc fn l c) (LInt i))
+    is (TDouble (l, c) d) = Just (ELit (SLoc fn l c) (LDouble d))
     is _ = Nothing
   satisfyM "literal" is
 
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -273,6 +273,7 @@
       [(mkIdent "IO",     [entry "Primitives.IO"       kTypeTypeS]),
        (mkIdent "->",     [entry "Primitives.->"       kTypeTypeTypeS]),
        (mkIdent "Int",    [entry "Primitives.Int"      kTypeS]),
+       (mkIdent "Double", [entry "Primitives.Double"   kTypeS]),
        (mkIdent "Word",   [entry "Primitives.Word"     kTypeS]),
        (mkIdent "Char",   [entry "Primitives.Char"     kTypeS]),
        (mkIdent "Handle", [entry "Primitives.Handle"   kTypeS]),
@@ -850,6 +851,7 @@
   let { lit t = T.do { munify loc mt t; T.return (ELit loc l, t) } } in
   case l of
     LInt _ -> lit (tConI "Primitives.Int")
+    LDouble _ -> lit (tConI "Primitives.Double")
     LChar _ -> lit (tConI "Primitives.Char")
     LStr _ -> lit (tApps (mkIdent "Data.List.[]") [tConI "Primitives.Char"])
     LPrim _ -> T.do
--- a/src/PrimTable.hs
+++ b/src/PrimTable.hs
@@ -30,6 +30,9 @@
   , arith "quot" quot
   , arith "rem" rem
   , arith "subtract" subtract
+  , farith "fadd" (+)
+  , farith "fsub" (-)
+  , farith "fmul" (*)
   , cmp "==" (==)
   , cmp "/=" (/=)
   , cmp "<"  (<)
@@ -52,6 +55,8 @@
     comb n f = (n, unsafeCoerce f)
     arith :: String -> (Int -> Int -> Int) -> (String, Any)
     arith = comb
+    farith :: String -> (Double -> Double -> Double) -> (String, Any)
+    farith = comb
     cmp :: String -> (Int -> Int -> Bool) -> (String, Any)
     cmp n f = comb n (\ x y -> if f x y then cTrue else cFalse)
     cTrue _x y = y
--- a/src/Text/ParserComb.hs
+++ b/src/Text/ParserComb.hs
@@ -49,6 +49,7 @@
 data Res s t a = Many [(a, ([t], s))] (LastFail t)
   --deriving (Show)
 
+-- | 
 data Prsr s t a = P (([t], s) -> Res s t a)
 --instance Show (Prsr s t a) where show _ = "<<Prsr>>"
 
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -82,9 +82,11 @@
 
 #define ERR(s) do { fprintf(stderr, "ERR: %s\n", s); exit(1); } while(0)
 
-enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_HDL, T_S, T_K, T_I, T_B, T_C,
+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_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_FEQ, T_FNE, T_FLT, T_FLE, T_FGT, T_FGE, T_FSHOW,
                 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_IO_BIND, T_IO_THEN, T_IO_RETURN, T_IO_GETCHAR, T_IO_PUTCHAR,
@@ -120,7 +122,9 @@
 #define GETTAG(p) (p)->tag
 #define SETTAG(p, t) do { (p)->tag = (t); } while(0)
 #define GETVALUE(p) (p)->u.value
+#define GETDOUBLEVALUE(p,d) do { memcpy(&d, &((p)->u.value), 8); } while(0)
 #define SETVALUE(p,v) (p)->u.value = v
+#define SETDOUBLEVALUE(p,v) do { memcpy(&((p)->u.value), &v, 8); } while(0)
 #define FUN(p) (p)->u.s.fun
 #define ARG(p) (p)->u.s.arg
 #define NEXT(p) FUN(p)
@@ -151,7 +155,9 @@
 #define GETTAG(p) ((p)->ufun.uutag & 1 ? (int)((p)->ufun.uutag >> 1) : T_AP)
 #define SETTAG(p,t) do { if (t != T_AP) (p)->ufun.uutag = ((t) << 1) + 1; } while(0)
 #define GETVALUE(p) (p)->uarg.uuvalue
+#define GETDOUBLEVALUE(p, d) do { memcpy(&d, &((p)->uarg.uuvalue), 8); } while(0)
 #define SETVALUE(p,v) (p)->uarg.uuvalue = v
+#define SETDOUBLEVALUE(p,v) do { memcpy(&((p)->uarg.uuvalue), &v, 8); } while(0)
 #define FUN(p) (p)->ufun.uufun
 #define ARG(p) (p)->uarg.uuarg
 #define STR(p) (p)->uarg.uustring
@@ -362,6 +368,16 @@
   { "uquot", T_UQUOT },
   { "urem", T_UREM },
   { "subtract", T_SUBR },
+  { "fadd" , T_FADD},
+  { "fsub" , T_FSUB},
+  { "fmul" , T_FMUL},
+  {"feq", T_FEQ},
+  {"fne", T_FNE},
+  {"flt", T_FLT},
+  {"fle", T_FLE},
+  {"fgt", T_FGT},
+  {"fge", T_FGE},
+  {"fshow", T_FSHOW},
   { "==", T_EQ },
   { "/=", T_NE },
   { "<", T_LT },
@@ -628,6 +644,42 @@
   return i;
 }
 
+double
+parse_double(BFILE *f)
+{
+  // apparently longest float, when rendered, takes up 24 characters
+  // I expect Lennart will hate this...
+  char floatstr[24];
+  int i = 0;
+  for(;;) {
+    int c = getb(f);
+//    printf("%d\n", c);
+    if (c < '0' || c > '9') {
+      ungetb(c, f);
+      break;
+    }
+    floatstr[i++] = c;
+  }
+  int c = getb(f);
+  if(c != '.') {
+    ERR("can not parse double");
+  }
+  floatstr[i++] = '.';
+
+  for(;;) {
+    int c = getb(f);
+    if(c < '0' || c > '9') {
+      ungetb(c, f);
+      break;
+    }
+    floatstr[i++] = c;
+  }
+
+  floatstr[i++] = '\0';
+  double d = strtod(floatstr, NULL);
+  return d;
+}
+
 NODEPTR
 mkStrNode(const char *str)
 {
@@ -637,6 +689,7 @@
 }
 
 NODEPTR mkInt(int64_t i);
+NODEPTR mkDouble(double d);
 
 /* Table of labelled nodes for sharing during parsing. */
 struct shared_entry {
@@ -673,6 +726,7 @@
   NODEPTR *nodep;
   int64_t l;
   value_t i;
+  double d;
   value_t neg;
   int c;
   char buf[80];                 /* store names of primitives. */
@@ -686,6 +740,9 @@
     FUN(r) = parse(f);
     if (!gobble(f, ' ')) ERR("parse ' '");
     ARG(r) = parse(f);
+    c = getb(f);
+//    printf("got %c\n", c);
+    ungetb(c, f); 
     if (!gobble(f, ')')) ERR("parse ')'");
     return r;
   case '-':
@@ -693,9 +750,21 @@
     if ('0' <= c && c <= '9') {
       neg = -1;
       goto number;
+    } else if (c == 'f') {
+      neg = -1;
+      goto flabel; // this stuff is cursed, I am not as much of a hacker as Lennart
     } else {
       ERR("got -");
     }
+  case 'f':
+  flabel:
+    c = getb(f);
+    if('0' <= c && c <= '9') {
+      neg = 1;
+      goto floatingnumber;
+    } else {
+      ERR("got f");
+    }
   case '0':case '1':case '2':case '3':case '4':case '5':case '6':case '7':case '8':case '9':
     /* integer [0-9]+*/
     neg = 1;
@@ -703,8 +772,17 @@
     ungetb(c, f);
     i = neg * parse_int(f);
     r = mkInt(i);
+//    printf("%ld\n", i);
     return r;
+  floatingnumber:
+    ungetb(c, f);
+    d = neg * parse_double(f);
+    r = mkDouble(d);
+//    printf("%f\n", d);
+    return r;
+  /* somewhere here, add case for doubles */
   case '$':
+//    printf("$\n");
     /* A primitive, keep getting char's until end */
     for (int j = 0;;) {
       c = getb(f);
@@ -715,6 +793,7 @@
       }
       buf[j++] = c;
     }
+//    printf("%s\n", buf);
     /* Look up the primop and use the preallocated node. */
     for (int j = 0; j < sizeof primops / sizeof primops[0]; j++) {
       if (strcmp(primops[j].name, buf) == 0) {
@@ -938,6 +1017,11 @@
     fputc(')', f);
     break;
   case T_INT: fprintf(f, "%"PRIu64, GETVALUE(n)); break;
+  case T_DOUBLE:
+    double d;
+    GETDOUBLEVALUE(n, d);
+    fprintf(f, "%f", d);
+    break;
   case T_STR:
     {
       const char *p = STR(n);
@@ -983,6 +1067,16 @@
   case T_UQUOT: fprintf(f, "$uquot"); break;
   case T_UREM: fprintf(f, "$urem"); break;
   case T_SUBR: fprintf(f, "$subtract"); break;
+  case T_FADD:  fprintf(f, "$fadd"); break;
+  case T_FSUB:  fprintf(f, "$fsub"); break;
+  case T_FMUL:  fprintf(f, "$fmul"); break;
+  case T_FEQ: fprintf(f, "$feq"); break;
+  case T_FNE: fprintf(f, "$fne"); break;
+  case T_FLT: fprintf(f, "$flt"); break;
+  case T_FLE: fprintf(f, "$fle"); break;
+  case T_FGT: fprintf(f, "$fgt"); break;
+  case T_FGE: fprintf(f, "$fge"); break;
+  case T_FSHOW: fprintf(f, "$fshow"); break;
   case T_EQ: fprintf(f, "$=="); break;
   case T_NE: fprintf(f, "$/="); break;
   case T_LT: fprintf(f, "$<"); break;
@@ -1056,6 +1150,15 @@
   return n;
 }
 
+NODEPTR
+mkDouble(double d)
+{
+  NODEPTR n;
+  n = alloc_node(T_DOUBLE);
+  SETDOUBLEVALUE(n, d);
+  return n;
+}
+
 static inline NODEPTR
 mkNil(void)
 {
@@ -1114,6 +1217,18 @@
   return n;
 }
 
+static inline NODEPTR
+evald(NODEPTR n)
+{
+  PUSH(n);
+  eval(n);
+  n = TOP(0);
+  POP(1);
+  while (GETTAG(n) == T_IND)
+    n = INDIR(n);
+  return n;
+}
+
 /* Follow indirections */
 static inline NODEPTR
 indir(NODEPTR n)
@@ -1137,6 +1252,22 @@
   return GETVALUE(n);
 }
 
+/* Evaluate to a Double */
+static inline double
+evaldouble(NODEPTR n)
+{
+  n = evald(n);
+  #if SANITY
+  if (GETTAG(n) != T_DOUBLE) {
+    fprintf(stderr, "bad tag %d\n", GETTAG(n));
+    ERR("evaldouble");
+  }
+  #endif
+  double d;
+  GETDOUBLEVALUE(n, d);
+  return d;
+}
+
 /* Evaluate to a T_HDL */
 FILE *
 evalhandleN(NODEPTR n)
@@ -1205,7 +1336,9 @@
   int64_t stk = stack_ptr;
   NODEPTR x, y, z, w;
   value_t xi, yi;
+  double xd, yd;
   value_t r;
+  double rd;
   FILE *hdl;
   char *msg;
   int64_t l;
@@ -1234,14 +1367,20 @@
 /* Alloc a possible GC action, e, between setting x and popping */
 #define CHKARGEV1(e) do { CHECK(1); x = ARG(TOP(0)); e; POP(1); n = TOP(-1); } while(0)
 
-#define SETINT(n,r)   do { SETTAG((n), T_INT); SETVALUE((n), (r)); } 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 ARITHBIN(op)  do { OPINT2(r = xi op yi); SETINT(n, r); RET; } while(0)
-#define ARITHBINU(op) do { OPINT2(r = (int64_t)((uint64_t)xi op (uint64_t)yi)); SETINT(n, r); RET; } while(0)
-#define CMP(op)       do { OPINT2(r = xi op yi); GOIND(r ? comTrue : combFalse); } while(0)
-#define CMPU(op)      do { OPINT2(r = (uint64_t)xi op (uint64_t)yi); GOIND(r ? comTrue : combFalse); } while(0)
+#define SETINT(n,r)    do { SETTAG((n), T_INT); SETVALUE((n), (r)); } while(0)
+#define SETSTRING(n,r) do { SETTAG((n), T_STR); 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 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 = (int64_t)((uint64_t)xi op (uint64_t)yi)); SETINT(n, r); RET; } while(0)
+#define FARITHBIN(op)  do { OPDOUBLE2(rd = xd op yd); SETDOUBLE(n, rd); RET; } while(0) // TODO FIXME
+#define CMP(op)        do { OPINT2(r = xi op yi); GOIND(r ? comTrue : combFalse); } while(0)
+#define CMPF(op)       do { OPDOUBLE2(r = xd op yd); GOIND(r ? comTrue : combFalse); } while(0)
+#define CMPU(op)       do { OPINT2(r = (uint64_t)xi op (uint64_t)yi); GOIND(r ? comTrue : combFalse); } while(0)
 
   for(;;) {
+    printf("eval %d\n", GETTAG(n));
     num_reductions++;
 #if FASTTAGS
     l = LABEL(n);
@@ -1268,6 +1407,7 @@
 
     case T_STR:  GCCHECK(strNodes(strlen(STR(n)))); GOIND(mkStringC(STR(n)));
     case T_INT:  RET;
+    case T_DOUBLE: RET;
     case T_HDL:  RET;
 
     case T_S:    GCCHECK(2); CHKARG3; GOAP(new_ap(x, z), new_ap(y, z));                     /* S x y z = x z (y z) */
@@ -1291,6 +1431,37 @@
     case T_QUOT: ARITHBIN(/);
     case T_REM:  ARITHBIN(%);
     case T_SUBR: OPINT2(r = yi - xi); SETINT(n, r); RET;
+    case T_FADD:  FARITHBIN(+);
+    case T_FSUB:  FARITHBIN(-);
+    case T_FMUL:  FARITHBIN(*);
+    case T_FEQ: CMPF(==);
+    case T_FNE: CMPF(!=);
+    case T_FLT: CMPF(<);
+    case T_FLE: CMPF(<=);
+    case T_FGT: CMPF(>);
+    case T_FGE: CMPF(>=);
+    case T_FSHOW:
+      // check that the double exists
+      CHECK(1);
+
+      // evaluate it, I have verified that it is properly evaluated
+      xd = evaldouble(ARG(TOP(0)));
+
+      // turn it into a string, which I have also verified does what it is supposed to
+      char str[25];
+      memset(str, 0, 25);
+      snprintf(str, 25, "%f", xd);
+      NODEPTR s = mkStringC(str);
+
+      // remove the double from the stack
+      POP(1);
+      n = TOP(-1);
+
+      // make the node point to the new string
+      SETIND(n,s);
+
+      // return
+      RET;
     case T_UQUOT: ARITHBINU(/);
     case T_UREM:  ARITHBINU(%);
 
@@ -1355,6 +1526,7 @@
   n = evali(n);
   PUSH(n);
   for(;;) {
+    printf("evalio %d\n", GETTAG(n));
     num_reductions++;
     switch (GETTAG(n)) {
     case T_IND:
-- 
⑨