nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implement fixed-function reader for getting data into the interpreter.

This commit is contained in:
Jesse D. McDonald 2009-11-13 01:18:57 -06:00
parent 10fbc269c5
commit 449b0cf478
8 changed files with 1054 additions and 339 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
Makefile
View File

@ -1,5 +1,5 @@
CFLAGS = -std=c99 CFLAGS = -std=c99 -Wall
LDFLAGS = -lrt LDFLAGS = -lrt -lm
ifeq ($(DEBUG),yes) ifeq ($(DEBUG),yes)
CFLAGS += -g CFLAGS += -g
@ -25,9 +25,10 @@ endif
clean: clean:
-rm -f rosella *.o *.gcda *.gcno -rm -f rosella *.o *.gcda *.gcno
rosella: rosella.o gc.o builtin.o interp.o rosella: rosella.o gc.o builtin.o interp.o reader.o
rosella.o: rosella.c gc.h builtin.h interp.h rosella.o: rosella.c gc.h builtin.h interp.h
gc.o: gc.c gc.h gc.o: gc.c gc.h
builtin.o: builtin.c builtin.h gc.h builtin.o: builtin.c builtin.h gc.h
interp.o: interp.c interp.h gc.h builtin.h interp.o: interp.c interp.h gc.h builtin.h
reader.o: reader.c reader.h gc.h builtin.h

233
builtin.c
View File

@ -2,120 +2,28 @@
#include <inttypes.h> #include <inttypes.h>
#include <stdbool.h> #include <stdbool.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h>
#include "gc.h" #include "gc.h"
#include "builtin.h" #include "builtin.h"
static gc_root_t builtin_list; static gc_root_t builtin_list;
/* Returns a byte string w/ bytes from 's' (excl. terminating NUL). */ static void register_structure(gc_root_t *ms_root);
static value_t string_to_value(const char *s); static void register_template(gc_root_t *ms_root);
static void register_lambda(gc_root_t *ms_root);
/* Return value is a new C string which must be free()'d by caller. */
static char *value_to_string(value_t v);
/* Like strcmp(), but for byte strings. */
static int byte_strcmp(value_t s1, value_t s2);
void builtin_init(void) void builtin_init(void)
{ {
gc_root_t ms_root, tmp_root; gc_root_t ms_root;
register_gc_root(&builtin_list, NIL); register_gc_root(&builtin_list, UNDEFINED);
register_gc_root(&ms_root, UNDEFINED);
#define SS(x) STRUCTURE_SLOT_ ## x register_builtin(BI_UNDEFINED, UNDEFINED);
/* (Meta-)Structure: Instances of this structure describe structures. */ register_structure(&ms_root);
register_gc_root(&ms_root, make_struct(NIL, STRUCTURE_SLOTS)); register_template(&ms_root);
register_builtin(BI_STRUCTURE, ms_root.value); register_lambda(&ms_root);
/* Metastruct is both a structure and a structure description,
* and thus is an instance of itself. */
_get_struct(ms_root.value)->type = ms_root.value;
/* Slot 1: Name */
_get_struct(ms_root.value)->slots[SS(NAME)] = string_to_value("structure");
/* Slot 2: Super/parent structure type, or NIL */
_get_struct(ms_root.value)->slots[SS(SUPER)] = NIL;
/* Slot 3: Vector of slot names; size == total number of slots (excl. type) */
_get_struct(ms_root.value)->slots[SS(SLOTS)] = make_vector(STRUCTURE_SLOTS, NIL);
{
gc_root_t vec_root;
register_gc_root(&vec_root, _get_struct(ms_root.value)->slots[SS(SLOTS)]);
_get_vector(vec_root.value)->elements[SS(NAME)] = string_to_value("name");
_get_vector(vec_root.value)->elements[SS(SUPER)] = string_to_value("super");
_get_vector(vec_root.value)->elements[SS(SLOTS)] = string_to_value("slots");
_get_vector(vec_root.value)->elements[SS(CALLABLE)] = string_to_value("callable");
unregister_gc_root(&vec_root);
}
/* Slot 4: Callable object used as proxy when structure is APPLY'd. */
/* Can be LAMBDA or callable structure instance. */
_get_struct(ms_root.value)->slots[SS(CALLABLE)] = NIL;
#define TS(x) TEMPLATE_SLOT_ ## x
/* Template: Instances of this structure describe what a LAMBDA
* will look like when instanciated with the 'lambda' bytecode. */
register_gc_root(&tmp_root, make_struct(ms_root.value, STRUCTURE_SLOTS));
register_builtin(BI_TEMPLATE, tmp_root.value);
/* Slot 1: Name */
_get_struct(tmp_root.value)->slots[SS(NAME)] = string_to_value("template");
/* Slot 2: Super/parent structure type, or NIL */
_get_struct(tmp_root.value)->slots[SS(SUPER)] = NIL;
/* Slot 3: Vector of slot names; size == total number of slots */
_get_struct(tmp_root.value)->slots[SS(SLOTS)] = make_vector(TEMPLATE_SLOTS, NIL);
{
gc_root_t vec_root;
register_gc_root(&vec_root, _get_struct(tmp_root.value)->slots[SS(SLOTS)]);
_get_vector(vec_root.value)->elements[TS(GLOBAL_VARS)] = string_to_value("global-vars");
_get_vector(vec_root.value)->elements[TS(INSTANCE_VARS)] = string_to_value("instance-vars");
_get_vector(vec_root.value)->elements[TS(FRAME_VARS)] = string_to_value("frame-vars");
_get_vector(vec_root.value)->elements[TS(BYTE_CODE)] = string_to_value("byte-code");
_get_vector(vec_root.value)->elements[TS(TAIL_CALL)] = string_to_value("tail-call");
_get_vector(vec_root.value)->elements[TS(ARG_LIST)] = string_to_value("argument-list");
_get_vector(vec_root.value)->elements[TS(CONTINUATION)] = string_to_value("continuation");
_get_vector(vec_root.value)->elements[TS(CONTEXT)] = string_to_value("context");
unregister_gc_root(&vec_root);
}
/* Slot 4: Callable object used as proxy when structure is apply'd. */
_get_struct(tmp_root.value)->slots[SS(CALLABLE)] = NIL;
unregister_gc_root(&tmp_root);
#undef TS
#define LS(x) LAMBDA_SLOT_ ## x
/* Lambda: Instances of this structure are fundamental callable objects. */
register_gc_root(&tmp_root, make_struct(ms_root.value, STRUCTURE_SLOTS));
register_builtin(BI_LAMBDA, tmp_root.value);
/* Slot 1: Name */
_get_struct(tmp_root.value)->slots[SS(NAME)] = string_to_value("lambda");
/* Slot 2: Super/parent structure type, or NIL */
_get_struct(tmp_root.value)->slots[SS(SUPER)] = NIL;
/* Slot 3: Vector of slot names; size == total number of slots */
_get_struct(tmp_root.value)->slots[SS(SLOTS)] = make_vector(LAMBDA_SLOTS, NIL);
{
gc_root_t vec_root;
register_gc_root(&vec_root, _get_struct(tmp_root.value)->slots[SS(SLOTS)]);
_get_vector(vec_root.value)->elements[LS(GLOBAL_VARS)] = string_to_value("global-vars");
_get_vector(vec_root.value)->elements[LS(INSTANCE_VARS)] = string_to_value("instance-vars");
_get_vector(vec_root.value)->elements[LS(FRAME_VARS)] = string_to_value("frame-vars");
_get_vector(vec_root.value)->elements[LS(BYTE_CODE)] = string_to_value("byte-code");
_get_vector(vec_root.value)->elements[LS(TAIL_CALL)] = string_to_value("tail-call");
_get_vector(vec_root.value)->elements[LS(ARG_LIST)] = string_to_value("argument-list");
_get_vector(vec_root.value)->elements[LS(CONTINUATION)] = string_to_value("continuation");
_get_vector(vec_root.value)->elements[LS(CONTEXT)] = string_to_value("context");
unregister_gc_root(&vec_root);
}
/* Slot 4: Callable object used as proxy when structure is apply'd. */
_get_struct(tmp_root.value)->slots[SS(CALLABLE)] = NIL;
unregister_gc_root(&tmp_root);
#undef LS
#undef SS
unregister_gc_root(&ms_root); unregister_gc_root(&ms_root);
} }
@ -146,36 +54,117 @@ value_t lookup_builtin(const char *name)
return FALSE_VALUE; return FALSE_VALUE;
} }
static value_t string_to_value(const char *s) #define SS(x) STRUCTURE_SLOT_ ## x
static void register_structure(gc_root_t *ms_root)
{ {
size_t len = strlen(s); /* (Meta-)Structure: Instances of this structure describe structures. */
value_t v = make_byte_string(len, '\0'); ms_root->value = make_struct(UNDEFINED, STRUCTURE_SLOTS);
memcpy(_get_byte_string(v)->bytes, s, len);
return v; /* Metastruct is both a structure and a structure description,
* and thus is an instance of itself. */
_get_struct(ms_root->value)->type = ms_root->value;
/* Slot 1: Name */
_get_struct(ms_root->value)->slots[SS(NAME)] = string_to_value("structure");
/* Slot 2: Super/parent structure type, or FALSE_VALUE */
_get_struct(ms_root->value)->slots[SS(SUPER)] = FALSE_VALUE;
/* Slot 3: Vector of slot names; size == total number of slots (excl. type) */
_get_struct(ms_root->value)->slots[SS(SLOTS)] = make_vector(STRUCTURE_SLOTS, UNDEFINED);
{
gc_root_t vec_root;
register_gc_root(&vec_root, _get_struct(ms_root->value)->slots[SS(SLOTS)]);
_get_vector(vec_root.value)->elements[SS(NAME)] = string_to_value("name");
_get_vector(vec_root.value)->elements[SS(SUPER)] = string_to_value("super");
_get_vector(vec_root.value)->elements[SS(SLOTS)] = string_to_value("slots");
_get_vector(vec_root.value)->elements[SS(CALLABLE)] = string_to_value("callable");
_get_vector(vec_root.value)->elements[SS(MUTABLE)] = string_to_value("mutable");
unregister_gc_root(&vec_root);
}
/* Slot 4: Callable object used as proxy when structure is APPLY'd. */
/* Can be LAMBDA, callable structure instance, or FALSE_VALUE. */
_get_struct(ms_root->value)->slots[SS(CALLABLE)] = FALSE_VALUE;
_get_struct(ms_root->value)->slots[SS(MUTABLE)] = FALSE_VALUE;
register_builtin(BI_STRUCTURE, ms_root->value);
} }
static char *value_to_string(value_t v) static void register_template(gc_root_t *ms_root)
{ {
byte_string_t *str = get_byte_string(v); gc_root_t tmp_root;
char *s = (char*)malloc(str->size + 1);
memcpy(s, str->bytes, str->size); #define TS(x) TEMPLATE_SLOT_ ## x
s[str->size] = '\0';
return s; /* Template: Instances of this structure describe what a LAMBDA
* will look like when instanciated with the 'lambda' bytecode. */
register_gc_root(&tmp_root, make_struct(ms_root->value, STRUCTURE_SLOTS));
register_builtin(BI_TEMPLATE, tmp_root.value);
/* Slot 1: Name */
_get_struct(tmp_root.value)->slots[SS(NAME)] = string_to_value("template");
/* Slot 2: Super/parent structure type, or FALSE_VALUE */
_get_struct(tmp_root.value)->slots[SS(SUPER)] = FALSE_VALUE;
/* Slot 3: Vector of slot names; size == total number of slots */
_get_struct(tmp_root.value)->slots[SS(SLOTS)] = make_vector(TEMPLATE_SLOTS, UNDEFINED);
{
gc_root_t vec_root;
register_gc_root(&vec_root, _get_struct(tmp_root.value)->slots[SS(SLOTS)]);
_get_vector(vec_root.value)->elements[TS(GLOBAL_VARS)] = string_to_value("global-vars");
_get_vector(vec_root.value)->elements[TS(INSTANCE_VARS)] = string_to_value("instance-vars");
_get_vector(vec_root.value)->elements[TS(FRAME_VARS)] = string_to_value("frame-vars");
_get_vector(vec_root.value)->elements[TS(BYTE_CODE)] = string_to_value("byte-code");
_get_vector(vec_root.value)->elements[TS(TAIL_CALL)] = string_to_value("tail-call");
_get_vector(vec_root.value)->elements[TS(ARG_LIST)] = string_to_value("argument-list");
_get_vector(vec_root.value)->elements[TS(CONTINUATION)] = string_to_value("continuation");
_get_vector(vec_root.value)->elements[TS(CONTEXT)] = string_to_value("context");
unregister_gc_root(&vec_root);
}
/* Slot 4: Callable object used as proxy when structure is apply'd. */
_get_struct(tmp_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
_get_struct(tmp_root.value)->slots[SS(MUTABLE)] = FALSE_VALUE;
unregister_gc_root(&tmp_root);
#undef TS
} }
static int byte_strcmp(value_t s1, value_t s2) static void register_lambda(gc_root_t *ms_root)
{ {
byte_string_t *str1 = get_byte_string(s1); gc_root_t tmp_root;
byte_string_t *str2 = get_byte_string(s2);
if (str1->size < str2->size) #define LS(x) LAMBDA_SLOT_ ## x
return -1;
else if (str1->size > str2->size) /* Lambda: Instances of this structure are fundamental callable objects. */
return 1; register_gc_root(&tmp_root, make_struct(ms_root->value, STRUCTURE_SLOTS));
else register_builtin(BI_LAMBDA, tmp_root.value);
return memcmp(str1->bytes, str2->bytes, str1->size);
/* Slot 1: Name */
_get_struct(tmp_root.value)->slots[SS(NAME)] = string_to_value("lambda");
/* Slot 2: Super/parent structure type, or FALSE_VALUE */
_get_struct(tmp_root.value)->slots[SS(SUPER)] = FALSE_VALUE;
/* Slot 3: Vector of slot names; size == total number of slots */
_get_struct(tmp_root.value)->slots[SS(SLOTS)] = make_vector(LAMBDA_SLOTS, UNDEFINED);
{
gc_root_t vec_root;
register_gc_root(&vec_root, _get_struct(tmp_root.value)->slots[SS(SLOTS)]);
_get_vector(vec_root.value)->elements[LS(GLOBAL_VARS)] = string_to_value("global-vars");
_get_vector(vec_root.value)->elements[LS(INSTANCE_VARS)] = string_to_value("instance-vars");
_get_vector(vec_root.value)->elements[LS(FRAME_VARS)] = string_to_value("frame-vars");
_get_vector(vec_root.value)->elements[LS(BYTE_CODE)] = string_to_value("byte-code");
_get_vector(vec_root.value)->elements[LS(TAIL_CALL)] = string_to_value("tail-call");
_get_vector(vec_root.value)->elements[LS(ARG_LIST)] = string_to_value("argument-list");
_get_vector(vec_root.value)->elements[LS(CONTINUATION)] = string_to_value("continuation");
_get_vector(vec_root.value)->elements[LS(CONTEXT)] = string_to_value("context");
unregister_gc_root(&vec_root);
}
/* Slot 4: Callable object used as proxy when structure is apply'd. */
_get_struct(tmp_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
_get_struct(tmp_root.value)->slots[SS(MUTABLE)] = FALSE_VALUE;
unregister_gc_root(&tmp_root);
#undef LS
} }
#undef SS
/* vim:set sw=2 expandtab: */ /* vim:set sw=2 expandtab: */

4
builtin.h
View File

@ -8,6 +8,7 @@
#include "gc.h" #include "gc.h"
/* Names of fundamental builtin values */ /* Names of fundamental builtin values */
#define BI_UNDEFINED "undefined"
#define BI_STRUCTURE "structure" #define BI_STRUCTURE "structure"
#define BI_TEMPLATE "template" #define BI_TEMPLATE "template"
#define BI_LAMBDA "lambda" #define BI_LAMBDA "lambda"
@ -16,7 +17,8 @@
#define STRUCTURE_SLOT_SUPER 1 #define STRUCTURE_SLOT_SUPER 1
#define STRUCTURE_SLOT_SLOTS 2 #define STRUCTURE_SLOT_SLOTS 2
#define STRUCTURE_SLOT_CALLABLE 3 #define STRUCTURE_SLOT_CALLABLE 3
#define STRUCTURE_SLOTS 4 #define STRUCTURE_SLOT_MUTABLE 4
#define STRUCTURE_SLOTS 5
#define TEMPLATE_SLOT_GLOBAL_VARS 0 #define TEMPLATE_SLOT_GLOBAL_VARS 0
#define TEMPLATE_SLOT_INSTANCE_VARS 1 #define TEMPLATE_SLOT_INSTANCE_VARS 1

297
gc.c
View File

@ -1,6 +1,7 @@
#define _POSIX_C_SOURCE 199309L #define _POSIX_C_SOURCE 199309L
#include <assert.h> #include <assert.h>
#include <ctype.h>
#include <inttypes.h> #include <inttypes.h>
#include <stdbool.h> #include <stdbool.h>
#include <stdio.h> #include <stdio.h>
@ -43,7 +44,7 @@ static value_t gc_will_list;
static value_t gc_will_active_list; static value_t gc_will_active_list;
static gc_root_t gc_root_list = { static gc_root_t gc_root_list = {
.value = NIL, .value = UNDEFINED,
.prev = &gc_root_list, .prev = &gc_root_list,
.next = &gc_root_list .next = &gc_root_list
}; };
@ -72,12 +73,22 @@ void unregister_gc_root(gc_root_t *root)
/****************************************************************************/ /****************************************************************************/
bool get_boolean(value_t v)
{
release_assert(is_boolean(v));
return (v != FALSE_VALUE);
}
fixnum_t get_fixnum(value_t v)
{
release_assert(is_fixnum(v));
return _get_fixnum(v);
}
object_t *get_object(value_t v) object_t *get_object(value_t v)
{ {
if (is_object(v)) release_assert(is_object(v));
return _get_object(v); return _get_object(v);
else
abort();
} }
/* No one outside this module should care... */ /* No one outside this module should care... */
@ -106,10 +117,8 @@ value_t cons(value_t car, value_t cdr)
pair_t *get_pair(value_t v) pair_t *get_pair(value_t v)
{ {
if (is_pair(v)) release_assert(is_pair(v));
return _get_pair(v); return _get_pair(v);
else
abort();
} }
value_t make_box(value_t initial_value) value_t make_box(value_t initial_value)
@ -130,10 +139,8 @@ value_t make_box(value_t initial_value)
box_t *get_box(value_t v) box_t *get_box(value_t v)
{ {
if (is_box(v)) release_assert(is_box(v));
return _get_box(v); return _get_box(v);
else
abort();
} }
value_t make_vector(size_t nelem, value_t initial_value) value_t make_vector(size_t nelem, value_t initial_value)
@ -157,10 +164,8 @@ value_t make_vector(size_t nelem, value_t initial_value)
vector_t *get_vector(value_t v) vector_t *get_vector(value_t v)
{ {
if (is_vector(v)) release_assert(is_vector(v));
return _get_vector(v); return _get_vector(v);
else
abort();
} }
value_t make_byte_string(size_t size, int default_value) value_t make_byte_string(size_t size, int default_value)
@ -179,10 +184,40 @@ value_t make_byte_string(size_t size, int default_value)
byte_string_t *get_byte_string(value_t v) byte_string_t *get_byte_string(value_t v)
{ {
if (is_byte_string(v)) release_assert(is_byte_string(v));
return _get_byte_string(v); return _get_byte_string(v);
}
value_t string_to_value(const char *s)
{
size_t len = strlen(s);
value_t v = make_byte_string(len, '\0');
memcpy(_get_byte_string(v)->bytes, s, len);
return v;
}
char *value_to_string(value_t v)
{
byte_string_t *str = get_byte_string(v);
char *s = (char*)malloc(str->size + 1);
memcpy(s, str->bytes, str->size);
s[str->size] = '\0';
return s;
}
int byte_strcmp(value_t s1, value_t s2)
{
byte_string_t *str1 = get_byte_string(s1);
byte_string_t *str2 = get_byte_string(s2);
if (str1->size < str2->size)
return -1;
else if (str1->size > str2->size)
return 1;
else else
abort(); return memcmp(str1->bytes, str2->bytes, str1->size);
} }
value_t make_struct(value_t type, size_t nslots) value_t make_struct(value_t type, size_t nslots)
@ -198,7 +233,7 @@ value_t make_struct(value_t type, size_t nslots)
s->nslots = nslots; s->nslots = nslots;
for (int i = 0; i < nslots; ++i) for (int i = 0; i < nslots; ++i)
s->slots[i] = NIL; s->slots[i] = UNDEFINED;
unregister_gc_root(&type_root); unregister_gc_root(&type_root);
@ -207,10 +242,8 @@ value_t make_struct(value_t type, size_t nslots)
struct_t *get_struct(value_t v) struct_t *get_struct(value_t v)
{ {
if (is_struct(v)) release_assert(is_struct(v));
return _get_struct(v); return _get_struct(v);
else
abort();
} }
value_t make_weak_box(value_t initial_value) value_t make_weak_box(value_t initial_value)
@ -233,10 +266,8 @@ value_t make_weak_box(value_t initial_value)
weak_box_t *get_weak_box(value_t v) weak_box_t *get_weak_box(value_t v)
{ {
if (is_weak_box(v)) release_assert(is_weak_box(v));
return _get_weak_box(v); return _get_weak_box(v);
else
abort();
} }
void register_finalizer(value_t value, value_t finalizer) void register_finalizer(value_t value, value_t finalizer)
@ -271,24 +302,48 @@ static inline will_t *_get_will(value_t v)
static will_t *get_will(value_t v) static will_t *get_will(value_t v)
{ {
if (is_will(v)) release_assert(is_will(v));
return _get_will(v); return _get_will(v);
else
abort();
} }
fixnum_t get_fixnum(value_t v) value_t make_float(native_float_t value)
{ {
if (is_fixnum(v)) float_object_t *obj;
return _get_fixnum(v);
else obj = (float_object_t*)gc_alloc(sizeof(float_object_t));
abort(); obj->tag = TYPE_TAG_FLOAT;
obj->value = value;
return object_value(obj);
}
native_float_t get_float(value_t v)
{
release_assert(is_float(v));
return _get_float(v);
}
value_t make_builtin_fn(builtin_fn_t *fn)
{
builtin_fn_object_t *obj;
obj = (builtin_fn_object_t*)gc_alloc(sizeof(builtin_fn_object_t));
obj->tag = TYPE_TAG_BUILTIN;
obj->fn = fn;
return object_value(obj);
}
builtin_fn_t *get_builtin_fn(value_t v)
{
release_assert(is_builtin_fn(v));
return _get_builtin_fn(v);
} }
/****************************************************************************/ /****************************************************************************/
static inline size_t gc_align(size_t nbytes) __attribute__ ((const)); static inline size_t gc_align(size_t nbytes) __attribute__ ((const));
static int gc_range_of(void *object) __attribute__ ((const)); static int gc_range_of(void *object) __attribute__ ((const,unused));
static void transfer_object(value_t *value); static void transfer_object(value_t *value);
static size_t transfer_children(object_t *object); static size_t transfer_children(object_t *object);
static void _collect_garbage(size_t min_free); static void _collect_garbage(size_t min_free);
@ -384,6 +439,9 @@ static void transfer_object(value_t *value)
switch (obj->tag) switch (obj->tag)
{ {
case TYPE_TAG_BOX:
nbytes = sizeof(box_t);
break;
case TYPE_TAG_VECTOR: case TYPE_TAG_VECTOR:
nbytes = VECTOR_BYTES(((const vector_t*)obj)->size); nbytes = VECTOR_BYTES(((const vector_t*)obj)->size);
break; break;
@ -399,8 +457,11 @@ static void transfer_object(value_t *value)
case TYPE_TAG_WILL: case TYPE_TAG_WILL:
nbytes = sizeof(will_t); nbytes = sizeof(will_t);
break; break;
case TYPE_TAG_BOX: case TYPE_TAG_FLOAT:
nbytes = sizeof(box_t); nbytes = sizeof(float_object_t);
break;
case TYPE_TAG_BUILTIN:
nbytes = sizeof(builtin_fn_object_t);
break; break;
default: /* pair */ default: /* pair */
nbytes = sizeof(pair_t); nbytes = sizeof(pair_t);
@ -438,6 +499,12 @@ static size_t transfer_struct(struct_t *s)
return STRUCT_BYTES(s->nslots); return STRUCT_BYTES(s->nslots);
} }
static size_t transfer_box(box_t *b)
{
transfer_object(&b->value);
return sizeof(box_t);
}
static size_t transfer_pair(pair_t *p) static size_t transfer_pair(pair_t *p)
{ {
transfer_object(&p->car); transfer_object(&p->car);
@ -462,6 +529,8 @@ static size_t transfer_children(object_t *obj)
{ {
switch (obj->tag) switch (obj->tag)
{ {
case TYPE_TAG_BOX:
return transfer_box((box_t*)obj);
case TYPE_TAG_VECTOR: case TYPE_TAG_VECTOR:
return transfer_vector((vector_t*)obj); return transfer_vector((vector_t*)obj);
case TYPE_TAG_BYTESTR: case TYPE_TAG_BYTESTR:
@ -472,7 +541,10 @@ static size_t transfer_children(object_t *obj)
return sizeof(weak_box_t); return sizeof(weak_box_t);
case TYPE_TAG_WILL: case TYPE_TAG_WILL:
return transfer_will((will_t*)obj); return transfer_will((will_t*)obj);
case TYPE_TAG_BOX: case TYPE_TAG_FLOAT:
return sizeof(float_object_t);
case TYPE_TAG_BUILTIN:
return sizeof(builtin_fn_object_t);
default: /* pair */ default: /* pair */
return transfer_pair((pair_t*)obj); return transfer_pair((pair_t*)obj);
} }
@ -776,4 +848,145 @@ void get_next_finalizer(value_t *value, value_t *finalizer)
} }
} }
void _release_assert(bool expr, const char *str, const char *file, int line)
{
if (!expr)
{
fprintf(stderr, "ERROR: Invalid state detected in %s, line %d.\n"
"Assertion failed: %s\n",
file, line, str);
abort();
}
}
void fprint_value(FILE *f, value_t v)
{
if (v == NIL)
{
fputs("nil", f);
}
else if (v == FALSE_VALUE)
{
fputs("#f", f);
}
else if (v == TRUE_VALUE)
{
fputs("#t", f);
}
else if (v == UNDEFINED)
{
fputs("#<undefined>", f);
}
else if (is_fixnum(v))
{
fprintf(f, "%d", (int)get_fixnum(v));
}
else if (is_box(v))
{
fputs("#&", f);
fprint_value(f, _get_box(v)->value);
}
else if (is_pair(v))
{
fputc('(', f);
fprint_value(f, _get_pair(v)->car);
v = _get_pair(v)->cdr;
while (is_pair(v))
{
fputc(' ', f);
fprint_value(f, _get_pair(v)->car);
v = _get_pair(v)->cdr;
}
if (v != NIL)
{
fputs(" . ", f);
fprint_value(f, v);
}
fputc(')', f);
}
else if (is_vector(v))
{
fputs("#(", f);
for (size_t i = 0; i < _get_vector(v)->size; ++i)
{
if (i != 0) fputc(' ', f);
fprint_value(f, _get_vector(v)->elements[i]);
}
fputc(')', f);
}
else if (is_byte_string(v))
{
byte_string_t *str = _get_byte_string(v);
fputc('"', f);
for (size_t i = 0; i < str->size; ++i)
{
int ch = str->bytes[i];
if (isprint(ch) && (ch != '\\') && (ch != '\"'))
fputc(str->bytes[i], f);
else
fprintf(f, "\\x%.2X", (int)str->bytes[i]);
}
fputc('"', f);
}
else if (is_struct(v))
{
struct_t *meta = get_struct(_get_struct(v)->type);
byte_string_t *str = get_byte_string(meta->slots[0]);
fputs("#S(", f);
fwrite(str->bytes, str->size, 1, f);
for (size_t i = 0; i < _get_struct(v)->nslots; ++i)
{
fputc(' ', f);
fprint_value(f, _get_struct(v)->slots[i]);
}
fputc(')', f);
}
else if (is_weak_box(v))
{
fputs("#W&", f);
fprint_value(f, _get_weak_box(v)->value);
}
else if (is_float(v))
{
fprintf(f, "%f", (double)_get_float(v));
}
else if (is_builtin_fn(v))
{
fputs("#<builtin>", f);
}
else
{
fputs("#<unknown>", f);
}
}
void fprint_gc_stats(FILE *f)
{
const double total_time = gc_stats.total_ns / 1.0e9;
const double max_time = gc_stats.max_ns / 1.0e9;
fprintf(f, "%lld bytes freed in %0.6f sec => %0.3f MB/sec. (%d GCs.)\n",
gc_stats.total_freed,
total_time,
(gc_stats.total_freed / total_time) / (1024*1024),
gc_stats.collections);
fprintf(f, "Max GC time was %0.6f sec, avg. %0.6f sec; peak heap size was %d bytes.\n",
max_time, (total_time / gc_stats.collections), gc_stats.high_water);
}
/* vim:set sw=2 expandtab: */ /* vim:set sw=2 expandtab: */

130
gc.h
View File

@ -13,8 +13,34 @@
# define debug(printf_args) ((void)0) # define debug(printf_args) ((void)0)
#endif #endif
/* Like assert(), but for things we want to check even in release builds. */
/* More informative than a simple "if (!x) abort();" statement. */
#define release_assert(expr) ((void)_release_assert((expr), #expr, __FILE__, __LINE__))
/* Evaluates to false, but with an expression that conveys what went wrong. */
#define NOTREACHED(msg) 0
typedef uintptr_t value_t; typedef uintptr_t value_t;
typedef intptr_t fixnum_t; typedef intptr_t fixnum_t;
typedef double native_float_t;
#if INTPTR_MAX - 0 == 0
/* The INTPTR_ macros are defined, but not given values. */
# undef INTPTR_MIN
# undef INTPTR_MAX
# define INTPTR_MIN INT32_MIN
# define INTPTR_MAX INT32_MAX
#endif
#define FIXNUM_MIN (INTPTR_MIN/2)
#define FIXNUM_MAX (INTPTR_MAX/2)
/* Builtins replace the normal run_byte_code() and perform_tail_call() steps.
* The argv, k, and ctx inputs can be found in the state fields, and should be
* updated as necessary (particularly argv) before the builtin returns. The
* 'lambda' field will refer to the builtin itself, and in1-in3 are all free. */
struct interp_state;
typedef void (builtin_fn_t)(struct interp_state *state);
/* NIL: 00000000 00000000 00000000 00000000 */ /* NIL: 00000000 00000000 00000000 00000000 */
/* Object: aaaaaaaa aaaaaaaa aaaaaaaa aaaaaa00 (where aa... >= 1024) */ /* Object: aaaaaaaa aaaaaaaa aaaaaaaa aaaaaa00 (where aa... >= 1024) */
@ -40,6 +66,8 @@ typedef intptr_t fixnum_t;
#define TYPE_TAG_STRUCT TYPE_TAG(3) #define TYPE_TAG_STRUCT TYPE_TAG(3)
#define TYPE_TAG_WEAK_BOX TYPE_TAG(4) #define TYPE_TAG_WEAK_BOX TYPE_TAG(4)
#define TYPE_TAG_WILL TYPE_TAG(5) #define TYPE_TAG_WILL TYPE_TAG(5)
#define TYPE_TAG_FLOAT TYPE_TAG(6)
#define TYPE_TAG_BUILTIN TYPE_TAG(7)
#define CAR(x) (get_pair(x)->car) #define CAR(x) (get_pair(x)->car)
#define CDR(x) (get_pair(x)->cdr) #define CDR(x) (get_pair(x)->cdr)
@ -108,6 +136,18 @@ typedef struct will
value_t next; value_t next;
} will_t; } will_t;
typedef struct float_object
{
value_t tag;
native_float_t value;
} float_object_t;
typedef struct builtin_fn_object
{
value_t tag;
builtin_fn_t *fn;
} builtin_fn_object_t;
typedef struct gc_root typedef struct gc_root
{ {
value_t value; value_t value;
@ -130,6 +170,11 @@ typedef struct gc_stats
extern gc_stats_t gc_stats; extern gc_stats_t gc_stats;
/* Must be #t or #f; for generalized booleans use _get_boolean(). */
bool get_boolean(value_t v);
fixnum_t get_fixnum(value_t v);
object_t *get_object(value_t v); object_t *get_object(value_t v);
pair_t *get_pair(value_t pair); pair_t *get_pair(value_t pair);
@ -144,6 +189,15 @@ vector_t *get_vector(value_t v);
value_t make_byte_string(size_t size, int default_value); value_t make_byte_string(size_t size, int default_value);
byte_string_t *get_byte_string(value_t v); byte_string_t *get_byte_string(value_t v);
/* Returns a byte string w/ bytes from 's' (excl. terminating NUL). */
value_t string_to_value(const char *s);
/* Return a new C string which must be free()'d by caller. */
char *value_to_string(value_t v);
/* Like strcmp(), but for byte strings. */
int byte_strcmp(value_t s1, value_t s2);
value_t make_struct(value_t type, size_t nslots); value_t make_struct(value_t type, size_t nslots);
struct_t *get_struct(value_t v); struct_t *get_struct(value_t v);
@ -157,7 +211,11 @@ bool are_finalizers_pending(void);
/* If *value == #f on return there are no more finalizers. */ /* If *value == #f on return there are no more finalizers. */
void get_next_finalizer(value_t *value, value_t *finalizer); void get_next_finalizer(value_t *value, value_t *finalizer);
fixnum_t get_fixnum(value_t v); value_t make_float(native_float_t value);
native_float_t get_float(value_t v);
value_t make_builtin_fn(builtin_fn_t *fn);
builtin_fn_t *get_builtin_fn(value_t v);
/****************************************************************************/ /****************************************************************************/
@ -166,14 +224,9 @@ static inline bool is_nil(value_t v)
return v == NIL; return v == NIL;
} }
static inline bool is_false(value_t v) static inline value_t boolean_value(bool b)
{ {
return v == FALSE_VALUE; return b ? TRUE_VALUE : FALSE_VALUE;
}
static inline bool is_true(value_t v)
{
return v != FALSE_VALUE;
} }
static inline bool is_boolean(value_t v) static inline bool is_boolean(value_t v)
@ -181,9 +234,24 @@ static inline bool is_boolean(value_t v)
return (v == FALSE_VALUE) || (v == TRUE_VALUE); return (v == FALSE_VALUE) || (v == TRUE_VALUE);
} }
static inline value_t make_boolean(bool b) static inline bool _get_boolean(value_t v)
{ {
return b ? TRUE_VALUE : FALSE_VALUE; return v != FALSE_VALUE;
}
static inline value_t fixnum_value(fixnum_t n)
{
return (value_t)(n << 1) | 1;
}
static inline bool is_fixnum(value_t v)
{
return (v & 1) != 0;
}
static inline fixnum_t _get_fixnum(value_t n)
{
return ((fixnum_t)n) >> 1;
} }
static inline value_t object_value(void *obj) static inline value_t object_value(void *obj)
@ -247,11 +315,6 @@ static inline vector_t *_get_vector(value_t v)
return (vector_t*)_get_object(v); return (vector_t*)_get_object(v);
} }
static inline size_t vector_size(value_t v)
{
return get_vector(v)->size;
}
static inline bool is_byte_string(value_t v) static inline bool is_byte_string(value_t v)
{ {
return is_object(v) && (_get_object(v)->tag == TYPE_TAG_BYTESTR); return is_object(v) && (_get_object(v)->tag == TYPE_TAG_BYTESTR);
@ -262,11 +325,6 @@ static inline byte_string_t *_get_byte_string(value_t v)
return (byte_string_t*)_get_object(v); return (byte_string_t*)_get_object(v);
} }
static inline size_t byte_string_size(value_t v)
{
return get_byte_string(v)->size;
}
static inline bool is_struct(value_t v) static inline bool is_struct(value_t v)
{ {
return is_object(v) && (_get_object(v)->tag == TYPE_TAG_STRUCT); return is_object(v) && (_get_object(v)->tag == TYPE_TAG_STRUCT);
@ -292,19 +350,24 @@ static inline bool is_will(value_t v)
return is_object(v) && (_get_object(v)->tag == TYPE_TAG_WILL); return is_object(v) && (_get_object(v)->tag == TYPE_TAG_WILL);
} }
static inline bool is_fixnum(value_t v) static inline bool is_float(value_t v)
{ {
return (v & 1) != 0; return is_object(v) && (_get_object(v)->tag == TYPE_TAG_FLOAT);
} }
static inline value_t make_fixnum(fixnum_t n) static inline native_float_t _get_float(value_t v)
{ {
return (value_t)(n << 1) | 1; return ((float_object_t*)_get_object(v))->value;
} }
static inline fixnum_t _get_fixnum(value_t n) static inline bool is_builtin_fn(value_t v)
{ {
return ((fixnum_t)n) >> 1; return is_object(v) && (_get_object(v)->tag == TYPE_TAG_BUILTIN);
}
static inline builtin_fn_t *_get_builtin_fn(value_t v)
{
return ((builtin_fn_object_t*)_get_object(v))->fn;
} }
void gc_init(size_t min_size, size_t max_size); void gc_init(size_t min_size, size_t max_size);
@ -314,6 +377,21 @@ void *gc_alloc(size_t nbytes);
void collect_garbage(size_t min_free); void collect_garbage(size_t min_free);
bool set_gc_enabled(bool enable); bool set_gc_enabled(bool enable);
void fprint_value(FILE *f, value_t v);
void fprint_gc_stats(FILE *f);
static inline void print_value(value_t v)
{
fprint_value(stdout, v);
}
static inline void print_gc_stats(void)
{
fprint_gc_stats(stderr);
}
void _release_assert(bool expr, const char *str, const char *file, int line);
/* To be provided by the main application */ /* To be provided by the main application */
void out_of_memory(void) __attribute__ ((noreturn)); void out_of_memory(void) __attribute__ ((noreturn));

548
reader.c Normal file
View File

@ -0,0 +1,548 @@
#include <ctype.h>
#include <inttypes.h>
#include <stdbool.h>
#include <stdlib.h>
#include <string.h>
#include "gc.h"
#include "builtin.h"
typedef struct reader_state
{
FILE *file;
char ch;
gc_root_t ref_alist;
gc_root_t weak_list;
gc_root_t ref_list;
} reader_state_t;
static value_t read_one_value(reader_state_t *state);
static value_t read_special(reader_state_t *state);
static value_t read_list(reader_state_t *state);
static value_t read_number(reader_state_t *state);
static value_t read_string(reader_state_t *state);
static value_t read_box(reader_state_t *state);
static value_t read_vector(reader_state_t *state);
static value_t read_struct(reader_state_t *state);
static value_t read_weak_box(reader_state_t *state);
static value_t read_definition(reader_state_t *state);
static value_t read_backref(reader_state_t *state);
static void next_char(reader_state_t *state);
static value_t make_placeholder(reader_state_t *state, fixnum_t ref);
static value_t get_placeholder(reader_state_t *state, fixnum_t ref);
static value_t patch_placeholders(reader_state_t *state, value_t v);
static void set_placeholder(value_t place, value_t value);
static void tree_replace(value_t *in, value_t oldval, value_t newval);
value_t read_value(FILE *f)
{
reader_state_t state;
value_t result;
register_gc_root(&state.ref_alist, NIL);
register_gc_root(&state.weak_list, NIL);
register_gc_root(&state.ref_list, NIL);
state.file = f;
next_char(&state);
result = read_one_value(&state);
ungetc(state.ch, f);
result = patch_placeholders(&state, result);
unregister_gc_root(&state.ref_list);
unregister_gc_root(&state.weak_list);
unregister_gc_root(&state.ref_alist);
return result;
}
static value_t read_one_value(reader_state_t *state)
{
while (isspace(state->ch))
next_char(state);
release_assert(state->ch != EOF);
switch (state->ch)
{
case '#':
return read_special(state);
case '(':
return read_list(state);
case '0' ... '9':
return read_number(state);
case '\"':
return read_string(state);
default:
release_assert(NOTREACHED("Unexpected character in input."));
return UNDEFINED;
}
}
bool issymbol(int ch)
{
switch (ch)
{
case 'A' ... 'Z':
case 'a' ... 'z':
case '0' ... '9':
case '!': case '$': case '%':
case '&': case '*': case '+':
case '-': case '/': case '<':
case '=': case '>': case '?':
case '@': case '\\': case '^':
case '_': case '|': case '~':
return true;
default:
return false;
}
}
static value_t read_special(reader_state_t *state)
{
next_char(state);
release_assert(state->ch != EOF);
switch (state->ch)
{
case 'F':
case 'f':
next_char(state);
release_assert(!issymbol(state->ch));
return FALSE_VALUE;
case 'T':
case 't':
next_char(state);
release_assert(!issymbol(state->ch));
return TRUE_VALUE;
case '&':
return read_box(state);
case '(':
return read_vector(state);
case 'S':
case 's':
next_char(state);
release_assert(state->ch == '(');
return read_struct(state);
case 'W':
case 'w':
next_char(state);
release_assert(state->ch == '&');
return read_weak_box(state);
case '0' ... '9':
return read_definition(state);
case '=':
return read_backref(state);
default:
release_assert(NOTREACHED("Invalid character in special value."));
return UNDEFINED;
}
}
static void reverse_list(value_t *list, value_t newcdr)
{
value_t lst = *list;
while (is_pair(lst))
{
value_t temp = _get_pair(lst)->cdr;
_get_pair(lst)->cdr = newcdr;
newcdr = lst;
lst = temp;
}
*list = newcdr;
}
static value_t read_list(reader_state_t *state)
{
gc_root_t list_root;
bool done = false;
register_gc_root(&list_root, NIL);
next_char(state);
while (!done)
{
while (isspace(state->ch))
next_char(state);
release_assert(state->ch != EOF);
switch (state->ch)
{
case '.':
{
release_assert(!is_nil(list_root.value));
next_char(state);
value_t temp = read_one_value(state);
reverse_list(&list_root.value, temp);
while (isspace(state->ch))
next_char(state);
release_assert(state->ch == ')');
next_char(state);
done = true;
}
break;
case ')':
{
reverse_list(&list_root.value, NIL);
next_char(state);
done = true;
}
break;
default:
{
value_t temp;
list_root.value = cons(UNDEFINED, list_root.value);
temp = read_one_value(state);
_CAR(list_root.value) = temp;
}
break;
}
}
unregister_gc_root(&list_root);
return list_root.value;
}
static value_t read_number(reader_state_t *state)
{
fixnum_t num = 0;
while (isdigit(state->ch))
{
release_assert(num <= (FIXNUM_MAX/10));
num *= 10;
num += (state->ch - '0');
next_char(state);
}
return fixnum_value(num);
}
static value_t read_string(reader_state_t *state)
{
char *buffer = (char*)malloc(128);
size_t buffer_size = 128;
size_t length = 0;
value_t value;
release_assert(buffer != NULL);
next_char(state);
while (state->ch != '"')
{
bool skip_whitespace = false;
char ch;
if ((buffer_size - length) < 2)
{
release_assert(buffer_size <= INT32_MAX / 3);
buffer_size = (3 * buffer_size) / 2;
buffer = realloc(buffer, buffer_size);
release_assert(buffer != NULL);
}
ch = state->ch;
next_char(state);
if (ch == '\\')
{
switch (state->ch)
{
case 'o':
next_char(state);
release_assert(('0' <= state->ch) && (state->ch <= '7'));
/* fall through */
case '0' ... '7':
ch = 0;
/* One to three octal digits */
for (int i = 0; i < 3; ++i)
{
ch = 8 * ch + (state->ch - '0');
next_char(state);
if ((state->ch < '0') || (state->ch > '7'))
break;
}
break;
case 'X':
case 'x':
ch = 0;
next_char(state);
release_assert(isxdigit(state->ch));
/* One or two hex digits */
for (int i = 0; i < 2; ++i)
{
int n = isdigit(state->ch)
? (state->ch - '0')
: (10 + toupper(state->ch) - 'A');
ch = 16 * ch + n;
next_char(state);
if (!isxdigit(state->ch))
break;
}
break;
case ' ':
case '\t':
case '\v':
case '\n':
skip_whitespace = true;
break;
case '\\': ch = '\\'; next_char(state); break;
case '\'': ch = '\''; next_char(state); break;
case '\"': ch = '\"'; next_char(state); break;
case 'a': ch = '\a'; next_char(state); break;
case 'b': ch = '\b'; next_char(state); break;
case 'f': ch = '\f'; next_char(state); break;
case 'n': ch = '\n'; next_char(state); break;
case 'r': ch = '\r'; next_char(state); break;
case 't': ch = '\t'; next_char(state); break;
case 'v': ch = '\v'; next_char(state); break;
default:
release_assert(NOTREACHED("Invalid escape sequence in string."));
ch = '#';
next_char(state);
break;
}
}
if (skip_whitespace)
{
do {
next_char(state);
} while (isspace(state->ch) && (state->ch != '\n'));
}
else
{
buffer[length++] = ch;
}
}
next_char(state);
buffer[length] = '\0';
value = make_byte_string(length, '\0');
memcpy(_get_byte_string(value)->bytes, buffer, length);
free(buffer);
return value;
}
static value_t read_box(reader_state_t *state)
{
gc_root_t root;
value_t v;
next_char(state);
register_gc_root(&root, make_box(UNDEFINED));
v = read_one_value(state);
_get_box(root.value)->value = v;
unregister_gc_root(&root);
return root.value;
}
static value_t read_vector(reader_state_t *state)
{
gc_root_t list_root;
gc_root_t vec_root;
size_t length = 0;
value_t v;
register_gc_root(&list_root, read_list(state));
for (value_t v = list_root.value; !is_nil(v); v = CDR(v))
++length;
register_gc_root(&vec_root, make_vector(length, UNDEFINED));
v = list_root.value;
for (size_t i = 0; i < length; ++i, v = _CDR(v))
_get_vector(vec_root.value)->elements[i] = _CAR(v);
unregister_gc_root(&list_root);
unregister_gc_root(&vec_root);
return vec_root.value;
}
static value_t read_struct(reader_state_t *state)
{
gc_root_t list_root;
gc_root_t struct_root;
size_t slots = 0;
value_t v;
register_gc_root(&list_root, read_list(state));
for (value_t v = CDR(list_root.value); !is_nil(v); v = CDR(v))
++slots;
register_gc_root(&struct_root, make_struct(_CAR(list_root.value), slots));
v = _CDR(list_root.value);
for (size_t i = 0; i < slots; ++i, v = _CDR(v))
_get_struct(struct_root.value)->slots[i] = _CAR(v);
unregister_gc_root(&list_root);
unregister_gc_root(&struct_root);
return struct_root.value;
}
static value_t read_weak_box(reader_state_t *state)
{
gc_root_t box_root;
gc_root_t value_root;
next_char(state);
register_gc_root(&box_root, make_weak_box(UNDEFINED));
register_gc_root(&value_root, read_one_value(state));
_get_weak_box(box_root.value)->value = value_root.value;
state->weak_list.value = cons(value_root.value, state->weak_list.value);
unregister_gc_root(&box_root);
unregister_gc_root(&value_root);
return box_root.value;
}
static value_t read_definition(reader_state_t *state)
{
fixnum_t ref = get_fixnum(read_number(state));
gc_root_t place_root;
value_t v;
release_assert(state->ch == '=');
next_char(state);
register_gc_root(&place_root, make_placeholder(state, ref));
v = read_one_value(state);
set_placeholder(place_root.value, v);
unregister_gc_root(&place_root);
return v;
}
static value_t read_backref(reader_state_t *state)
{
next_char(state);
release_assert(state->ch != EOF);
if (state->ch == '"')
{
char *name = value_to_string(read_string(state));
value_t bi = lookup_builtin(name);
free(name);
return bi;
}
else
{
return get_placeholder(state, get_fixnum(read_number(state)));
}
}
static value_t make_placeholder(reader_state_t *state, fixnum_t ref)
{
state->ref_alist.value = cons(UNDEFINED, state->ref_alist.value);
state->ref_alist.value = cons(fixnum_value(ref), state->ref_alist.value);
return state->ref_alist.value;
}
static value_t get_placeholder(reader_state_t *state, fixnum_t ref)
{
value_t refval = fixnum_value(ref);
value_t item = state->ref_alist.value;
while (!is_nil(item))
{
if (_CAR(item) == refval)
return item;
else
item = _CDDR(item);
}
release_assert(NOTREACHED("Back-reference without definition!"));
return UNDEFINED;
}
static value_t patch_placeholders(reader_state_t *state, value_t v)
{
value_t item = state->ref_alist.value;
while (!is_nil(item))
{
tree_replace(&v, item, _CADR(item));
item = _CDDR(item);
}
return v;
}
static void set_placeholder(value_t place, value_t value)
{
CAR(CDR(place)) = value;
}
static void tree_replace(value_t *in, value_t oldval, value_t newval)
{
if (*in == oldval)
{
*in = newval;
}
else if (is_box(*in))
{
tree_replace(&_get_box(*in)->value, oldval, newval);
}
else if (is_pair(*in))
{
tree_replace(&_get_pair(*in)->car, oldval, newval);
tree_replace(&_get_pair(*in)->cdr, oldval, newval);
}
else if (is_vector(*in))
{
for (size_t i = 0; i < _get_vector(*in)->size; ++i)
{
tree_replace(&_get_vector(*in)->elements[i], oldval, newval);
}
}
else if (is_struct(*in))
{
tree_replace(&_get_struct(*in)->type, oldval, newval);
for (size_t i = 0; i < _get_struct(*in)->nslots; ++i)
tree_replace(&_get_struct(*in)->slots[i], oldval, newval);
}
else if (is_weak_box(*in))
{
tree_replace(&_get_weak_box(*in)->value, oldval, newval);
}
}
static void next_char(reader_state_t *state)
{
state->ch = fgetc(state->file);
}
/* vim:set sw=2 expandtab: */

9
reader.h Normal file
View File

@ -0,0 +1,9 @@
#ifndef READER_H_bc8f9bf546e3914a72851703b38326d2
#define READER_H_bc8f9bf546e3914a72851703b38326d2
#include "gc.h"
value_t read_value(FILE *f);
#endif
/* vim:set sw=2 expandtab: */

165
rosella.c
View File

@ -1,6 +1,5 @@
#include <sys/time.h> #include <sys/time.h>
#include <ctype.h>
#include <inttypes.h> #include <inttypes.h>
#include <stdbool.h> #include <stdbool.h>
#include <stdio.h> #include <stdio.h>
@ -11,12 +10,12 @@
#include "gc.h" #include "gc.h"
#include "builtin.h" #include "builtin.h"
#include "interp.h" #include "interp.h"
#include "reader.h"
static void test_builtins(void); static void test_builtins(void);
static void test_weak_boxes_and_wills(void); static void test_weak_boxes_and_wills(void);
static void test_garbage_collection(bool keep_going); static void test_garbage_collection(bool keep_going);
static void print_value(value_t v); static void test_reader(void);
static void print_gc_stats(void);
static inline void comma(void) { fputs(", ", stdout); } static inline void comma(void) { fputs(", ", stdout); }
static inline void nl(void) { putchar('\n'); } static inline void nl(void) { putchar('\n'); }
@ -39,6 +38,7 @@ int main(int argc, char **argv)
test_builtins(); test_builtins();
test_weak_boxes_and_wills(); test_weak_boxes_and_wills();
test_reader();
test_garbage_collection(argc > 1); test_garbage_collection(argc > 1);
return 0; return 0;
@ -63,19 +63,19 @@ static void test_weak_boxes_and_wills(void)
{ {
gc_root_t box_root, tmp_root; gc_root_t box_root, tmp_root;
register_gc_root(&box_root, NIL); register_gc_root(&box_root, UNDEFINED);
register_gc_root(&tmp_root, NIL); register_gc_root(&tmp_root, UNDEFINED);
tmp_root.value = cons(make_fixnum(1), cons(make_fixnum(2), NIL)); tmp_root.value = cons(fixnum_value(1), cons(fixnum_value(2), NIL));
box_root.value = make_weak_box(tmp_root.value); box_root.value = make_weak_box(tmp_root.value);
register_finalizer(tmp_root.value, make_fixnum(10)); register_finalizer(tmp_root.value, fixnum_value(10));
print_weak_box_results(box_root.value); print_weak_box_results(box_root.value);
collect_garbage(0); collect_garbage(0);
print_weak_box_results(box_root.value); print_weak_box_results(box_root.value);
tmp_root.value = NIL; tmp_root.value = UNDEFINED;
print_weak_box_results(box_root.value); print_weak_box_results(box_root.value);
collect_garbage(0); collect_garbage(0);
@ -83,6 +83,7 @@ static void test_weak_boxes_and_wills(void)
collect_garbage(0); collect_garbage(0);
print_weak_box_results(box_root.value); print_weak_box_results(box_root.value);
nl();
unregister_gc_root(&box_root); unregister_gc_root(&box_root);
unregister_gc_root(&tmp_root); unregister_gc_root(&tmp_root);
@ -100,13 +101,13 @@ static void test_garbage_collection(bool keep_going)
int r = rand() & 0xffff; int r = rand() & 0xffff;
if (r == 0) if (r == 0)
root.value = make_fixnum(rand()); root.value = fixnum_value(rand());
else else
{ {
switch (r & 7) switch (r & 7)
{ {
case 0: case 0:
root.value = cons(make_fixnum(rand()), root.value); root.value = cons(fixnum_value(rand()), root.value);
break; break;
case 1: case 1:
root.value = cons(root.value, make_byte_string(256, '\0')); root.value = cons(root.value, make_byte_string(256, '\0'));
@ -115,7 +116,7 @@ static void test_garbage_collection(bool keep_going)
root.value = make_box(root.value); root.value = make_box(root.value);
break; break;
case 3: case 3:
root.value = cons(root.value, cons(make_fixnum(-1), NIL)); root.value = cons(root.value, cons(fixnum_value(-1), NIL));
get_pair(get_pair(root.value)->cdr)->cdr = root.value; get_pair(get_pair(root.value)->cdr)->cdr = root.value;
break; break;
case 4: case 4:
@ -123,8 +124,8 @@ static void test_garbage_collection(bool keep_going)
case 6: case 6:
case 7: case 7:
{ {
value_t s = make_struct(NIL, 4); value_t s = make_vector(4, FALSE_VALUE);
_get_struct(s)->slots[r & 3] = root.value; _get_vector(s)->elements[r & 3] = root.value;
root.value = s; root.value = s;
} }
break; break;
@ -151,140 +152,14 @@ static void test_garbage_collection(bool keep_going)
unregister_gc_root(&root); unregister_gc_root(&root);
} }
static bool all_print(const char *s, size_t len) static void test_reader(void)
{ {
for (size_t i = 0; i < len; ++i) value_t v;
{
if (s[i] == '"' || !isprint(s[i]))
return false;
}
return true;
}
static void print_value(value_t v) do {
{ v = read_value(stdin);
if (v == NIL) print_value(v); nl(); nl();
{ } while (v != NIL);
fputs("nil", stdout);
}
else if (v == FALSE_VALUE)
{
fputs("#f", stdout);
}
else if (v == TRUE_VALUE)
{
fputs("#t", stdout);
}
else if (v == UNDEFINED)
{
fputs("#<undefined>", stdout);
}
else if (is_fixnum(v))
{
printf("%d", (int)get_fixnum(v));
}
else if (is_box(v))
{
fputs("#&", stdout);
print_value(_get_box(v)->value);
}
else if (is_pair(v))
{
putchar('(');
print_value(_get_pair(v)->car);
v = _get_pair(v)->cdr;
while (is_pair(v))
{
putchar(' ');
print_value(_get_pair(v)->car);
v = _get_pair(v)->cdr;
}
if (v != NIL)
{
fputs(" . ", stdout);
print_value(v);
}
putchar(')');
}
else if (is_vector(v))
{
fputs("#(", stdout);
for (size_t i = 0; i < _get_vector(v)->size; ++i)
{
if (i != 0) putchar(' ');
print_value(_get_vector(v)->elements[i]);
}
putchar(')');
}
else if (is_byte_string(v))
{
byte_string_t *str = _get_byte_string(v);
if (all_print(str->bytes, str->size))
{
putchar('"');
fwrite(str->bytes, str->size, 1, stdout);
putchar('"');
}
else
{
fputs("#B(", stdout);
for (size_t i = 0; i < str->size; ++i)
{
if (i != 0) putchar(' ');
printf("%d", (int)str->bytes[i]);
}
putchar(')');
}
}
else if (is_struct(v))
{
struct_t *meta = get_struct(_get_struct(v)->type);
byte_string_t *str = get_byte_string(meta->slots[0]);
fputs("#S(", stdout);
fwrite(str->bytes, str->size, 1, stdout);
for (size_t i = 0; i < _get_struct(v)->nslots; ++i)
{
putchar(' ');
print_value(_get_struct(v)->slots[i]);
}
putchar(')');
}
else if (is_weak_box(v))
{
fputs("#W&", stdout);
print_value(_get_weak_box(v)->value);
}
else
{
fputs("#<unknown>", stdout);
}
}
static void print_gc_stats(void)
{
const double total_time = gc_stats.total_ns / 1.0e9;
const double max_time = gc_stats.max_ns / 1.0e9;
fprintf(stderr, "%lld bytes freed in %0.6f sec => %0.3f MB/sec. (%d GCs.)\n",
gc_stats.total_freed,
total_time,
(gc_stats.total_freed / total_time) / (1024*1024),
gc_stats.collections);
fprintf(stderr, "Max GC time was %0.6f sec, avg. %0.6f sec; peak heap size was %d bytes.\n",
max_time, (total_time / gc_stats.collections), gc_stats.high_water);
} }
/* vim:set sw=2 expandtab: */ /* vim:set sw=2 expandtab: */