Zander671/glisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Print changes

Browse Source
This commit is contained in:
Zander671
2026-08-13 02:41:41 -07:00
parent 046b9b0c87
commit 7b854c1559
11 changed files with 438 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/print.c
+186 -9
View File
@@ -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) {
pc->circle = true;
pc->length = 80;
struct PrintContext {
struct PrintOptions opts;
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;
}