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

Recursive reading and printing

Browse Source
This commit is contained in:
Zander671
2026-09-07 10:53:21 -07:00
parent 3dfac40e7e
commit a68ddba589
7 changed files with 255 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files
lisp/kernel.gl
+1 -1
View File
@@ -23,4 +23,4 @@
(princ datum print-char-fun)
(funcall (or print-char-fun 'write-byte) ?\n))
(princln (list (symbolp 1) '1a '1aa))
(princln '#1=(a '#2=(a #1# c) . #1#))
src/function.c
+1
View File
@@ -213,6 +213,7 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(void),
ReadStream stream;
read_stream_init_from_string(&stream, lisp_args, args_len);
LispVal *args_form = read(&stream);
read_stream_cleanup(&stream);
if (!args_form) {
fprintf(stderr, "Builtin function lambda list had a syntax error\n");
fprintf(stderr, "Name: ");
src/main.c
+1
View File
@@ -42,6 +42,7 @@ int main(int argc, const char **argv) {
StackFrame *toplevel = LISP_STACK_REF();
ReadStream s;
read_stream_init_from_string(&s, src, src_len);
push_unwind_protect_frame(read_stream_cleanup, &s, NULL);
LispVal *r;
push_handler_bind_frame(LIST(Qt), toplevel_error_handler, NULL, NULL);
volatile bool had_toplevel_error = false;
src/memory.h
+4
View File
@@ -41,6 +41,10 @@ static ALWAYS_INLINE bool LITTLE_ENDIAN_P(void) {
return ENDIANNESS() == ENDIAN_LITTLE;
}
// ceil(# bytes in sizeof(t) / 3)
// This works because log10(2^n) is O(n) for k=3
#define NUMBER_PRINTF_BUFFER_SIZE(t) (((sizeof(t) * 8) / 3) + 1)
// General float stuff
#if SIZE_MAX == 0xffffffff
# define LISP_WORD_BITS 32
src/print.c
+138 -6
View File
@@ -32,8 +32,9 @@ struct PrintOptions {
struct PrintContext {
struct PrintOptions opts;
LispVal *print_char_fun;
size_t next_circular_num;
LispHashTable *seen_objects;
LispVal *length_stack;
LispHashTable *printed_objects;
};
static void check_print_base(fixnum_t base) {
@@ -88,8 +89,14 @@ static void init_print_context(struct PrintContext *restrict pc, bool readable,
} else {
pc->print_char_fun = print_char_fun;
}
pc->seen_objects = Fmake_hash_table(Qnil, Qnil);
pc->length_stack = Qnil;
if (pc->opts.circle) {
pc->seen_objects = Fmake_hash_table(Qnil, Qnil);
pc->printed_objects = Fmake_hash_table(Qnil, Qnil);
} else {
pc->seen_objects = Qnil;
pc->printed_objects = Qnil;
}
pc->next_circular_num = 0;
}
static void print_char(struct PrintContext *restrict pc, char c) {
@@ -205,16 +212,95 @@ static void print_float(struct PrintContext *restrict pc, LispVal *val) {
}
}
static bool seen_object_p(struct PrintContext *restrict pc, LispVal *val) {
if (!pc->opts.circle) {
return false;
}
return !NILP(Fgethash(pc->seen_objects, val, Qnil));
}
static bool recursive_object_p(struct PrintContext *restrict pc, LispVal *val) {
if (!pc->opts.circle) {
return false;
}
return FIXNUMP(Fgethash(pc->seen_objects, val, Qnil));
}
static void mark_object_seen(struct PrintContext *restrict pc, LispVal *val) {
assert(pc->opts.circle);
Fputhash(pc->seen_objects, val, Qt);
}
static fixnum_t seen_object_number(struct PrintContext *restrict pc,
LispVal *val) {
assert(pc->opts.circle);
LispVal *cur = Fgethash(pc->seen_objects, val, Qnil);
assert(!NILP(cur));
if (FIXNUMP(cur)) {
return XFIXNUM(cur);
}
Fputhash(pc->seen_objects, val, MAKE_FIXNUM(pc->next_circular_num));
return pc->next_circular_num++;
}
static bool printed_seen_object_p(struct PrintContext *restrict pc,
LispVal *val) {
assert(pc->opts.circle);
return !NILP(Fgethash(pc->printed_objects, val, Qnil));
}
static void mark_object_printed(struct PrintContext *restrict pc,
LispVal *val) {
assert(pc->opts.circle);
Fputhash(pc->printed_objects, val, Qt);
}
static void print_numbered_reference(struct PrintContext *restrict pc,
LispVal *val, char term) {
print_char(pc, '#');
size_t fixnum_t_len = NUMBER_PRINTF_BUFFER_SIZE(fixnum_t);
char buf[fixnum_t_len + 1];
fixnum_t n = seen_object_number(pc, val);
int l = snprintf(buf, fixnum_t_len + 1, "%" LISP_FIXNUM_PRINTF(d), n);
print_buffer(pc, buf, l);
print_char(pc, term);
}
static void print_cons(struct PrintContext *restrict pc, LispVal *val) {
if (pc->opts.quoted && EQ(XCAR(val), Qquote) && list_length_eq(val, 2)) {
if (recursive_object_p(pc, val)) {
if (printed_seen_object_p(pc, val)) {
print_numbered_reference(pc, val, '#');
return;
}
print_numbered_reference(pc, val, '=');
mark_object_printed(pc, val);
}
print_char(pc, '\'');
print_driver(pc, SECOND(val));
return;
}
print_char(pc, '(');
bool first = true;
DOTAILS(rest, val) {
if (!first) {
if (recursive_object_p(pc, rest)) {
if (!first) {
PRINT_STATIC_BUFFER(pc, " . ");
}
if (printed_seen_object_p(pc, rest)) {
print_numbered_reference(pc, rest, '#');
break;
} else {
print_numbered_reference(pc, rest, '=');
mark_object_printed(pc, rest);
if (!first) {
print_cons(pc, rest);
break;
}
}
}
if (first) {
print_char(pc, '(');
} else {
print_char(pc, ' ');
}
first = false;
@@ -298,6 +384,14 @@ static void print_pretty_symbol(struct PrintContext *restrict pc,
}
static void print_vector(struct PrintContext *restrict pc, LispVal *val) {
if (recursive_object_p(pc, val)) {
if (printed_seen_object_p(pc, val)) {
print_numbered_reference(pc, val, '#');
return;
}
print_numbered_reference(pc, val, '=');
mark_object_printed(pc, val);
}
LispVector *vec = val;
print_char(pc, '[');
bool first = true;
@@ -315,7 +409,7 @@ 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];
char buffer[NUMBER_PRINTF_BUFFER_SIZE(size_t)];
int written = snprintf(buffer, sizeof(buffer), "%zu", ht->count);
assert(written < sizeof(buffer));
print_buffer(pc, buffer, written);
@@ -352,6 +446,36 @@ static void print_function(struct PrintContext *restrict pc, LispVal *val) {
print_char(pc, '>');
}
static void scan_circular_objects(struct PrintContext *restrict pc,
LispVal *val) {
assert(HASH_TABLE_P(pc->seen_objects));
if (CONSP(val)) {
DOTAILS(rest, val) {
if (!CONSP(rest)) {
scan_circular_objects(pc, rest);
break;
}
if (!seen_object_p(pc, rest)) {
mark_object_seen(pc, rest);
scan_circular_objects(pc, XCAR(rest));
} else {
seen_object_number(pc, rest);
break;
}
}
} else if (VECTORP(val)) {
if (!seen_object_p(pc, val)) {
mark_object_seen(pc, val);
LispVector *vec = val;
for (size_t i = 0; i < vec->length; ++i) {
scan_circular_objects(pc, vec->data[i]);
}
} else {
seen_object_number(pc, val);
}
}
}
static void print_driver(struct PrintContext *restrict pc, LispVal *val) {
switch (TYPE_OF(val)) {
case TYPE_FIXNUM:
@@ -391,11 +515,18 @@ static void print_driver(struct PrintContext *restrict pc, LispVal *val) {
}
}
static void prepare_for_print(struct PrintContext *restrict pc, LispVal *obj) {
if (pc->opts.circle) {
scan_circular_objects(pc, obj);
}
}
// 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);
prepare_for_print(&pc, val);
print_driver(&pc, val);
return Qnil;
}
@@ -405,6 +536,7 @@ 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);
prepare_for_print(&pc, val);
print_driver(&pc, val);
return Qnil;
}
src/read.c
+107 -14
View File
@@ -1,6 +1,7 @@
#include "read.h"
#include "function.h"
#include "hashtable.h"
#include "io.h"
#include "lisp_string.h"
#include "list.h"
@@ -21,6 +22,8 @@ void read_stream_init_from_string(ReadStream *restrict stream,
stream->string.buffer = buffer;
stream->string.len = length;
stream->string.off = 0;
stream->named_objects = make_hash_table_no_gc(Qnil, Qnil);
stream->need_record_self = Qnil;
stream->line = 1;
stream->col = 0;
stream->backquote_level = 0;
@@ -31,11 +34,17 @@ void read_stream_init_from_func(ReadStream *restrict stream,
stream->kind = READ_STREAM_FUNC;
stream->func.func = read_char_func;
stream->func.is_eof = false;
stream->named_objects = make_hash_table_no_gc(Qnil, Qnil);
stream->need_record_self = Qnil;
stream->line = 1;
stream->col = 0;
stream->backquote_level = 0;
}
void read_stream_cleanup(void *stream) {
release_hash_table_no_gc(((ReadStream *) stream)->named_objects);
}
static int peek_char(ReadStream *restrict stream);
static ALWAYS_INLINE bool EOSP(ReadStream *restrict stream) {
switch (stream->kind) {
@@ -119,12 +128,14 @@ static void skip_whitespace(ReadStream *restrict stream) {
FORMAT(2, 3)
static noreturn void read_error(ReadStream *restrict stream,
const char *restrict msg, ...) {
int c = pop_char(stream);
va_list args;
va_start(args, msg);
LispVal *lmsg = lisp_vsprintf(msg, args);
va_end(args);
lisp_signal(Qread_error, LIST(MAKE_FIXNUM(stream->line),
MAKE_FIXNUM(stream->col), lmsg));
lisp_signal(Qread_error,
LIST(MAKE_FIXNUM(stream->line), MAKE_FIXNUM(stream->col), lmsg,
c == READ_EOS ? Qnil : MAKE_FIXNUM(c)));
}
static ALWAYS_INLINE bool DOT_SYMBOL_P(LispVal *val) {
@@ -138,7 +149,10 @@ static ALWAYS_INLINE bool DOT_SYMBOL_P(LispVal *val) {
LispVal *next_list(ReadStream *restrict stream) {
pop_char(stream); // the (
skip_whitespace(stream);
LispVal *start = Qnil;
LispVal *start = CONS(Qnil, Qnil);
if (!NILP(stream->need_record_self)) {
Fputhash(stream->named_objects, stream->need_record_self, start);
}
LispVal *end = NULL;
bool dotted = false;
while (peek_char(stream) != ')') {
@@ -159,8 +173,8 @@ LispVal *next_list(ReadStream *restrict stream) {
}
if (dotted) {
RPLACD(end, new_val);
} else if (NILP(start)) {
start = CONS(new_val, Qnil);
} else if (end == NULL) {
RPLACA(start, new_val);
end = start;
} else {
RPLACD(end, CONS(new_val, Qnil));
@@ -171,18 +185,21 @@ LispVal *next_list(ReadStream *restrict stream) {
if (pop_char(stream) == READ_EOS) { // the )
read_error(stream, "got EOF while reading list");
}
return start;
return end == NULL ? Qnil : start;
}
LispVal *next_vector(ReadStream *restrict stream) {
pop_char(stream); // the [
skip_whitespace(stream);
LispVal **data = NULL;
size_t length = 0;
LispVal *vec = make_vector(NULL, 0, true);
#define data ((LispVector *) vec)->data
#define length ((LispVector *) vec)->length
if (!NILP(stream->need_record_self)) {
Fputhash(stream->named_objects, stream->need_record_self, vec);
}
while (peek_char(stream) != ']') {
LispVal *new_val = read(stream);
if (!new_val) {
free(data);
read_error(stream, "got EOF while reading vector");
}
data = lisp_realloc(data, sizeof(LispVal *) * ++length);
@@ -193,7 +210,9 @@ LispVal *next_vector(ReadStream *restrict stream) {
free(data);
read_error(stream, "got EOF while reading vector");
}
return make_vector(data, length, true);
return vec;
#undef data
#undef length
}
LispVal *next_string(ReadStream *restrict stream) {
@@ -446,9 +465,7 @@ LispVal *next_number_or_symbol(ReadStream *restrict stream, int base) {
size_t len = ss.nchars - number_start;
if (has_decimal || exp_start) {
// float
// ceil(# bytes in size_t / 3)
// This works because log10(2^n) is O(n) for k=3
size_t size_t_len = ((sizeof(size_t) * 8) / 3) + 1;
size_t size_t_len = NUMBER_PRINTF_BUFFER_SIZE(size_t);
char fmt_buf[3 + size_t_len + 1];
if (exp_start == ss.nchars) {
goto change_to_symbol;
@@ -480,7 +497,81 @@ change_to_symbol:
next_symbol(ss.buffer, ss.nchars, stream));
}
LispVal *read(ReadStream *stream) {
static fixnum_t convert_object_number(ReadStream *restrict stream,
const char *buffer) {
char *endptr;
intmax_t number = strtoimax(buffer, &endptr, 10);
if (number < 0 || number > MOST_POSITIVE_FIXNUM) {
read_error(stream, "object number out of range: %jd", number);
}
return number;
}
static LispVal *lookup_numbered_object(ReadStream *restrict stream,
fixnum_t n) {
LispVal *lisp_n = MAKE_FIXNUM(n);
LispVal *obj = Fgethash(stream->named_objects, lisp_n, Qunbound);
if (obj == Qunbound) {
read_error(stream,
"numbered object not defined: %" LISP_FIXNUM_PRINTF(d), n);
}
return obj;
}
static LispVal *read_numbered(ReadStream *restrict stream, fixnum_t n) {
if (!NILP(Fgethash(stream->named_objects, MAKE_FIXNUM(n), Qnil))) {
read_error(stream, "duplicate named object: %" LISP_FIXNUM_PRINTF(d),
n);
}
LispVal *save = stream->need_record_self;
stream->need_record_self = MAKE_FIXNUM(n);
LispVal *obj = read(stream);
Fremhash(stream->named_objects, stream->need_record_self);
stream->need_record_self = save;
return obj;
}
static LispVal *hash_dispatcher(ReadStream *restrict stream) {
pop_char(stream); // the #
StringStream ss;
string_stream_init(&ss);
StackFrame *stack_ref = LISP_STACK_REF();
push_unwind_protect_frame(string_stream_free_as_cleanup, &ss, NULL);
int c;
while ((c = peek_char(stream)) != READ_EOS) {
switch (c) {
case '#':
pop_char(stream);
return UNWIND_AND_RETURN(
stack_ref,
lookup_numbered_object(
stream, convert_object_number(stream, ss.buffer)));
case '=':
pop_char(stream);
return UNWIND_AND_RETURN(
stack_ref, read_numbered(stream, convert_object_number(
stream, ss.buffer)));
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
pop_char(stream);
string_stream_putc(&ss, c);
break;
default:
read_error(stream, "expected digit, '#', or '=");
}
}
read_error(stream, "got EOF while reading object number");
}
LispVal *read(ReadStream *restrict stream) {
skip_whitespace(stream);
if (EOSP(stream)) {
return NULL;
@@ -548,6 +639,8 @@ LispVal *read(ReadStream *stream) {
case '8':
case '9':
return next_number_or_symbol(stream, ANY_BASE);
case '#':
return hash_dispatcher(stream);
default:
return next_symbol(NULL, 0, stream);
}
src/read.h
+3
View File
@@ -36,6 +36,8 @@ typedef struct {
} func;
};
LispVal *need_record_self; // fixnum or null
LispVal *named_objects; // hashtable
size_t line;
size_t col;
size_t backquote_level;
@@ -44,6 +46,7 @@ typedef struct {
void read_stream_init_from_string(ReadStream *stream, const char *buffer,
size_t length);
void read_stream_init_from_func(ReadStream *stream, LispVal *read_char_func);
void read_stream_cleanup(void *stream);
// NULL on eof
LispVal *read(ReadStream *stream);