pit: Better double support

10 files changed, 162 insertions, 21 deletions

diff --git a/pit/Makefile b/pit/Makefile
index 771ea0d..b7b3815 100644
--- a/pit/Makefile
+++ b/pit/Makefile
@@ -3,7 +3,7 @@ EXE ?= pit
 CC ?= gcc
 AR ?= ar
 override CPPFLAGS += -MMD -MP
-override CFLAGS += -O2 -fPIC --std=c99 -g -Ideps/ -Isrc/ -Iinclude/ -Wall -Wextra -Wpedantic -Wconversion -Wformat-security -Wshadow -Wpointer-arith -Wstrict-prototypes -Wmissing-prototypes -Wnull-dereference -Wfloat-equal -Wundef -Wpointer-arith -Wbad-function-cast -Wlogical-op -Wmissing-braces -Wcast-align -Wstrict-overflow=5 -fwrapv # -ftrapv
+override CFLAGS += -O2 -fPIC --std=c99 -g -Ideps/ -Isrc/ -Iinclude/ -Wall -Wextra -Wpedantic -Wconversion -Wformat-security -Wshadow -Wpointer-arith -Wstrict-prototypes -Wmissing-prototypes -Wnull-dereference -Wfloat-equal -Wundef -Wpointer-arith -Wbad-function-cast -Wlogical-op -Wmissing-braces -Wcast-align -Wstrict-overflow=5 -fanalyzer -fwrapv # -ftrapv
 override LDFLAGS += -g -static
 
 BUILD = build_$(CC)
@@ -59,7 +59,7 @@ clean:
 	-rm -r $(BUILD)/
 
 tags: $(SRCS)
-	ctags --kinds-all=* --fields=* --extras=* --recurse src/ include/
+	@ctags --kinds-all=* --fields=* --extras=* --recurse src/ include/
 
 install: install-bin install-headers install-core install-native
 
diff --git a/pit/include/lcq/pit/lexer.h b/pit/include/lcq/pit/lexer.h
index db452e7..2bb17ee 100644
--- a/pit/include/lcq/pit/lexer.h
+++ b/pit/include/lcq/pit/lexer.h
@@ -13,6 +13,7 @@ typedef enum {
     PIT_LEX_TOKEN_DOT,
     PIT_LEX_TOKEN_QUOTE,
     PIT_LEX_TOKEN_INTEGER_LITERAL,
+    PIT_LEX_TOKEN_DOUBLE_LITERAL,
     PIT_LEX_TOKEN_STRING_LITERAL,
     PIT_LEX_TOKEN_SYMBOL,
     PIT_LEX_TOKEN__SENTINEL
diff --git a/pit/src/lexer.c b/pit/src/lexer.c
index def4084..ba4c3d6 100644
--- a/pit/src/lexer.c
+++ b/pit/src/lexer.c
@@ -11,6 +11,7 @@ const char *PIT_LEX_TOKEN_NAMES[PIT_LEX_TOKEN__SENTINEL] = {
     /* [PIT_LEX_TOKEN_DOT] = */ "dot",
     /* [PIT_LEX_TOKEN_QUOTE] = */ "quote",
     /* [PIT_LEX_TOKEN_INTEGER_LITERAL] = */ "integer_literal",
+    /* [PIT_LEX_TOKEN_DOUBLE_LITERAL] = */ "double_literal",
     /* [PIT_LEX_TOKEN_STRING_LITERAL] = */ "string_literal",
     /* [PIT_LEX_TOKEN_SYMBOL] = */ "symbol",
 };
@@ -24,7 +25,7 @@ static bool is_more_input(pit_lexer *st) {
 }
 
 static int is_symchar(int c) {
-    return c != '(' && c != ')' && c != '[' && c != ']' && c != '.' && c != '\'' && c != '"'
+    return c != '(' && c != ')' && c != '[' && c != ']' && c != '\'' && c != '"'
         && pit_libc_ctype_isprint(c)
         && !pit_libc_ctype_isspace(c);
 }
@@ -69,6 +70,8 @@ void pit_lex_bytes(pit_lexer *ret, char *buf, i64 len) {
     ret->error = NULL;
 }
 
+#include <stdio.h>
+
 pit_lex_token pit_lex_next(pit_lexer *st) {
 restart:
     st->start = st->end;
@@ -99,6 +102,7 @@ restart:
         pit_lex_token ret = PIT_LEX_TOKEN_INTEGER_LITERAL;
         int num_idx = 0;
         bool hex = false;
+        bool binary_or_octal = false;
         bool leading_dash = false;
         bool zero_prefix = false;
         if (!is_symchar(c)) {
@@ -115,11 +119,14 @@ restart:
                 case 1:
                     if (zero_prefix) {
                         if (c == 'x') { hex = true; continue; }
-                        else if (c == 'o' || c == 'b') continue;
+                        else if (c == 'o' || c == 'b') { binary_or_octal = true; continue; }
                     }
                     break;
                 }
-                if (!(pit_libc_ctype_isdigit(c) || (hex && is_hexdigit(c)))) ret = PIT_LEX_TOKEN_SYMBOL;
+                if (!hex && !binary_or_octal && c == '.' && ret != PIT_LEX_TOKEN_DOUBLE_LITERAL)
+                    ret = PIT_LEX_TOKEN_DOUBLE_LITERAL;
+                else if (!(pit_libc_ctype_isdigit(c) || (hex && is_hexdigit(c))))
+                    ret = PIT_LEX_TOKEN_SYMBOL;
                 ++num_idx;
             } while (c = peek(st), match(st, is_symchar));
         }
diff --git a/pit/src/library.c b/pit/src/library.c
index 10f56f4..098c6f9 100644
--- a/pit/src/library.c
+++ b/pit/src/library.c
@@ -283,6 +283,16 @@ static pit_value impl_symbol_p(pit_runtime *rt, pit_value args, void *data) {
     (void) data;
     return pit_value_bool_new(rt, pit_value_is_symbol(rt, pit_value_cons_car(rt, args)));
 }
+static pit_value impl_integer_to_double(pit_runtime *rt, pit_value args, void *data) {
+    (void) data;
+    i64 x = pit_value_as_integer(rt, pit_value_cons_car(rt, args));
+    return pit_value_double_new(rt, (double) x);
+}
+static pit_value impl_double_to_integer(pit_runtime *rt, pit_value args, void *data) {
+    (void) data;
+    double x = pit_value_as_double(rt, pit_value_cons_car(rt, args));
+    return pit_value_integer_new(rt, (i64) x);
+}
 static pit_value impl_cons_p(pit_runtime *rt, pit_value args, void *data) {
     (void) data;
     return pit_value_bool_new(rt, pit_value_is_cons(rt, pit_value_cons_car(rt, args)));
@@ -683,6 +693,50 @@ static pit_value impl_mod(pit_runtime *rt, pit_value args, void *data) {
     i64 y = pit_value_as_integer(rt, pit_value_cons_car(rt, pit_value_cons_cdr(rt, args)));
     return pit_value_integer_new(rt, x % y);
 }
+static pit_value impl_double_abs(pit_runtime *rt, pit_value args, void *data) {
+    (void) data;
+    double x = pit_value_as_double(rt, pit_value_cons_car(rt, args));
+    if (x < 0) return pit_value_double_new(rt, -x);
+    return pit_value_double_new(rt, x);
+}
+static pit_value impl_double_add(pit_runtime *rt, pit_value args, void *data) {
+    (void) data;
+    double total = 0;
+    while (args != PIT_NIL) {
+        total += pit_value_as_double(rt, pit_value_cons_car(rt, args));
+        args = pit_value_cons_cdr(rt, args);
+    }
+    return pit_value_double_new(rt, total);
+}
+static pit_value impl_double_sub(pit_runtime *rt, pit_value args, void *data) {
+    (void) data;
+    double total = 0;
+    while (args != PIT_NIL) {
+        total -= pit_value_as_double(rt, pit_value_cons_car(rt, args));
+        args = pit_value_cons_cdr(rt, args);
+    }
+    return pit_value_double_new(rt, total);
+}
+static pit_value impl_double_mul(pit_runtime *rt, pit_value args, void *data) {
+    (void) data;
+    double total = 1;
+    while (args != PIT_NIL) {
+        total *= pit_value_as_double(rt, pit_value_cons_car(rt, args));
+        args = pit_value_cons_cdr(rt, args);
+    }
+    return pit_value_double_new(rt, total);
+}
+static pit_value impl_double_div(pit_runtime *rt, pit_value args, void *data) {
+    (void) data;
+    double total = pit_value_as_double(rt, pit_value_cons_car(rt, args));
+    args = pit_value_cons_cdr(rt, args);
+    while (args != PIT_NIL) {
+        double denom = pit_value_as_double(rt, pit_value_cons_car(rt, args));
+        total /= denom;
+        args = pit_value_cons_cdr(rt, args);
+    }
+    return pit_value_double_new(rt, total);
+}
 static pit_value impl_not(pit_runtime *rt, pit_value args, void *data) {
     (void) data;
     if (pit_value_cons_car(rt, args) == PIT_NIL) {
@@ -786,6 +840,9 @@ void pit_install_library_essential(pit_runtime *rt) {
     pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "array?"), pit_value_nativefunc_new(rt, impl_array_p));
     pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "bytes?"), pit_value_nativefunc_new(rt, impl_bytes_p));
     pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "function?"), pit_value_nativefunc_new(rt, impl_function_p));
+    /* conversions */
+    pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "integer->double"), pit_value_nativefunc_new(rt, impl_integer_to_double));
+    pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "double->integer"), pit_value_nativefunc_new(rt, impl_double_to_integer));
     /* symbols */
     pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "set!"), pit_value_nativefunc_new(rt, impl_set));
     pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "fset!"), pit_value_nativefunc_new(rt, impl_fset));
@@ -836,6 +893,11 @@ void pit_install_library_essential(pit_runtime *rt) {
     pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "*"), pit_value_nativefunc_new(rt, impl_mul));
     pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "/"), pit_value_nativefunc_new(rt, impl_div));
     pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "%"), pit_value_nativefunc_new(rt, impl_mod));
+    pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "double/abs"), pit_value_nativefunc_new(rt, impl_double_abs));
+    pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "double/+"), pit_value_nativefunc_new(rt, impl_double_add));
+    pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "double/-"), pit_value_nativefunc_new(rt, impl_double_sub));
+    pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "double/*"), pit_value_nativefunc_new(rt, impl_double_mul));
+    pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "double//"), pit_value_nativefunc_new(rt, impl_double_div));
     /* booleans */
     pit_symtab_fset(rt, pit_symtab_intern_cstr(rt, "not"), pit_value_nativefunc_new(rt, impl_not));
     /* comparisons */
diff --git a/pit/src/native.c b/pit/src/native.c
index 4dab09d..8ef886d 100644
--- a/pit/src/native.c
+++ b/pit/src/native.c
@@ -17,6 +17,7 @@ i64 pit_lex_file(pit_lexer *ret, char *path) {
     fseek(f, 0, SEEK_SET);
     char *buf = calloc((size_t) len, sizeof(char));
     if ((size_t) len != fread(buf, sizeof(char), (size_t) len, f)) {
+        free(buf);
         fclose(f);
         return -1;
     }
@@ -294,6 +295,7 @@ static pit_value impl_bs_new(pit_runtime *rt, pit_value args, void *data) {
     (void) args;
     i64 cap = 256;
     struct bytestring *bs = malloc(sizeof(struct bytestring));
+    if (!bs) return PIT_NIL;
     bs->len = 0;
     bs->cap = cap;
     bs->data = calloc((size_t) cap, 1);
diff --git a/pit/src/parser.c b/pit/src/parser.c
index 0f9b167..6c633c9 100644
--- a/pit/src/parser.c
+++ b/pit/src/parser.c
@@ -46,6 +46,11 @@ static i64 digit_value(char c) {
     }
 }
 
+static double digit_value_double(char c) {
+    i64 ret = digit_value(c);
+    return (double) ret;
+}
+
 void pit_parser_from_lexer(pit_parser *ret, pit_lexer *lex) {
     ret->lexer = lex;
     ret->cur.token = ret->next.token = PIT_LEX_TOKEN_ERROR;
@@ -154,6 +159,35 @@ pit_value pit_parse(pit_runtime *rt, pit_parser *st, bool *eof) {
         }
         return pit_value_integer_new(rt, neg ? -total : total);
     }
+    case PIT_LEX_TOKEN_DOUBLE_LITERAL: {
+        i64 idx = st->cur.start;
+        double total = 0.0;
+        double point = 1.0;
+        bool after_point = false;
+        bool neg = false;
+        char c = st->lexer->input[idx++];
+        if (c == '-') {
+            neg = true;
+            if (idx < st->cur.end) {
+                c = st->lexer->input[idx++];
+            } else {
+                pit_error(rt, "malformed negative double literal"); return PIT_NIL;
+            }
+        } else if (c == '.') after_point = true;
+        total = digit_value_double(c);
+        while (idx < st->cur.end) {
+            c = st->lexer->input[idx++];
+            if (c == '.') {
+                after_point = true;
+            } else {
+                total *= 10.0;
+                total += digit_value_double(c);
+                if (after_point) point *= 10.0;
+            }
+        }
+        total /= point;
+        return pit_value_double_new(rt, neg ? -total : total);
+    }
     case PIT_LEX_TOKEN_STRING_LITERAL: {
         char buf[256] = {0};
         get_token_string(st, buf, sizeof(buf));
diff --git a/pit/src/runtime/dump.c b/pit/src/runtime/dump.c
index 4d67bb6..5c113fa 100644
--- a/pit/src/runtime/dump.c
+++ b/pit/src/runtime/dump.c
@@ -1,6 +1,8 @@
 #include <lcq/pit/utils.h>
 #include <lcq/pit/runtime/dump.h>
 
+#include <stdio.h>
+
 pit_dump_condition pit_dump_with_callback(
     pit_runtime *rt, pit_value top, bool readable,
     pit_dump_callback write, void *data
@@ -111,7 +113,10 @@ pit_dump_condition pit_dump_with_callback(
                         if (readable) { buf[i++] = '"'; }
                         i64 maxlen = len - i;
                         for (i64 j = 0; i < maxlen && j < h->in.bytes.len;) {
-                            if (buf[i - 1] != '\\' && (h->in.bytes.data[j] == '\\' || h->in.bytes.data[j] == '"')) {
+                            bool needs_backslash =
+                                (i == 0 || buf[i - 1] != '\\')
+                                && (h->in.bytes.data[j] == '\\' || h->in.bytes.data[j] == '"');
+                            if (needs_backslash) {
                                 buf[i++] = '\\';
                             }
                             else {
diff --git a/pit/src/runtime/macroexpand.c b/pit/src/runtime/macroexpand.c
index 042a972..fa49968 100644
--- a/pit/src/runtime/macroexpand.c
+++ b/pit/src/runtime/macroexpand.c
@@ -5,13 +5,17 @@ pit_value pit_macroexpand_1(pit_runtime *rt, pit_value top) {
     i64 expr_stack_reset = rt->expr_stack->next;
     i64 result_stack_reset = rt->result_stack->next;
     i64 traversal_reset = rt->traversal->next;
-    if (pit_vec_push(pit_value)(rt->expr_stack, top) < 0)
+    if (pit_vec_push(pit_value)(rt->expr_stack, top) < 0) {
         pit_error(rt, "macro expansion stack overflow");
+        goto end;
+    }
     while (rt->expr_stack->next > expr_stack_reset) {
         pit_value cur = PIT_NIL;
         if (rt->error != PIT_NIL) goto end;
-        if (pit_vec_pop(pit_value)(rt->expr_stack, &cur) < 0)
+        if (pit_vec_pop(pit_value)(rt->expr_stack, &cur) < 0) {
             pit_error(rt, "macro expansion stack underflow");
+            goto end;
+        }
         if (pit_value_is_cons(rt, cur)) {
             pit_value fsym = pit_value_cons_car(rt, cur);
             bool is_symbol = pit_value_is_symbol(rt, fsym);
@@ -26,21 +30,27 @@ pit_value pit_macroexpand_1(pit_runtime *rt, pit_value top) {
                 pit_value f = pit_symtab_fget(rt, fsym);
                 pit_value args = pit_value_cons_cdr(rt, cur);
                 pit_value res = pit_vm_apply(rt, f, args);
-                if (pit_vec_push(pit_value)(rt->expr_stack, res) < 0)
+                if (pit_vec_push(pit_value)(rt->expr_stack, res) < 0) {
                     pit_error(rt, "macro expansion stack overflow");
+                    goto end;
+                }
             } else {
                 pit_value args = pit_value_cons_cdr(rt, cur);
                 i64 argcount = 0;
                 while (args != PIT_NIL) {
                     pit_value a = pit_value_cons_car(rt, args);
-                    if (pit_vec_push(pit_value)(rt->expr_stack, a) < 0)
+                    if (pit_vec_push(pit_value)(rt->expr_stack, a) < 0) {
                         pit_error(rt, "macro expansion stack overflow");
+                        goto end;
+                    }
                     args = pit_value_cons_cdr(rt, args);
                     argcount += 1;
                 }
                 if (!is_symbol) {
-                    if (pit_vec_push(pit_value)(rt->expr_stack, fsym) < 0)
+                    if (pit_vec_push(pit_value)(rt->expr_stack, fsym) < 0) {
                         pit_error(rt, "macro expansion stack overflow");
+                        goto end;
+                    }
                 }
                 pit_traversal_push_application(rt, rt->traversal, argcount, ann);
                 if (is_symbol) {
@@ -53,31 +63,42 @@ pit_value pit_macroexpand_1(pit_runtime *rt, pit_value top) {
     }
     for (i64 idx = rt->traversal->next - 1; idx >= traversal_reset; --idx) {
         pit_traversal_entry *ent = pit_vec_get(pit_traversal_entry)(rt->traversal, idx);
-        if (ent == NULL) pit_error(rt, "macro expansion traversal invalid");
+        if (ent == NULL) {
+            pit_error(rt, "macro expansion traversal invalid");
+            goto end;
+        }
         if (rt->error != PIT_NIL) goto end;
         switch (ent->sort) {
         case PIT_TRAVERSAL_ENTRY_VALUE:
-            if (pit_vec_push(pit_value)(rt->result_stack, ent->in.value) < 0)
+            if (pit_vec_push(pit_value)(rt->result_stack, ent->in.value) < 0) {
                 pit_error(rt, "macro expansion stack overflow");
+                goto end;
+            }
             break;
         case PIT_TRAVERSAL_ENTRY_APPLICATION: {
             pit_value f = PIT_NIL;
             pit_value args = PIT_NIL;
             pit_value app = PIT_NIL;
-            if (pit_vec_pop(pit_value)(rt->result_stack, &f) < 0)
+            if (pit_vec_pop(pit_value)(rt->result_stack, &f) < 0) {
                 pit_error(rt, "macro expansion stack underflow");
+                goto end;
+            }
             for (i64 i = 0; i < ent->in.application.arity; ++i) {
                 pit_value a = PIT_NIL;
-                if (pit_vec_pop(pit_value)(rt->result_stack, &a) < 0)
+                if (pit_vec_pop(pit_value)(rt->result_stack, &a) < 0) {
                     pit_error(rt, "macro expansion stack underflow");
+                    goto end;
+                }
                 args = pit_value_cons(rt, a, args);
             }
             app = pit_value_cons(rt, f, args);
             if (ent->in.application.annotation != NULL) {
                 pit_annotation_set(rt, pit_value_as_ref(rt, app), *ent->in.application.annotation);
             }
-            if (pit_vec_push(pit_value)(rt->result_stack, app) < 0)
+            if (pit_vec_push(pit_value)(rt->result_stack, app) < 0) {
                 pit_error(rt, "macroexpansion stack overflow");
+                goto end;
+            }
             break;
         }
         default:
diff --git a/pit/src/runtime/value.c b/pit/src/runtime/value.c
index 6354f60..154e6a1 100644
--- a/pit/src/runtime/value.c
+++ b/pit/src/runtime/value.c
@@ -1,5 +1,16 @@
 #include <lcq/pit/runtime/value.h>
 
+const i64 PIT__SORT_DOUBLE = PIT_VALUE_SORT_DOUBLE;
+const i64 PIT__SORT_INTEGER = PIT_VALUE_SORT_INTEGER;
+const i64 PIT__SORT_SYMBOL = PIT_VALUE_SORT_SYMBOL;
+const i64 PIT__SORT_CELL = PIT_VALUE_SORT_REF + PIT_VALUE_HEAVY_SORT_CELL;
+const i64 PIT__SORT_CONS = PIT_VALUE_SORT_REF + PIT_VALUE_HEAVY_SORT_CONS;
+const i64 PIT__SORT_ARRAY = PIT_VALUE_SORT_REF + PIT_VALUE_HEAVY_SORT_ARRAY;
+const i64 PIT__SORT_BYTES = PIT_VALUE_SORT_REF + PIT_VALUE_HEAVY_SORT_BYTES;
+const i64 PIT__SORT_FUNC = PIT_VALUE_SORT_REF + PIT_VALUE_HEAVY_SORT_FUNC;
+const i64 PIT__SORT_NATIVEFUNC = PIT_VALUE_SORT_REF + PIT_VALUE_HEAVY_SORT_NATIVEFUNC;
+const i64 PIT__SORT_NATIVEDATA = PIT_VALUE_SORT_REF + PIT_VALUE_HEAVY_SORT_NATIVEDATA;
+
 pit_value pit_value_new(pit_runtime *rt, enum pit_value_sort s, u64 data) {
     if (s == PIT_VALUE_SORT_DOUBLE) {
         /* if (((data >> 52) & 0b011111111111) == 0b011111111111 && ((data >> 51) & 0b1) == 0) { */
diff --git a/pit/src/utils.c b/pit/src/utils.c
index ac8087c..7bbad10 100644
--- a/pit/src/utils.c
+++ b/pit/src/utils.c
@@ -1,5 +1,7 @@
 #include <lcq/pit/utils.h>
 
+#include <stdio.h>
+
 enum vsnprintf_mode {
     VSNPRINTF_MODE_NORMAL,
     VSNPRINTF_MODE_FLAGS,
@@ -55,11 +57,7 @@ int pit_vsnprintf_helper(
                 break;
             }
             case 'f': {
-                double arg = 0.0;
-                if (length_mod == 'l')
-                    arg = va_arg(ap, double);
-                else
-                    arg = va_arg(ap, double);
+                double arg = arg = va_arg(ap, double);
                 long wholepart = (long) arg;
                 double fracpart = arg - (double) wholepart;
                 if (wholepart == 0) { WRITE('0') }