#include "print.h" #include "lisp.h" // for WHITESPACEP, READ_EOS, and SYMBOL_END_P #include "read.h" #include #include 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, "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, "", ((LispHashTable *) obj)->count, (uintmax_t) obj); break; } case TYPE_FUNCTION: { LispFunction *fobj = obj; if (NILP(fobj->name)) { fprintf(file, "", (uintmax_t) obj); } else { fprintf(file, "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); }