Print changes

Makefile

@@ -17,7 +17,7 @@ CC=gcc
 CFLAGS=$(DEBUG_CFLAGS) $(LLVM_SAN_FLAGS) -std=c11 -Wall -Wpedantic $\
        -D_POSIX_C_SOURCE=200112L
 LD=gcc
-LDFLAGS=$(LLVM_SAN_FLAGS)
+LDFLAGS=-lm $(LLVM_SAN_FLAGS)
 
 SRCS:=$(wildcard src/*.c)
 OBJS:=$(SRCS:src/%.c=bin/%.o)

lisp/kernel.gl

@@ -1,11 +1,4 @@
 ;; -*- mode: lisp-data -*-
 
-(fset 'test (lambda () (print print-circular)))
+(prin1 1.0)
-
+(write-byte 10)
-(print print-circular)
-
-(let ((print-circular nil)
-      (b t))
-  (test))
-
-(print print-circular)

src/base.h

@@ -6,6 +6,7 @@
 #include "memory.h"
 
 #include <assert.h>
+#include <inttypes.h>
 #include <stdnoreturn.h>
 
 // ###################
@@ -17,12 +18,29 @@ typedef void LispVal;
 // # Fixnum and float stuff #
 // ##########################
 typedef intptr_t fixnum_t;
+#define LISP_FIXNUM_PRINTF(code) PRI##code##PTR
 #if LISP_WORD_BITS == 32
 #    define LISP_FLOAT_SCANF  "f"
+#    define LISP_FLOAT_PRINTF "f"
 typedef lisp_float32_t lisp_float_t;
+typedef lisp_float32_parts lisp_float_parts_t;
+#    define LISP_FLOAT_MIN_EXP       FLOAT32_MIN_EXP
+#    define LISP_FLOAT_MAX_EXP       FLOAT32_MAX_EXP
+#    define LISP_FLOAT_MAX_PRECISION FLOAT32_MAX_PRECISION
+#    define LISP_FLOAT_NAN           LISP_FLOAT32_NAN()
+#    define LISP_FLOAT_POS_INF       LISP_FLOAT32_INF(false)
+#    define LISP_FLOAT_NEG_INF       LISP_FLOAT32_INF(true)
 #else
 #    define LISP_FLOAT_SCANF         "lf"
+#    define LISP_FLOAT_PRINTF        "f"
 typedef lisp_float64_t lisp_float_t;
+typedef lisp_float64_parts lisp_float_parts_t;
+#    define LISP_FLOAT_MIN_EXP       FLOAT64_MIN_EXP
+#    define LISP_FLOAT_MAX_EXP       FLOAT64_MAX_EXP
+#    define LISP_FLOAT_MAX_PRECISION FLOAT64_MAX_PRECISION
+#    define LISP_FLOAT_NAN           LISP_FLOAT64_NAN()
+#    define LISP_FLOAT_POS_INF       LISP_FLOAT64_INF(false)
+#    define LISP_FLOAT_NEG_INF       LISP_FLOAT64_INF(true)
 #endif
 
 #define MOST_POSITIVE_FIXNUM ((intptr_t) ((INTPTR_MAX & ~(intptr_t) 3) >> 2))
@@ -73,6 +91,10 @@ static ALWAYS_INLINE LispVal *MAKE_LISP_FLOAT(lisp_float_t flt) {
     return (LispVal *) ((bits & ~(uintptr_t) 3) | LISP_FLOAT_TAG);
 }
 
+#define LISP_NAN     MAKE_LISP_FLOAT(LISP_FLOAT_NAN)
+#define LISP_POS_INF MAKE_LISP_FLOAT(LISP_FLOAT_POS_INF)
+#define LISP_NEG_INF MAKE_LISP_FLOAT(LISP_FLOAT_NEG_INF)
+
 // ###############
 // # Other types #
 // ###############

src/lisp.c

@@ -4,6 +4,8 @@
 #include "init_globals.h"
 #include "lisp_string.h"
 
+#include <locale.h>
+
 LispVal *obarray;
 
 static void construct_manual_symbols(void) {
@@ -131,6 +133,22 @@ DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") {
     return rval;
 }
 
+DEFSPECIAL(setq, "setq", (LispVal * bindings), "(&rest bindings)", "") {
+    size_t nbindings = list_length(bindings);
+    if (nbindings < 2 || (nbindings & 1) != 0) {
+        // TODO error
+        abort();
+    }
+    LispVal *value = Qnil;
+    for (LispVal *rest = bindings; !NILP(bindings);
+         bindings = XCDR(XCDR(bindings))) {
+        LispVal *name = FIRST(rest);
+        value = Feval(SECOND(rest), Vlexical_environment);
+        set_lexical_variable(name, value);
+    }
+    return value;
+}
+
 DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body),
            "(bindings &rest body)", "") {
     CHECK_LISTP(bindings);

src/lisp.h

@@ -17,6 +17,7 @@ void lisp_shutdown(void);
 
 DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv));
 DECLARE_FUNCTION(progn, (LispVal * forms));
+DECLARE_FUNCTION(setq, (LispVal * bindings));
 DECLARE_FUNCTION(let, (LispVal * bindings, LispVal *body));
 DECLARE_FUNCTION(if, (LispVal * cond, LispVal *then, LispVal *otherwise));
 DECLARE_FUNCTION(and, (LispVal * forms));

src/memory.h

@@ -2,6 +2,7 @@
 #define INCLUDED_MEMORY_H
 
 #include <float.h>
+#include <math.h>
 #include <stdarg.h>
 #include <stdbool.h>
 #include <stdint.h>
@@ -10,7 +11,7 @@
 
 // Geneal macros
 #ifndef __has_attribute
-#    define __has_attribute(attr) 0
+#    define __has_attribute(x) 0
 #endif
 
 #if __has_attribute(always_inline) && defined(_NDEBUG)
@@ -98,6 +99,142 @@ static ALWAYS_INLINE lisp_float64_t INT_TO_FLOAT64_BITS(uint64_t i) {
         uint32_t: INT_TO_FLOAT32_BITS(i), \
         uint64_t: INT_TO_FLOAT64_BITS(i))
 
+#define FLOAT_POSITIVE 0
+#define FLOAT_NEGATIVE 1
+typedef struct
+#if __has_attribute(packed)
+    __attribute__((packed))
+#endif
+{
+    uint32_t sign : 1;
+    int32_t exp : 8;
+    uint32_t mantissa : 23;
+} lisp_float32_parts;
+#define FLOAT32_MIN_EXP       -127
+#define FLOAT32_MAX_EXP       127
+#define FLOAT32_MAX_PRECISION 6
+#define FLOAT32_MAX_MANTISSA  0x7fffff
+
+typedef struct
+#if __has_attribute(packed)
+    __attribute__((packed))
+#endif
+{
+    uint64_t sign : 1;
+    int64_t exp : 11;
+    uint64_t mantissa : 52;
+} lisp_float64_parts;
+#define FLOAT64_MIN_EXP       -1023
+#define FLOAT64_MAX_EXP       1023
+#define FLOAT64_MAX_PRECISION 15
+#define FLOAT64_MAX_MANTISSA  0xfffffffffffff
+
+static ALWAYS_INLINE lisp_float32_parts FLOAT32_TO_PARTS(lisp_float32_t flt) {
+#if __has_attribute(packed)
+    union {
+        lisp_float32_parts parts;
+        lisp_float32_t flt_val;
+    } conv = {.flt_val = flt};
+    conv.parts.exp -= 127;
+    return conv.parts;
+#else
+    uint32_t bits = FLOAT_TO_INT_BITS(flt);
+    return (lisp_float32_parts) {
+        .sign = bits >> 31,
+        .exp = (bits >> 23) - 127,
+        .mantissa = bits & 0x7fffff,
+    };
+#endif
+}
+
+static ALWAYS_INLINE lisp_float64_parts FLOAT64_TO_PARTS(lisp_float64_t flt) {
+#if __has_attribute(packed)
+    union {
+        lisp_float64_parts parts;
+        lisp_float64_t flt_val;
+    } conv = {.flt_val = flt};
+    conv.parts.exp -= 1023;
+    return conv.parts;
+#else
+    uint64_t bits = FLOAT_TO_INT_BITS(flt);
+    return (lisp_float64_parts) {
+        .sign = bits >> 63,
+        .exp = (bits >> 52) - 1023,
+        .mantissa = bits & 0xfffffffffffff,
+    };
+#endif
+}
+
+#define FLOAT_TO_PARTS(flt)                    \
+    _Generic((flt),                            \
+        lisp_float32_t: FLOAT32_TO_PARTS(flt), \
+        lisp_float64_t: FLOAT64_TO_PARTS(flt))
+
+static ALWAYS_INLINE lisp_float64_t PARTS_TO_FLOAT64(lisp_float64_parts parts) {
+#if __has_attribute(packed)
+    parts.exp += 1023;
+    union {
+        lisp_float64_parts parts;
+        lisp_float64_t flt_val;
+    } conv = {.parts = parts};
+    return conv.flt_val;
+#else
+    return INT_TO_FLOAT64_BITS(parts.sign << 63 | (parts.exp + 1023) << 52
+                               | parts.mantissa);
+#endif
+}
+
+static ALWAYS_INLINE lisp_float32_t PARTS_TO_FLOAT32(lisp_float32_parts parts) {
+#if __has_attribute(packed)
+    parts.exp += 127;
+    union {
+        lisp_float32_parts parts;
+        lisp_float32_t flt_val;
+    } conv = {.parts = parts};
+    return conv.flt_val;
+#else
+    return INT_TO_FLOAT32_BITS(parts.sign << 31 | (parts.exp + 127) << 23
+                               | parts.mantissa);
+#endif
+}
+
+#define PARTS_TO_FLOAT(parts)                        \
+    _Generic((parts),                                \
+        lisp_float32_parts: PARTS_TO_FLOAT32(parts), \
+        lisp_float64_parts: PARTS_TO_FLOAT64(parts))
+
+static ALWAYS_INLINE lisp_float32_t LISP_FLOAT32_NAN(void) {
+    return PARTS_TO_FLOAT32((lisp_float32_parts) {
+        .sign = FLOAT_POSITIVE,
+        .exp = FLOAT32_MAX_EXP,
+        .mantissa = FLOAT32_MAX_MANTISSA,
+    });
+}
+
+static ALWAYS_INLINE lisp_float32_t LISP_FLOAT32_INF(bool negative) {
+    return PARTS_TO_FLOAT32((lisp_float32_parts) {
+        .sign = negative ? FLOAT_NEGATIVE : FLOAT_POSITIVE,
+        .exp = FLOAT32_MAX_EXP,
+        .mantissa = 0,
+    });
+}
+
+static ALWAYS_INLINE lisp_float64_t LISP_FLOAT64_NAN(void) {
+    return PARTS_TO_FLOAT64((lisp_float64_parts) {
+        .sign = FLOAT_POSITIVE,
+        .exp = FLOAT64_MAX_EXP,
+        .mantissa = FLOAT64_MAX_MANTISSA,
+    });
+}
+
+static ALWAYS_INLINE lisp_float64_t LISP_FLOAT64_INF(bool negative) {
+    return PARTS_TO_FLOAT64((lisp_float64_parts) {
+        .sign = negative ? FLOAT_NEGATIVE : FLOAT_POSITIVE,
+        .exp = FLOAT64_MAX_EXP,
+        .mantissa = 0,
+    });
+}
+
 // Allocator
 void *lisp_realloc(void *oldptr, size_t size);
 void *lisp_malloc(size_t size);
@@ -130,6 +267,25 @@ static ALWAYS_INLINE void add_timespecs(const struct timespec *t1,
     out->tv_nsec = nsec;
 }
 
+static ALWAYS_INLINE size_t signed_number_length(intmax_t n) {
+    if (!n) {
+        return 1;
+    }
+    size_t sign_part = 0;
+    if (n < 0) {
+        n = -n;
+        sign_part = 1;
+    }
+    return sign_part + floor(log10(n)) + 1;
+}
+
+static ALWAYS_INLINE size_t unsigned_number_length(uintmax_t n) {
+    if (!n) {
+        return 1;
+    }
+    return floor(log10(n)) + 1;
+}
+
 typedef struct {
     // this is actually size + 1 bytes for the null byte
     char *buffer;

src/print.c

@@ -2,24 +2,197 @@
 
 #include "lisp.h"
 
+#include <limits.h>
+
 DEFVAR(print_circular, "print-circular", "", Qt);
 DEFVAR(print_length, "print-length", "", MAKE_FIXNUM(100));
 DEFVAR(print_level, "print-level", "", Qnil);
+DEFVAR(print_base, "print-base", "", MAKE_FIXNUM(10));
+DEFVAR(print_base_upper, "print-base-upper", "", Qt);
+DEFVAR(print_precision, "print-precision", "", MAKE_FIXNUM(6));
 
-struct PrintContext {
+DEFUN(write_byte, "write-byte", (LispVal * ch), "(ch)", "") {
+    if (NILP(ch)) {
+        fflush(stdout);
+    }
+    CHECK_TYPE(ch, TYPE_FIXNUM);
+    fixnum_t f = XFIXNUM(ch);
+    if (f < 0 || f > 255) {
+        // TODO error
+        abort();
+    }
+    fputc(f, stdout);
+    return Qnil;
+}
+
+struct PrintOptions {
+    bool readable;
     bool circle;
-    bool length;
+    fixnum_t length;
+    fixnum_t level;
+    fixnum_t base;
+    bool base_upper;
+    fixnum_t precision;
 };
 
-static void init_print_context(struct PrintContext *restrict pc) {
+struct PrintContext {
-    pc->circle = true;
+    struct PrintOptions opts;
-    pc->length = 80;
+    LispVal *print_char_fun;
+    LispHashTable *seen_objects;
+    LispVal *length_stack;
+};
+
+static void init_print_options(struct PrintOptions *opts, bool readable) {
+    opts->readable = readable;
+    opts->circle = !NILP(Vprint_circular);
+    if (NILP(Vprint_length)) {
+        opts->length = SIZE_MAX;
+    } else {
+        CHECK_TYPE(Vprint_length, TYPE_FIXNUM);
+        opts->length = XFIXNUM(Vprint_length);
+    }
+    if (NILP(Vprint_level)) {
+        opts->level = SIZE_MAX;
+    } else {
+        CHECK_TYPE(Vprint_level, TYPE_FIXNUM);
+        opts->level = XFIXNUM(Vprint_level);
+    }
+    CHECK_TYPE(Vprint_base, TYPE_FIXNUM);
+    opts->base = XFIXNUM(Vprint_base);
+    if (opts->base < 2 || opts->base > 16) {
+        opts->base = 10;
+    }
+    opts->base_upper = !NILP(Vprint_base_upper);
+    CHECK_TYPE(Vprint_precision, TYPE_FIXNUM);
+    opts->precision = XFIXNUM(Vprint_precision);
+    if (opts->precision < 0) {
+        opts->precision = 0;
+    } else if (opts->precision > LISP_FLOAT_MAX_PRECISION) {
+        opts->precision = LISP_FLOAT_MAX_PRECISION;
+    }
+}
+
+static void init_print_context(struct PrintContext *restrict pc, bool readable,
+                               LispVal *print_char_fun) {
+    init_print_options(&pc->opts, readable);
+    if (NILP(print_char_fun)) {
+        pc->print_char_fun = Qwrite_byte;
+    } else {
+        pc->print_char_fun = print_char_fun;
+    }
+    pc->seen_objects = Fmake_hash_table(Qnil, Qnil);
+    pc->length_stack = Qnil;
+}
+
+static void print_char(struct PrintContext *restrict pc, char c) {
+    CALL(pc->print_char_fun, MAKE_FIXNUM(c));
+}
+
+static void print_buffer(struct PrintContext *restrict pc,
+                         const char *restrict buf, size_t len) {
+    for (size_t i = 0; i < len; ++i) {
+        print_char(pc, buf[i]);
+    }
+}
+#define PRINT_STATIC_BUFFER(pc, buf) print_buffer(pc, buf, sizeof(buf) - 1)
+
+static void print_fixnum_base(struct PrintContext *restrict pc, LispVal *val) {
+    switch (pc->opts.base) {
+    case 2:
+        print_char(pc, '2');
+        break;
+    case 8:
+        print_char(pc, '8');
+        break;
+    case 10:
+        print_char(pc, '1');
+        print_char(pc, '0');
+        break;
+    case 16:
+        print_char(pc, '1');
+        print_char(pc, '6');
+        break;
+    default:
+        // TODO error
+        abort();
+    }
+    print_char(pc, '#');
+}
+
+static void print_fixnum(struct PrintContext *restrict pc, LispVal *val) {
+    fixnum_t fn = XFIXNUM(val);
+    if (fn == 0) {
+        Ffuncall(pc->print_char_fun, MAKE_FIXNUM('0'));
+    } else {
+        if (pc->opts.base != 10 && pc->opts.readable) {
+            print_fixnum_base(pc, val);
+        }
+        if (fn < 0) {
+            fn = -fn;
+            print_char(pc, '-');
+        }
+        // smallest base is 2
+        fixnum_t base = pc->opts.base;
+        char buf[64];
+        size_t num_len = 0;
+        while (fn) {
+            fixnum_t digit = fn % base;
+            fn /= base;
+            char to_print;
+            if (digit >= 0 && digit <= 9) {
+                to_print = '0' + digit;
+            } else if (digit >= 10 && digit <= 15) {
+                to_print = (pc->opts.base_upper ? 'A' : 'a') + digit - 10;
+            } else {
+                abort();
+            }
+            buf[63 - (num_len++)] = to_print;
+        }
+        print_buffer(pc, &buf[64 - num_len], num_len);
+    }
+}
+
+static void print_float(struct PrintContext *restrict pc, LispVal *val) {
+    lisp_float_t fv = XLISP_FLOAT(val);
+    switch (fpclassify(fv)) {
+    case FP_ZERO:
+        PRINT_STATIC_BUFFER(pc, "0.0");
+        break;
+    case FP_NAN:
+        PRINT_STATIC_BUFFER(pc, "0.0eNaN");
+        break;
+    case FP_INFINITE:
+        if (fv < 0.0) {
+            PRINT_STATIC_BUFFER(pc, "0.0eInf");
+        } else {
+            PRINT_STATIC_BUFFER(pc, "-0.0eInf");
+        }
+        break;
+    case FP_SUBNORMAL:
+    case FP_NORMAL: {
+        char fmt[16];
+        int written =
+            snprintf(fmt, sizeof(fmt), "%%%" LISP_FIXNUM_PRINTF(d) "g",
+                     pc->opts.precision);
+        assert(written < sizeof(fmt));
+        char buffer[32];
+        written = snprintf(buffer, sizeof(buffer), fmt, buffer);
+        assert(written < sizeof(buffer));
+        print_buffer(pc, buffer, written);
+    } break;
+    default:
+        abort();
+    }
 }
 
 static void print_driver(struct PrintContext *restrict pc, LispVal *val) {
     switch (TYPE_OF(val)) {
     case TYPE_FIXNUM:
+        print_fixnum(pc, val);
+        break;
     case TYPE_FLOAT:
+        print_float(pc, val);
+        break;
     case TYPE_CONS:
     case TYPE_STRING:
     case TYPE_SYMBOL:
@@ -32,16 +205,20 @@ static void print_driver(struct PrintContext *restrict pc, LispVal *val) {
     }
 }
 
-DEFUN(princ, "princ", (LispVal * val), "(val)", "") {
+// Not readable
+DEFUN(princ, "princ", (LispVal * val, LispVal *print_char_fun),
+      "(val &optional print-char-fun)", "") {
     struct PrintContext pc;
-    init_print_context(&pc);
+    init_print_context(&pc, false, print_char_fun);
     print_driver(&pc, val);
     return Qnil;
 }
 
-DEFUN(prin1, "prin1", (LispVal * val), "(val)", "") {
+// Readable
+DEFUN(prin1, "prin1", (LispVal * val, LispVal *print_char_fun),
+      "(val &optional print-char-fun)", "") {
     struct PrintContext pc;
-    init_print_context(&pc);
+    init_print_context(&pc, true, print_char_fun);
     print_driver(&pc, val);
     return Qnil;
 }

src/print.h

@@ -8,11 +8,17 @@
 DECLARE_VARIABLE(print_circular);
 DECLARE_VARIABLE(print_length);
 DECLARE_VARIABLE(print_level);
+DECLARE_VARIABLE(print_base);
+DECLARE_VARIABLE(print_base_upper);
+DECLARE_VARIABLE(print_precision);
+
+// For now, a print character function takes nil to mean flush
+DECLARE_FUNCTION(write_byte, (LispVal * ch));
 
 // Pretty print
-DECLARE_FUNCTION(princ, (LispVal * val));
+DECLARE_FUNCTION(princ, (LispVal * val, LispVal *print_char_fun));
 // Quoted print
-DECLARE_FUNCTION(prin1, (LispVal * val));
+DECLARE_FUNCTION(prin1, (LispVal * val, LispVal *print_char_fun));
 
 __attribute__((no_sanitize("address"))) void debug_print(FILE *file,
                                                          LispVal *obj);

src/read.c

@@ -315,6 +315,7 @@ LispVal *next_number_or_symbol(ReadStream *stream, int base) {
     size_t number_start = stream->off;
     size_t exp_start = 0;
     bool had_number = false;
+    bool negative = false;
     int c;
     while (!SYMBOL_END_P(peek_char(stream))) {
         c = pop_char(stream);
@@ -339,7 +340,32 @@ LispVal *next_number_or_symbol(ReadStream *stream, int base) {
                 && stream->off - 1 != exp_start) {
                 goto change_to_symbol;
             }
-            // fallthrough
+            // for inf
+            if (c == '-' && stream->off - 1 == number_start) {
+                negative = true;
+            }
+        } else if (exp_start == stream->off - 1 && base == ANY_BASE
+                   && (c == 'n' || c == 'N')) {
+            // attempt to read "nan" or fallback to symbol
+            if (tolower(pop_char(stream)) != 'a'
+                || tolower(pop_char(stream)) != 'n') {
+                goto change_to_symbol;
+            }
+            if (SYMBOL_END_P(peek_char(stream))) {
+                return LISP_NAN;
+            }
+            goto change_to_symbol;
+        } else if (exp_start == stream->off - 1 && base == ANY_BASE
+                   && (c == 'i' || c == 'I')) {
+            // same for "inf"
+            if (tolower(pop_char(stream)) != 'n'
+                || tolower(pop_char(stream)) != 'f') {
+                goto change_to_symbol;
+            }
+            if (SYMBOL_END_P(peek_char(stream))) {
+                return negative ? LISP_NEG_INF : LISP_POS_INF;
+            }
+            goto change_to_symbol;
         } else if (!is_base_char(base, c)) {
             if ((c == 'e' || c == 'E') && !exp_start && base == ANY_BASE
                 && had_number) {

src/stack.c

@@ -252,7 +252,7 @@ void set_lexical_variable(LispVal *name, LispVal *value) {
         abort();
     }
     if (DYNAMIC_SYMBOL_P(name)) {
-        push_dynamic_binding(name, value);
+        SET_SYMBOL_VALUE(name, value);
     } else {
         Vlexical_environment = Fplist_put(Vlexical_environment, name, value);
     }

src/stack.h

@@ -153,4 +153,17 @@ static ALWAYS_INLINE LispVal *UNWIND_AND_RETURN(StackFrame *frame,
 }
 noreturn void continue_unwinding(void);
 
+#define UNWIND_PROTECT(body, cleanup)                        \
+    {                                                        \
+        jmp_buf _internal_jb;                                \
+        if (setjmp(_internal_jb) == 0) {                     \
+            push_unwind_protect_frame(&_internal_jb);        \
+            StackFrame *_internal_target = LISP_STACK_REF(); \
+            {body};                                          \
+            unwind_to(_internal_target);                     \
+        } else {                                             \
+            cleanup                                          \
+        }                                                    \
+    };
+
 #endif