Finish printing

lisp/kernel.gl

@@ -1,4 +1,7 @@
 ;; -*- mode: lisp-data -*-
 
-(prin1 1.0)
+(let ((print-quoted nil))
-(write-byte 10)
+  (prin1 '(quote a))
+  (write-byte ?\n))
+(prin1 '(quote a))
+(write-byte ?\n)

src/base.h

@@ -23,24 +23,16 @@ typedef intptr_t fixnum_t;
 #    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_INF           LISP_FLOAT32_INF()
-#    define LISP_FLOAT_NEG_INF       LISP_FLOAT32_INF(true)
+#    define LISP_FLOAT_MAX_PRECISION FLOAT32_MAX_PRECISION
 #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_INF           LISP_FLOAT64_INF()
-#    define LISP_FLOAT_NEG_INF       LISP_FLOAT64_INF(true)
+#    define LISP_FLOAT_MAX_PRECISION FLOAT64_MAX_PRECISION
 #endif
 
 #define MOST_POSITIVE_FIXNUM ((intptr_t) ((INTPTR_MAX & ~(intptr_t) 3) >> 2))
@@ -92,8 +84,8 @@ static ALWAYS_INLINE LispVal *MAKE_LISP_FLOAT(lisp_float_t flt) {
 }
 
 #define LISP_NAN     MAKE_LISP_FLOAT(LISP_FLOAT_NAN)
-#define LISP_POS_INF MAKE_LISP_FLOAT(LISP_FLOAT_POS_INF)
+#define LISP_POS_INF MAKE_LISP_FLOAT(LISP_FLOAT_INF)
-#define LISP_NEG_INF MAKE_LISP_FLOAT(LISP_FLOAT_NEG_INF)
+#define LISP_NEG_INF MAKE_LISP_FLOAT(-LISP_FLOAT_INF)
 
 // ###############
 // # Other types #

src/memory.h

@@ -51,11 +51,13 @@ static ALWAYS_INLINE bool LITTLE_ENDIAN_P(void) {
 #endif
 // Check if we support this system's floating point implementation
 #if FLT_RADIX != 2 || FLT_MANT_DIG != 24 || DBL_MANT_DIG != 53 \
-    || FLT_MAX_EXP != 128 || DBL_MAX_EXP != 1024
+    || FLT_MAX_EXP != 128 || DBL_MAX_EXP != 1024 || !defined(INFINITY)
 #    error "Floating point implementation not supported."
 #endif
 typedef float lisp_float32_t;
 typedef double lisp_float64_t;
+#define FLOAT32_MAX_PRECISION 6
+#define FLOAT64_MAX_PRECISION 15
 
 static ALWAYS_INLINE uint32_t FLOAT32_TO_INT_BITS(lisp_float32_t flt) {
     union {
@@ -99,140 +101,20 @@ 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) {
+    return INT_TO_FLOAT32_BITS(~(uint32_t) 0);
-        .sign = FLOAT_POSITIVE,
-        .exp = FLOAT32_MAX_EXP,
-        .mantissa = FLOAT32_MAX_MANTISSA,
-    });
 }
 
-static ALWAYS_INLINE lisp_float32_t LISP_FLOAT32_INF(bool negative) {
+static ALWAYS_INLINE lisp_float32_t LISP_FLOAT32_INF(void) {
-    return PARTS_TO_FLOAT32((lisp_float32_parts) {
+    return INFINITY;
-        .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) {
+    return INT_TO_FLOAT64_BITS(~(uint64_t) 0);
-        .sign = FLOAT_POSITIVE,
-        .exp = FLOAT64_MAX_EXP,
-        .mantissa = FLOAT64_MAX_MANTISSA,
-    });
 }
 
-static ALWAYS_INLINE lisp_float64_t LISP_FLOAT64_INF(bool negative) {
+static ALWAYS_INLINE lisp_float64_t LISP_FLOAT64_INF(void) {
-    return PARTS_TO_FLOAT64((lisp_float64_parts) {
+    return INFINITY;
-        .sign = negative ? FLOAT_NEGATIVE : FLOAT_POSITIVE,
-        .exp = FLOAT64_MAX_EXP,
-        .mantissa = 0,
-    });
 }
 
 // Allocator

src/print.c

@@ -1,8 +1,11 @@
 #include "print.h"
 
 #include "lisp.h"
+// for WHITESPACEP, READ_EOS, and SYMBOL_END_P
+#include "read.h"
 
 #include <limits.h>
+#include <string.h>
 
 DEFVAR(print_circular, "print-circular", "", Qt);
 DEFVAR(print_length, "print-length", "", MAKE_FIXNUM(100));
@@ -10,6 +13,7 @@ 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));
+DEFVAR(print_quoted, "print-quoted", "", Qt);
 
 DEFUN(write_byte, "write-byte", (LispVal * ch), "(ch)", "") {
     if (NILP(ch)) {
@@ -33,6 +37,7 @@ struct PrintOptions {
     fixnum_t base;
     bool base_upper;
     fixnum_t precision;
+    bool quoted;
 };
 
 struct PrintContext {
@@ -70,6 +75,7 @@ static void init_print_options(struct PrintOptions *opts, bool readable) {
     } else if (opts->precision > LISP_FLOAT_MAX_PRECISION) {
         opts->precision = LISP_FLOAT_MAX_PRECISION;
     }
+    opts->quoted = !NILP(Vprint_quoted);
 }
 
 static void init_print_context(struct PrintContext *restrict pc, bool readable,
@@ -96,6 +102,8 @@ static void print_buffer(struct PrintContext *restrict pc,
 }
 #define PRINT_STATIC_BUFFER(pc, buf) print_buffer(pc, buf, sizeof(buf) - 1)
 
+static void print_driver(struct PrintContext *restrict pc, LispVal *val);
+
 static void print_fixnum_base(struct PrintContext *restrict pc, LispVal *val) {
     switch (pc->opts.base) {
     case 2:
@@ -172,12 +180,23 @@ static void print_float(struct PrintContext *restrict pc, LispVal *val) {
     case FP_NORMAL: {
         char fmt[16];
         int written =
-            snprintf(fmt, sizeof(fmt), "%%%" LISP_FIXNUM_PRINTF(d) "g",
+            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);
+        written = snprintf(buffer, sizeof(buffer), fmt, fv);
         assert(written < sizeof(buffer));
+        size_t i;
+        for (i = 0; i < written && buffer[i] != 'e'; ++i) {
+            if (buffer[i] == '.') {
+                goto no_add;
+            }
+        }
+        memmove(buffer + i + 2, buffer + i, written - i);
+        buffer[i] = '.';
+        buffer[i + 1] = '0';
+        written += 2;
+    no_add:
         print_buffer(pc, buffer, written);
     } break;
     default:
@@ -185,6 +204,137 @@ static void print_float(struct PrintContext *restrict pc, LispVal *val) {
     }
 }
 
+static void print_cons(struct PrintContext *restrict pc, LispVal *val) {
+    if (pc->opts.quoted && EQ(XCAR(val), Qquote) && list_length_eq(val, 2)) {
+        print_char(pc, '\'');
+        print_driver(pc, SECOND(val));
+        return;
+    }
+    print_char(pc, '(');
+    bool first = true;
+    DOTAILS(rest, val) {
+        if (!first) {
+            print_char(pc, ' ');
+        }
+        first = false;
+        print_driver(pc, XCAR(rest));
+        if (!LISTP(XCDR(rest))) {
+            PRINT_STATIC_BUFFER(pc, " . ");
+            print_driver(pc, XCDR(rest));
+            break;
+        }
+    }
+    print_char(pc, ')');
+}
+
+static void print_readable_string(struct PrintContext *restrict pc,
+                                  LispVal *val) {
+    LispString *s = val;
+    print_char(pc, '"');
+    for (size_t i = 0; i < s->length; ++i) {
+        char c = s->data[i];
+        switch (c) {
+        case '"':
+            PRINT_STATIC_BUFFER(pc, "\\\"");
+            break;
+        case '\n':
+            PRINT_STATIC_BUFFER(pc, "\\n");
+            break;
+        case '\t':
+            PRINT_STATIC_BUFFER(pc, "\\t");
+        case '\0':
+            PRINT_STATIC_BUFFER(pc, "\\0");
+            break;
+        default:
+            print_char(pc, c);
+            break;
+        }
+    }
+    print_char(pc, '"');
+}
+
+static void print_pretty_string(struct PrintContext *restrict pc,
+                                LispVal *val) {
+    LispString *s = val;
+    print_buffer(pc, s->data, s->length);
+}
+
+static void print_readable_symbol(struct PrintContext *restrict pc,
+                                  LispVal *val) {
+    LispSymbol *sym = val;
+    assert(STRINGP(sym->name));
+    LispString *n = sym->name;
+    for (size_t i = 0; i < n->length; ++i) {
+        char c = n->data[i];
+        if (c == '\n') {
+            PRINT_STATIC_BUFFER(pc, "\\n");
+        } else if (c == '\t') {
+            PRINT_STATIC_BUFFER(pc, "\\t");
+        } else if (c == '\0') {
+            PRINT_STATIC_BUFFER(pc, "\\0");
+        } else if (c == '\\' || SYMBOL_END_P(c)) {
+            print_char(pc, '\\');
+            print_char(pc, c);
+        } else {
+            print_char(pc, c);
+        }
+    }
+}
+
+static void print_pretty_symbol(struct PrintContext *restrict pc,
+                                LispVal *val) {
+    LispSymbol *sym = val;
+    assert(STRINGP(sym->name));
+    print_pretty_string(pc, sym->name);
+}
+
+static void print_vector(struct PrintContext *restrict pc, LispVal *val) {
+    LispVector *vec = val;
+    print_char(pc, '[');
+    bool first = true;
+    for (size_t i = 0; i < vec->length; ++i) {
+        if (!first) {
+            print_char(pc, ' ');
+        }
+        first = false;
+        print_driver(pc, vec->data[i]);
+    }
+    print_char(pc, ']');
+}
+
+static void print_hash_table(struct PrintContext *restrict pc, LispVal *val) {
+    LispHashTable *ht = val;
+    PRINT_STATIC_BUFFER(pc, "<hash-table count=");
+    // large enough for 32 or 64 bit word size
+    char buffer[32];
+    int written = snprintf(buffer, sizeof(buffer), "%zu", ht->count);
+    assert(written < sizeof(buffer));
+    print_buffer(pc, buffer, written);
+    print_char(pc, '>');
+}
+
+static void print_function(struct PrintContext *restrict pc, LispVal *val) {
+    LispFunction *f = val;
+    print_char(pc, '<');
+    switch (f->type) {
+    case FUNCTION_NATIVE:
+        PRINT_STATIC_BUFFER(pc, "native-function");
+        break;
+    case FUNCTION_INTERP:
+        PRINT_STATIC_BUFFER(pc, "interp-function");
+        break;
+    default:
+        abort();
+    }
+    print_char(pc, ' ');
+    // large enough for 32 or 64 bit word size
+    char buffer[32];
+    int written = snprintf(buffer, sizeof(buffer), "0x%jx", (uintmax_t) &f);
+    assert(written < sizeof(buffer));
+    print_buffer(pc, buffer, written);
+    print_char(pc, '>');
+}
+
 static void print_driver(struct PrintContext *restrict pc, LispVal *val) {
     switch (TYPE_OF(val)) {
     case TYPE_FIXNUM:
@@ -194,11 +344,30 @@ static void print_driver(struct PrintContext *restrict pc, LispVal *val) {
         print_float(pc, val);
         break;
     case TYPE_CONS:
+        print_cons(pc, val);
+        break;
     case TYPE_STRING:
+        if (pc->opts.readable) {
+            print_readable_string(pc, val);
+        } else {
+            print_pretty_string(pc, val);
+        }
+        break;
     case TYPE_SYMBOL:
+        if (pc->opts.readable) {
+            print_readable_symbol(pc, val);
+        } else {
+            print_pretty_symbol(pc, val);
+        }
+        break;
     case TYPE_VECTOR:
+        print_vector(pc, val);
+        break;
     case TYPE_HASH_TABLE:
+        print_hash_table(pc, val);
+        break;
     case TYPE_FUNCTION:
+        print_function(pc, val);
         break;
     default:
         abort();

src/print.h

@@ -11,6 +11,7 @@ DECLARE_VARIABLE(print_level);
 DECLARE_VARIABLE(print_base);
 DECLARE_VARIABLE(print_base_upper);
 DECLARE_VARIABLE(print_precision);
+DECLARE_VARIABLE(print_quoted);
 
 // For now, a print character function takes nil to mean flush
 DECLARE_FUNCTION(write_byte, (LispVal * ch));

src/read.c

@@ -21,8 +21,6 @@ void read_stream_init(ReadStream *stream, const char *buffer, size_t length) {
     stream->backquote_level = 0;
 }
 
-#define READ_EOS -1
-
 static ALWAYS_INLINE bool EOSP(const ReadStream *stream) {
     return stream->off == stream->len;
 }
@@ -52,10 +50,6 @@ static int peek_char(const ReadStream *stream) {
     return peek_nth_char(stream, 0);
 }
 
-static ALWAYS_INLINE bool WHITESPACEP(int c) {
-    return c == ' ' || c == '\t' || c == '\n';
-}
-
 static void skip_whitespace(ReadStream *stream) {
     bool in_comment = false;
     int c;
@@ -226,12 +220,6 @@ LispVal *next_char_literal(ReadStream *stream) {
     }
 }
 
-static ALWAYS_INLINE bool SYMBOL_END_P(int c) {
-    return WHITESPACEP(c) || c == READ_EOS || c == '(' || c == ')' || c == '['
-           || c == ']' || c == '\'' || c == '\"' || c == ',' || c == '@'
-           || c == '`' || c == ';';
-}
-
 LispVal *next_symbol(ReadStream *stream) {
     bool backslash = false;
     char *name = lisp_malloc(1);
@@ -247,6 +235,9 @@ LispVal *next_symbol(ReadStream *stream) {
                 case READ_EOS:
                     free(name);
                     read_error(stream, 0, "backslash not escaping anything");
+                case '\\':
+                    // nothing to do
+                    break;
                 case 'n':
                     c = '\n';
                     break;

src/read.h

@@ -5,6 +5,18 @@
 
 #include <stddef.h>
 
+#define READ_EOS -1
+
+static ALWAYS_INLINE bool WHITESPACEP(int c) {
+    return c == ' ' || c == '\t' || c == '\n';
+}
+
+static ALWAYS_INLINE bool SYMBOL_END_P(int c) {
+    return WHITESPACEP(c) || c == READ_EOS || c == '(' || c == ')' || c == '['
+           || c == ']' || c == '\'' || c == '\"' || c == ',' || c == '@'
+           || c == '`' || c == ';';
+}
+
 typedef struct {
     const char *buffer;
     size_t len;