glisp/src/print.c

#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));
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);
DEFVAR(print_empty_list, "print-empty-list", "", Qnil);

static void lisp_fputc(LispVal *ch, FILE *file) {
    if (NILP(ch)) {
        fflush(file);
        return;
    }
    CHECK_TYPE(ch, TYPE_FIXNUM);
    fixnum_t f = XFIXNUM(ch);
    if (f < 0 || f > 255) {
        signal_type_error(ch, Qchar);
    }
    fputc(f, file);
}

DEFUN(write_byte, "write-byte", (LispVal * ch), "(ch)", "") {
    lisp_fputc(ch, stdout);
    return Qnil;
}

DEFUN(error_write_byte, "error-write-byte", (LispVal * ch), "(ch)", "") {
    lisp_fputc(ch, stderr);
    return Qnil;
}

struct PrintOptions {
    bool readable;
    bool circle;
    fixnum_t length;
    fixnum_t level;
    fixnum_t base;
    bool base_upper;
    fixnum_t precision;
    bool quoted;
    bool empty_list;
};

struct PrintContext {
    struct PrintOptions opts;
    LispVal *print_char_fun;
    LispHashTable *seen_objects;
    LispVal *length_stack;
};

static void check_print_base(fixnum_t base) {
    switch (base) {
    case 2:
    case 8:
    case 10:
    case 16:
        break;
    default:
        lisp_signal(
            Qprint_error,
            LIST(lisp_sprintf("Invalid base: %" LISP_FIXNUM_PRINTF(d), base)));
    }
}

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);
    check_print_base(opts->base);
    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;
    }
    opts->quoted = !NILP(Vprint_quoted);
    opts->empty_list = !NILP(Vprint_empty_list);
}

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_driver(struct PrintContext *restrict pc, LispVal *val);

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:
        abort();
    }
    print_char(pc, '#');
}

static void print_fixnum(struct PrintContext *restrict pc, LispVal *val) {
    fixnum_t fn = XFIXNUM(val);
    if (fn == 0) {
        CALL(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, 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:
        abort();
    }
}

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) {
    if (NILP(val) && pc->opts.empty_list) {
        print_buffer(pc, "()", 2);
        return;
    }
    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) {
    if (NILP(val) && pc->opts.empty_list) {
        print_buffer(pc, "()", 2);
        return;
    }
    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:
        if (f->impl.native.no_eval_args) {
            PRINT_STATIC_BUFFER(pc, "special-form");
        } else {
            PRINT_STATIC_BUFFER(pc, "native-function");
        }
        break;
    case FUNCTION_INTERP:
        PRINT_STATIC_BUFFER(pc, "interp-function");
        break;
    default:
        abort();
    }
    print_char(pc, ' ');
    if (!NILP(f->name)) {
        print_driver(pc, f->name);
        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:
        print_fixnum(pc, val);
        break;
    case TYPE_FLOAT:
        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();
    }
}

// Not readable
DEFUN(princ, "princ", (LispVal * val, LispVal *print_char_fun),
      "(val &optional print-char-fun)", "") {
    struct PrintContext pc;
    init_print_context(&pc, false, print_char_fun);
    print_driver(&pc, val);
    return Qnil;
}

// Readable
DEFUN(prin1, "prin1", (LispVal * val, LispVal *print_char_fun),
      "(val &optional print-char-fun)", "") {
    struct PrintContext pc;
    init_print_context(&pc, true, print_char_fun);
    print_driver(&pc, val);
    return Qnil;
}

DEFUN(print_condition, "print-condition",
      (LispVal * name, LispVal *data, LispVal *print_char_fun),
      "(name data &optional print-char-fun)", "") {
    if (NILP(Fcondition_class_p(name))) {
        signal_type_error(name, Qcondition_class);
    }
    LispVal *printer = Fcondition_printer(name);
    if (NILP(printer)) {
        // default format
        Fprin1(CONS(name, data), print_char_fun);
    } else {
        // custom format
        CALL(printer, data, print_char_fun);
    }
    return Qnil;
}

DEFINE_SYMBOL(print_error, "print-error");
DEFINE_CONDITION_CLASS(print_error, error);

void debug_print(FILE *file, LispVal *obj) {
    switch (TYPE_OF(obj)) {
    case TYPE_FIXNUM:
        fprintf(file, "%jd", (intmax_t) XFIXNUM(obj));
        break;
    case TYPE_FLOAT:
        fprintf(file, "%f", (double) XLISP_FLOAT(obj));
        break;
    case TYPE_STRING: {
        LispString *s = obj;
        fputc('"', file);
        fwrite(s->data, 1, s->length, file);
        fputc('"', file);
        break;
    }
    case TYPE_SYMBOL: {
        LispString *name = ((LispSymbol *) obj)->name;
        fwrite(name->data, 1, name->length, file);
        break;
    }
    case TYPE_HASH_TABLE: {
        fprintf(file, "<hash-table count=%zu at 0x%jx>",
                ((LispHashTable *) obj)->count, (uintmax_t) obj);
        break;
    }
    case TYPE_FUNCTION: {
        LispFunction *fobj = obj;
        if (NILP(fobj->name)) {
            fprintf(file, "<lambda at 0x%jx>", (uintmax_t) obj);
        } else {
            fprintf(file, "<function ");
            debug_print(file, fobj->name);
            fprintf(file, " at 0x%jx>", (uintmax_t) obj);
        }
        break;
    }
    case TYPE_CONS: {
        fputc('(', file);
        DOTAILS(tail, obj) {
            if (CONSP(tail)) {
                debug_print(file, XCAR(tail));
                if (!NILP(XCDR(tail))) {
                    fputc(' ', file);
                }
            } else {
                fwrite(". ", 1, 2, file);
                debug_print(file, tail);
            }
        }
        fputc(')', file);
        break;
    }
    case TYPE_VECTOR: {
        LispVector *v = obj;
        fputc('[', file);
        for (size_t i = 0; i < v->length; ++i) {
            debug_print(file, v->data[i]);
            if (i < v->length - 1) {
                fputc(' ', file);
            }
        }
        fputc(']', file);
        break;
    }
    default:
        abort();
    }
}

void debug_obj_info(FILE *file, LispVal *obj) {
    fprintf(file, "%s -> ", LISP_TYPE_NAMES[TYPE_OF(obj)]);
    debug_print(file, obj);
    fputc('\n', file);
}