Finish printing

lisp/kernel.gl

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

src/print.c

@@ -1,6 +1,8 @@
 #include "print.h"
 
 #include "lisp.h"
+// for WHITESPACEP, READ_EOS, and SYMBOL_END_P
+#include "read.h"
 
 #include <limits.h>
 #include <string.h>
@@ -11,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)) {
@@ -34,6 +37,7 @@ struct PrintOptions {
     fixnum_t base;
     bool base_upper;
     fixnum_t precision;
+    bool quoted;
 };
 
 struct PrintContext {
@@ -71,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,
@@ -97,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:
@@ -197,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:
@@ -206,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;