Constructive real functionality

9 files changed, 136 insertions, 18 deletions

diff --git a/src/compile/expressions.c b/src/compile/expressions.c
index ce44dafc..28f91500 100644
--- a/src/compile/expressions.c
+++ b/src/compile/expressions.c
@@ -77,7 +77,16 @@ Text_t compile(env_t *env, ast_t *ast) {
     }
     case Int: return compile_int(ast);
     case Num: {
-        return Text$from_str(String(hex_double(Match(ast, Num)->n)));
+        // return Text$from_str(String(hex_double(Match(ast, Num)->n)));
+        Text_t original = Text$from_str(String(string_slice(ast->start, (size_t)(ast->end - ast->start))));
+        Text_t roundtrip = Text$from_str(String(Match(ast, Num)->n));
+        original = Text$replace(original, Text("_"), EMPTY_TEXT);
+        original = Text$without_suffix(original, Text("."));
+        if (Text$equal_values(original, roundtrip)) {
+            return Texts("Real$from_float64(", Text$from_str(String(hex_double(Match(ast, Num)->n))), ")");
+        } else {
+            return Texts("Real$parse(Text(\"", original, "\"), NULL)");
+        }
     }
     case Not: {
         ast_t *value = Match(ast, Not)->value;
diff --git a/src/compile/types.c b/src/compile/types.c
index 94da1c49..24790e46 100644
--- a/src/compile/types.c
+++ b/src/compile/types.c
@@ -25,6 +25,7 @@ Text_t compile_type(type_t *t) {
     case BigIntType: return Text("Int_t");
     case IntType: return Texts("Int", (int32_t)Match(t, IntType)->bits, "_t");
     case FloatType: return Texts("Float", (int32_t)Match(t, FloatType)->bits, "_t");
+    case RealType: return Text("Real_t");
     case TextType: {
         DeclareMatch(text, t, TextType);
         if (!text->lang || streq(text->lang, "Text")) return Text("Text_t");
@@ -65,6 +66,7 @@ Text_t compile_type(type_t *t) {
         case IntType:
         case BigIntType:
         case FloatType:
+        case RealType:
         case BoolType:
         case ByteType:
         case ListType:
@@ -96,6 +98,7 @@ Text_t compile_type_info(type_t *t) {
     case IntType:
     case BigIntType:
     case FloatType:
+    case RealType:
     case CStringType: return Texts("&", type_to_text(t), "$info");
     case TextType: {
         DeclareMatch(text, t, TextType);
diff --git a/src/environment.c b/src/environment.c
index 7ab0d4fc..a5b30cb5 100644
--- a/src/environment.c
+++ b/src/environment.c
@@ -283,15 +283,25 @@ env_t *global_env(bool source_mapping) {
             F_opt(log1p), F_opt(log2), F(logb), F(rint), F(round), F(significand), F_opt(sin), F(sinh), F_opt(sqrt),
             F_opt(tan), F(tanh), F_opt(tgamma), F(trunc), F_opt(y0), F_opt(y1), F2(atan2), F2(copysign), F2(fdim),
             F2(hypot), F2(nextafter)),
-        MAKE_TYPE( //
-            "CString", Type(CStringType), Text("char*"), Text("CString$info"), //
-            {"as_text", "Text$from_str", "func(str:CString -> Text)"},
-            {"join", "CString$join", "func(glue:CString, pieces:[CString] -> CString)"}),
 #undef F2
 #undef F_opt
 #undef F
 #undef C
         MAKE_TYPE( //
+            "Real", REAL_TYPE, Text("Real_t"), Text("Real$info"), //
+            {"divided_by", "Real$divided_by", "func(x,y:Real -> Real)"}, //
+            {"inverse", "Real$inverse", "func(x:Real -> Real)"}, //
+            {"minus", "Real$minus", "func(x,y:Real -> Real)"}, //
+            {"negative", "Real$negative", "func(x:Real -> Real)"}, //
+            {"plus", "Real$plus", "func(x,y:Real -> Real)"}, //
+            {"power", "Real$power", "func(base:Real,exponent:Real -> Real)"}, //
+            {"times", "Real$times", "func(x,y:Real -> Real)"}, //
+            ),
+        MAKE_TYPE( //
+            "CString", Type(CStringType), Text("char*"), Text("CString$info"), //
+            {"as_text", "Text$from_str", "func(str:CString -> Text)"},
+            {"join", "CString$join", "func(glue:CString, pieces:[CString] -> CString)"}),
+        MAKE_TYPE( //
             "PathType", PATH_TYPE_TYPE, Text("PathType_t"), Text("PathType$info"), //
             {"Relative", "PATHTYPE_RELATIVE", "PathType"}, //
             {"Absolute", "PATHTYPE_ABSOLUTE", "PathType"}, //
diff --git a/src/stdlib/reals.c b/src/stdlib/reals.c
index 2c6a2601..1c4be751 100644
--- a/src/stdlib/reals.c
+++ b/src/stdlib/reals.c
@@ -9,6 +9,7 @@
 #include "floats.h"
 #include "reals.h"
 #include "text.h"
+#include "types.h"
 
 struct ieee754_bits {
     bool negative : 1;
@@ -16,23 +17,25 @@ struct ieee754_bits {
     uint64_t fraction : 53;
 };
 
+public
 Int_t Real$compute(Real_t r, int64_t precision) {
     if (r->exact) return Int$left_shifted(r->approximation, Int$from_int64(precision));
 
-    if (r->approximation.small != 0 && precision <= r->approximation_bits)
-        return Int$left_shifted(r->approximation, Int$from_int64(precision - r->approximation_bits));
+    if (r->approximation.small != 0 && precision <= r->approximation_bits) {
+        return Int$right_shifted(r->approximation, Int$from_int64(r->approximation_bits - precision));
+    }
 
     r->approximation = r->compute(r, precision);
     r->approximation_bits = precision;
     return r->approximation;
 }
 
-int64_t most_significant_bit(Real_t r, int64_t prec) {
+static int64_t most_significant_bit(Real_t r, int64_t prec) {
     if ((r->approximation.small | 0x1) == 0x1) {
         (void)Real$compute(r, prec);
     }
 
-    if (r->approximation.small == 1) {
+    if ((r->approximation.small & 0x1) == 0x1) {
         int64_t small = (r->approximation.small) >> 2;
         if (small < 0) small = -small;
         int64_t msb = (int64_t)__builtin_clzl((uint64_t)small);
@@ -62,6 +65,7 @@ static Int_t Real$compute_double(Real_t r, int64_t precision) {
     }
 }
 
+public
 OptionalReal_t Real$parse(Text_t text, Text_t *remainder) {
     Text_t decimal_onwards;
     OptionalInt_t int_component = Int$parse(text, &decimal_onwards);
@@ -84,8 +88,10 @@ OptionalReal_t Real$parse(Text_t text, Text_t *remainder) {
     }
 }
 
+public
 Real_t Real$from_float64(double n) { return new (struct Real_s, .compute = Real$compute_double, .userdata.n = n); }
 
+public
 double Real$as_float64(Real_t x) {
     int64_t my_msd = most_significant_bit(x, -1080 /* slightly > exp. range */);
     if (my_msd == INT64_MIN) return 0.0;
@@ -116,6 +122,7 @@ double Real$as_float64(Real_t x) {
     return 0.0;
 }
 
+public
 Real_t Real$from_int(Int_t i) {
     return new (struct Real_s, .compute = Real$compute_int, .userdata.i = i, .approximation = i, .exact = 1,
                 .approximation_bits = 0);
@@ -126,6 +133,7 @@ static Int_t Real$compute_negative(Real_t r, int64_t precision) {
     return Int$negative(x);
 }
 
+public
 Real_t Real$negative(Real_t x) { return new (struct Real_s, .compute = Real$compute_negative, .userdata.children = x); }
 
 static Int_t Real$compute_plus(Real_t r, int64_t precision) {
@@ -134,6 +142,7 @@ static Int_t Real$compute_plus(Real_t r, int64_t precision) {
     return Int$right_shifted(Int$plus(lhs, rhs), I(1));
 }
 
+public
 Real_t Real$plus(Real_t x, Real_t y) {
     Real_t result =
         new (struct Real_s, .compute = Real$compute_plus, .userdata.children = GC_MALLOC(sizeof(struct Real_s[2])), );
@@ -148,6 +157,7 @@ static Int_t Real$compute_minus(Real_t r, int64_t precision) {
     return Int$right_shifted(Int$minus(lhs, rhs), I(1));
 }
 
+public
 Real_t Real$minus(Real_t x, Real_t y) {
     Real_t result =
         new (struct Real_s, .compute = Real$compute_minus, .userdata.children = GC_MALLOC(sizeof(struct Real_s[2])), );
@@ -178,6 +188,7 @@ static Int_t Real$compute_times(Real_t r, int64_t precision) {
     return Int$right_shifted(Int$times(approx_big, approx_small), Int$from_int64(lhs_msb + rhs_msb - precision));
 }
 
+public
 Real_t Real$times(Real_t x, Real_t y) {
     Real_t result =
         new (struct Real_s, .compute = Real$compute_times, .userdata.children = GC_MALLOC(sizeof(struct Real_s[2])));
@@ -209,8 +220,10 @@ static Int_t Real$compute_inverse(Real_t r, int64_t precision) {
     return r->approximation;
 }
 
+public
 Real_t Real$inverse(Real_t x) { return new (struct Real_s, .compute = Real$compute_inverse, .userdata.children = x); }
 
+public
 Real_t Real$divided_by(Real_t x, Real_t y) { return Real$times(x, Real$inverse(y)); }
 
 static Int_t Real$compute_sqrt(Real_t r, int64_t precision) {
@@ -256,8 +269,10 @@ static Int_t Real$compute_sqrt(Real_t r, int64_t precision) {
     return I(0);
 }
 
+public
 Real_t Real$sqrt(Real_t x) { return new (struct Real_s, .compute = Real$compute_sqrt, .userdata.children = x); }
 
+public
 Text_t Real$value_as_text(Real_t x, int64_t digits) {
     Int_t scale_factor = Int$power(I(10), Int$from_int64(digits));
     Real_t scaled = Real$times(x, Real$from_int(scale_factor));
@@ -283,3 +298,64 @@ Text_t Real$value_as_text(Real_t x, int64_t digits) {
     }
     return result;
 }
+
+PUREFUNC
+static int32_t Real$compare(const void *x, const void *y, const TypeInfo_t *info) {
+    (void)info;
+    Int_t x_int = Real$compute(*(Real_t *)x, 100);
+    Int_t y_int = Real$compute(*(Real_t *)y, 100);
+    return Int$compare_value(x_int, y_int);
+}
+
+PUREFUNC
+static bool Real$equal(const void *x, const void *y, const TypeInfo_t *info) {
+    (void)info;
+    Int_t x_int = Real$compute(*(Real_t *)x, 100);
+    Int_t y_int = Real$compute(*(Real_t *)y, 100);
+    return Int$equal_value(x_int, y_int);
+}
+
+PUREFUNC
+static uint64_t Real$hash(const void *x, const TypeInfo_t *info) {
+    (void)x, (void)info;
+    fail("Hashing is not implemented for Reals");
+}
+
+static Text_t Real$as_text(const void *x, bool color, const TypeInfo_t *info) {
+    (void)info;
+    if (x == NULL) return Text("Real");
+    Text_t text = Real$value_as_text(*(Real_t *)x, 10);
+    return color ? Texts("\x1b[35m", text, "\x1b[m") : text;
+}
+
+PUREFUNC
+static bool Real$is_none(const void *x, const TypeInfo_t *info) {
+    (void)info;
+    return *(Real_t *)x == NULL;
+}
+
+static void Real$serialize(const void *obj, FILE *out, Table_t *pointers, const TypeInfo_t *info) {
+    (void)obj, (void)out, (void)pointers, (void)info;
+    fail("Serialization of Reals is not implemented");
+}
+
+static void Real$deserialize(FILE *in, void *obj, List_t *pointers, const TypeInfo_t *info) {
+    (void)in, (void)obj, (void)pointers, (void)info;
+    fail("Serialization of Reals is not implemented");
+}
+
+public
+const TypeInfo_t Real$info = {
+    .size = sizeof(Real_t),
+    .align = __alignof__(Real_t),
+    .metamethods =
+        {
+            .compare = Real$compare,
+            .equal = Real$equal,
+            .hash = Real$hash,
+            .as_text = Real$as_text,
+            .is_none = Real$is_none,
+            .serialize = Real$serialize,
+            .deserialize = Real$deserialize,
+        },
+};
diff --git a/src/stdlib/reals.h b/src/stdlib/reals.h
index ededa5c1..d3a66112 100644
--- a/src/stdlib/reals.h
+++ b/src/stdlib/reals.h
@@ -2,6 +2,7 @@
 #include <stdint.h>
 
 #include "datatypes.h"
+#include "types.h"
 
 #define NONE_REAL ((Real_t)NULL)
 
@@ -24,3 +25,5 @@ Real_t Real$times(Real_t x, Real_t y);
 Real_t Real$divided_by(Real_t x, Real_t y);
 Real_t Real$left_shifted(Real_t x, Int_t amount);
 Real_t Real$right_shifted(Real_t x, Int_t amount);
+
+extern const TypeInfo_t Real$info;
diff --git a/src/stdlib/tomo.h b/src/stdlib/tomo.h
index 4abf8856..b6166890 100644
--- a/src/stdlib/tomo.h
+++ b/src/stdlib/tomo.h
@@ -25,6 +25,7 @@
 #include "paths.h" // IWYU pragma: export
 #include "pointers.h" // IWYU pragma: export
 #include "print.h" // IWYU pragma: export
+#include "reals.h" // IWYU pragma: export
 #include "siphash.h" // IWYU pragma: export
 #include "stacktrace.h" // IWYU pragma: export
 #include "structs.h" // IWYU pragma: export
diff --git a/src/typecheck.c b/src/typecheck.c
index 8e5c7fcb..10cb9cba 100644
--- a/src/typecheck.c
+++ b/src/typecheck.c
@@ -706,7 +706,7 @@ type_t *get_type(env_t *env, ast_t *ast) {
         return Type(BigIntType);
     }
     case Num: {
-        return Type(FloatType, .bits = TYPE_NBITS64);
+        return Type(RealType);
     }
     case HeapAllocate: {
         type_t *pointed = get_type(env, Match(ast, HeapAllocate)->value);
diff --git a/src/types.c b/src/types.c
index cc3ac010..492a2a22 100644
--- a/src/types.c
+++ b/src/types.c
@@ -7,6 +7,7 @@
 #include <sys/param.h>
 
 #include "environment.h"
+#include "stdlib/datatypes.h"
 #include "stdlib/integers.h"
 #include "stdlib/text.h"
 #include "stdlib/util.h"
@@ -31,6 +32,7 @@ Text_t type_to_text(type_t *t) {
     case BigIntType: return Text("Int");
     case IntType: return Texts("Int", (int32_t)Match(t, IntType)->bits);
     case FloatType: return Match(t, FloatType)->bits == TYPE_NBITS32 ? Text("Float32") : Text("Float64");
+    case RealType: return Text("Real");
     case ListType: {
         DeclareMatch(list, t, ListType);
         return Texts("[", type_to_text(list->item_type), "]");
@@ -155,7 +157,7 @@ type_t *type_or_type(type_t *a, type_t *b) {
     if (type_is_a(a, b)) return b;
     if (a->tag == AbortType || a->tag == ReturnType) return non_optional(b);
     if (b->tag == AbortType || b->tag == ReturnType) return non_optional(a);
-    if ((a->tag == IntType || a->tag == FloatType) && (b->tag == IntType || b->tag == FloatType)) {
+    if (is_numeric_type(a) && is_numeric_type(b)) {
         switch (compare_precision(a, b)) {
         case NUM_PRECISION_EQUAL:
         case NUM_PRECISION_MORE: return a;
@@ -182,6 +184,7 @@ static PUREFUNC INLINE double type_min_magnitude(type_t *t) {
         }
     }
     case FloatType: return -1. / 0.;
+    case RealType: return -1. / 0.;
     default: return (double)NAN;
     }
 }
@@ -201,6 +204,7 @@ static PUREFUNC INLINE double type_max_magnitude(type_t *t) {
         }
     }
     case FloatType: return 1. / 0.;
+    case RealType: return 1. / 0.;
     default: return (double)NAN;
     }
 }
@@ -208,15 +212,17 @@ static PUREFUNC INLINE double type_max_magnitude(type_t *t) {
 PUREFUNC precision_cmp_e compare_precision(type_t *a, type_t *b) {
     if (a == NULL || b == NULL) return NUM_PRECISION_INCOMPARABLE;
 
-    if (is_int_type(a) && b->tag == FloatType) return NUM_PRECISION_LESS;
-    else if (a->tag == FloatType && is_int_type(b)) return NUM_PRECISION_MORE;
-
     double a_min = type_min_magnitude(a), b_min = type_min_magnitude(b), a_max = type_max_magnitude(a),
            b_max = type_max_magnitude(b);
 
     if (isnan(a_min) || isnan(b_min) || isnan(a_max) || isnan(b_max)) return NUM_PRECISION_INCOMPARABLE;
-    else if (a_min == b_min && a_max == b_max) return NUM_PRECISION_EQUAL;
-    else if (a_min <= b_min && b_max <= a_max) return NUM_PRECISION_MORE;
+    else if (a_min == b_min && a_max == b_max) {
+        if (is_int_type(a) && (b->tag == FloatType || b->tag == RealType)) return NUM_PRECISION_LESS;
+        else if ((a->tag == FloatType || a->tag == RealType) && is_int_type(b)) return NUM_PRECISION_MORE;
+        else if (a->tag == FloatType && b->tag == RealType) return NUM_PRECISION_LESS;
+        else if (a->tag == RealType && b->tag == FloatType) return NUM_PRECISION_MORE;
+        return NUM_PRECISION_EQUAL;
+    } else if (a_min <= b_min && b_max <= a_max) return NUM_PRECISION_MORE;
     else if (b_min <= a_min && a_max <= b_max) return NUM_PRECISION_LESS;
     else return NUM_PRECISION_INCOMPARABLE;
 }
@@ -228,6 +234,7 @@ PUREFUNC bool has_heap_memory(type_t *t) {
     case PointerType: return true;
     case OptionalType: return has_heap_memory(Match(t, OptionalType)->type);
     case BigIntType: return true;
+    case RealType: return true;
     case StructType: {
         for (arg_t *field = Match(t, StructType)->fields; field; field = field->next) {
             if (has_heap_memory(field->type)) return true;
@@ -279,6 +286,8 @@ PUREFUNC bool can_promote(type_t *actual, type_t *needed) {
     // Serialization/deserialization
     if (type_eq(actual, Type(ListType, Type(ByteType))) || type_eq(needed, Type(ListType, Type(ByteType)))) return true;
 
+    if (is_numeric_type(actual) && needed->tag == RealType) return true;
+
     if (actual->tag == FloatType && needed->tag == IntType) return false;
 
     if (actual->tag == IntType && (needed->tag == FloatType || needed->tag == BigIntType)) return true;
@@ -305,7 +314,8 @@ PUREFUNC bool can_promote(type_t *actual, type_t *needed) {
         if (Match(actual, OptionalType)->type == NULL) return (needed->tag == OptionalType);
 
         // Optional num -> num
-        if (needed->tag == FloatType && actual->tag == OptionalType && Match(actual, OptionalType)->type->tag == FloatType)
+        if (needed->tag == FloatType && actual->tag == OptionalType
+            && Match(actual, OptionalType)->type->tag == FloatType)
             return can_promote(Match(actual, OptionalType)->type, needed);
     }
 
@@ -379,7 +389,7 @@ PUREFUNC bool can_promote(type_t *actual, type_t *needed) {
 PUREFUNC bool is_int_type(type_t *t) { return t->tag == IntType || t->tag == BigIntType || t->tag == ByteType; }
 
 PUREFUNC bool is_numeric_type(type_t *t) {
-    return t->tag == IntType || t->tag == BigIntType || t->tag == FloatType || t->tag == ByteType;
+    return t->tag == IntType || t->tag == BigIntType || t->tag == FloatType || t->tag == ByteType || t->tag == RealType;
 }
 
 PUREFUNC bool is_packed_data(type_t *t) {
@@ -459,6 +469,7 @@ PUREFUNC size_t type_size(type_t *t) {
         }
     }
     case FloatType: return Match(t, FloatType)->bits == TYPE_NBITS64 ? sizeof(double) : sizeof(float);
+    case RealType: return sizeof(Real_t);
     case TextType: return sizeof(Text_t);
     case ListType: return sizeof(List_t);
     case TableType: return sizeof(Table_t);
@@ -548,6 +559,7 @@ PUREFUNC size_t type_align(type_t *t) {
         }
     }
     case FloatType: return Match(t, FloatType)->bits == TYPE_NBITS64 ? __alignof__(double) : __alignof__(float);
+    case RealType: return __alignof__(Real_t);
     case TextType: return __alignof__(Text_t);
     case ListType: return __alignof__(List_t);
     case TableType: return __alignof__(Table_t);
diff --git a/src/types.h b/src/types.h
index e5cc008b..a7a6ffcf 100644
--- a/src/types.h
+++ b/src/types.h
@@ -47,6 +47,7 @@ struct type_s {
         ByteType,
         BigIntType,
         IntType,
+        RealType,
         FloatType,
         CStringType,
         TextType,
@@ -76,6 +77,8 @@ struct type_s {
         struct {
         } ByteType;
         struct {
+        } RealType;
+        struct {
             enum { TYPE_NBITS32 = 32, TYPE_NBITS64 = 64 } bits;
         } FloatType;
         struct {
@@ -131,6 +134,7 @@ struct type_s {
 
 #define Type(typetag, ...) new (type_t, .tag = typetag, .__data.typetag = {__VA_ARGS__})
 #define INT_TYPE Type(BigIntType)
+#define REAL_TYPE Type(RealType)
 #define NUM_TYPE Type(FloatType, .bits = TYPE_NBITS64)
 #define NewFunctionType(ret, ...)                                                                                      \
     _make_function_type(ret, sizeof((arg_t[]){__VA_ARGS__}) / sizeof(arg_t), (arg_t[]){__VA_ARGS__})