274 lines
9.4 KiB
C
274 lines
9.4 KiB
C
#include <assert.h>
|
|
#include <inttypes.h>
|
|
#include <stdbool.h>
|
|
#include <stdlib.h>
|
|
#include <math.h>
|
|
|
|
#include "gc.h"
|
|
#include "builtin.h"
|
|
#include "interp.h"
|
|
|
|
static gc_root_t builtin_list;
|
|
static gc_root_t structure_type_root;
|
|
|
|
static void register_structure(void);
|
|
static void register_template(void);
|
|
static void register_lambda(void);
|
|
|
|
static void bi_string_to_number(interp_state_t *state);
|
|
|
|
void builtin_init(void)
|
|
{
|
|
register_gc_root(&builtin_list, NIL);
|
|
register_gc_root(&structure_type_root, UNDEFINED);
|
|
|
|
register_builtin(BI_UNDEFINED, UNDEFINED);
|
|
register_builtin(BI_STRING_TO_NUMBER, make_builtin_fn(bi_string_to_number));
|
|
|
|
#ifdef NAN
|
|
register_builtin(BI_POS_NAN, make_float(NAN));
|
|
register_builtin(BI_NEG_NAN, make_float(-NAN));
|
|
#endif
|
|
|
|
#ifdef INFINITY
|
|
register_builtin(BI_POS_INFINITY, make_float(INFINITY));
|
|
register_builtin(BI_NEG_INFINITY, make_float(-INFINITY));
|
|
#endif
|
|
|
|
register_structure();
|
|
register_template();
|
|
register_lambda();
|
|
}
|
|
|
|
void register_builtin(const char *name, value_t value)
|
|
{
|
|
gc_root_t name_root;
|
|
|
|
register_gc_root(&name_root, string_to_value(name));
|
|
builtin_list.value = cons(value, builtin_list.value);
|
|
builtin_list.value = cons(name_root.value, builtin_list.value);
|
|
unregister_gc_root(&name_root);
|
|
}
|
|
|
|
value_t lookup_builtin(const char *name)
|
|
{
|
|
value_t name_val = string_to_value(name);
|
|
|
|
for (value_t list = builtin_list.value; !is_nil(list);
|
|
list = _CDDR(list))
|
|
{
|
|
if (byte_strcmp(_CAR(list), name_val) == 0)
|
|
{
|
|
return _CADR(list);
|
|
}
|
|
}
|
|
|
|
return FALSE_VALUE;
|
|
}
|
|
|
|
#define SS(x) STRUCTURE_SLOT_ ## x
|
|
|
|
static void register_structure(void)
|
|
{
|
|
/* (Meta-)Structure: Instances of this structure describe structures. */
|
|
structure_type_root.value = make_struct(UNDEFINED, STRUCTURE_SLOTS);
|
|
|
|
/* Metastruct is both a structure and a structure description,
|
|
* and thus is an instance of itself. */
|
|
_get_struct(structure_type_root.value)->type = structure_type_root.value;
|
|
/* Slot 1: Name */
|
|
_get_struct(structure_type_root.value)->slots[SS(NAME)] = string_to_value("structure");
|
|
WRITE_BARRIER(structure_type_root.value);
|
|
/* Slot 2: List of superclasses, most to least specific */
|
|
_get_struct(structure_type_root.value)->slots[SS(SUPERS)] = NIL;
|
|
/* Slot 3: Vector of slot names; size == total number of slots (excl. type) */
|
|
_get_struct(structure_type_root.value)->slots[SS(SLOTS)] = make_vector(STRUCTURE_SLOTS, UNDEFINED);
|
|
WRITE_BARRIER(structure_type_root.value);
|
|
{
|
|
gc_root_t vec_root;
|
|
register_gc_root(&vec_root, _get_struct(structure_type_root.value)->slots[SS(SLOTS)]);
|
|
_get_vector(vec_root.value)->elements[SS(NAME)] = string_to_value("name");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[SS(SUPERS)] = string_to_value("supers");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[SS(SLOTS)] = string_to_value("slots");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[SS(CALLABLE)] = string_to_value("callable");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[SS(MUTABLE)] = string_to_value("mutable");
|
|
WRITE_BARRIER(vec_root.value);
|
|
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(structure_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
|
|
_get_struct(structure_type_root.value)->slots[SS(MUTABLE)] = FALSE_VALUE;
|
|
|
|
register_builtin(BI_STRUCTURE, structure_type_root.value);
|
|
}
|
|
|
|
static void register_template(void)
|
|
{
|
|
gc_root_t tmp_root;
|
|
|
|
#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(structure_type_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");
|
|
WRITE_BARRIER(tmp_root.value);
|
|
/* Slot 2: List of superclasses, most to least specific */
|
|
_get_struct(tmp_root.value)->slots[SS(SUPERS)] = NIL;
|
|
/* Slot 3: Vector of slot names; size == total number of slots */
|
|
_get_struct(tmp_root.value)->slots[SS(SLOTS)] = make_vector(TEMPLATE_SLOTS, UNDEFINED);
|
|
WRITE_BARRIER(tmp_root.value);
|
|
{
|
|
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");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[TS(INSTANCE_VARS)] = string_to_value("instance-vars");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[TS(FRAME_VARS)] = string_to_value("frame-vars");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[TS(BYTE_CODE)] = string_to_value("byte-code");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[TS(TAIL_CALL)] = string_to_value("tail-call");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[TS(ARG_LIST)] = string_to_value("argument-list");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[TS(CONTEXT)] = string_to_value("context");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[TS(CONTINUATION)] = string_to_value("continuation");
|
|
WRITE_BARRIER(vec_root.value);
|
|
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 void register_lambda(void)
|
|
{
|
|
gc_root_t tmp_root;
|
|
|
|
#define LS(x) LAMBDA_SLOT_ ## x
|
|
|
|
/* Lambda: Instances of this structure are fundamental callable objects. */
|
|
register_gc_root(&tmp_root, make_struct(structure_type_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");
|
|
WRITE_BARRIER(tmp_root.value);
|
|
/* Slot 2: List of superclasses, most to least specific */
|
|
_get_struct(tmp_root.value)->slots[SS(SUPERS)] = NIL;
|
|
/* Slot 3: Vector of slot names; size == total number of slots */
|
|
_get_struct(tmp_root.value)->slots[SS(SLOTS)] = make_vector(LAMBDA_SLOTS, UNDEFINED);
|
|
WRITE_BARRIER(tmp_root.value);
|
|
{
|
|
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");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[LS(INSTANCE_VARS)] = string_to_value("instance-vars");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[LS(FRAME_VARS)] = string_to_value("frame-vars");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[LS(BYTE_CODE)] = string_to_value("byte-code");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[LS(TAIL_CALL)] = string_to_value("tail-call");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[LS(ARG_LIST)] = string_to_value("argument-list");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[LS(CONTEXT)] = string_to_value("context");
|
|
WRITE_BARRIER(vec_root.value);
|
|
_get_vector(vec_root.value)->elements[LS(CONTINUATION)] = string_to_value("continuation");
|
|
WRITE_BARRIER(vec_root.value);
|
|
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
|
|
|
|
typedef struct seen_struct_type
|
|
{
|
|
value_t struct_type;
|
|
struct seen_struct_type *prev;
|
|
} seen_struct_type_t;
|
|
|
|
static bool _struct_is_a(value_t value, value_t type, seen_struct_type_t *seen)
|
|
{
|
|
seen_struct_type_t new_seen;
|
|
|
|
/* The trivial cases: non-struct and exact match */
|
|
if (!is_struct(value)) return false;
|
|
if (_get_struct(value)->type == type) return true;
|
|
|
|
/* Detect cycles */
|
|
for (seen_struct_type_t *s = seen; s; s = s->prev)
|
|
{
|
|
if (s->struct_type == _get_struct(value)->type)
|
|
return false;
|
|
}
|
|
|
|
/* If type is structure, see if value is derived from type. */
|
|
new_seen.struct_type = _get_struct(value)->type;
|
|
new_seen.prev = seen;
|
|
if (_struct_is_a(_get_struct(value)->type, structure_type_root.value, &new_seen))
|
|
{
|
|
for (value_t supers = _SLOT_VALUE(STRUCTURE, _get_struct(value)->type, SUPERS);
|
|
!is_nil(supers); supers = _CDR(supers))
|
|
{
|
|
if (CAR(supers) == type)
|
|
return true;
|
|
}
|
|
}
|
|
|
|
return false;
|
|
}
|
|
|
|
bool struct_is_a(value_t value, value_t type)
|
|
{
|
|
return _struct_is_a(value, type, NULL);
|
|
}
|
|
|
|
static void bi_string_to_number(interp_state_t *state)
|
|
{
|
|
char *str;
|
|
char *end;
|
|
fixnum_t num;
|
|
value_t rval;
|
|
|
|
str = value_to_string(CAR(state->argv.value));
|
|
num = strtol(str, &end, 0);
|
|
free(str);
|
|
|
|
if ((*end == '\0') && (_get_fixnum(fixnum_value(num)) == num))
|
|
rval = cons(fixnum_value(num), NIL);
|
|
else
|
|
rval = cons(FALSE_VALUE, NIL);
|
|
|
|
state->lambda.value = state->k.value;
|
|
state->argv.value = rval;
|
|
state->k.value = FALSE_VALUE;
|
|
state->ctx.value = FALSE_VALUE;
|
|
}
|
|
|
|
/* vim:set sw=2 expandtab: */
|