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

Improve on struct_is_a() and expose it as a VM primitive operation.

This commit is contained in:
Jesse D. McDonald 2010-05-05 00:31:36 -05:00
parent 50d9e0e0fc
commit e375edfc83
6 changed files with 86 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
builtin.c
View File

@ -9,19 +9,18 @@
#include "interp.h"
static gc_root_t builtin_list;
static gc_root_t structure_type_root;
static void register_structure(gc_root_t *ms_root);
static void register_template(gc_root_t *ms_root);
static void register_lambda(gc_root_t *ms_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)
{
gc_root_t ms_root;
register_gc_root(&builtin_list, NIL);
register_gc_root(&ms_root, UNDEFINED);
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));
@ -36,11 +35,9 @@ void builtin_init(void)
register_builtin(BI_NEG_INFINITY, make_float(-INFINITY));
#endif
register_structure(&ms_root);
register_template(&ms_root);
register_lambda(&ms_root);
unregister_gc_root(&ms_root);
register_structure();
register_template();
register_lambda();
}
void register_builtin(const char *name, value_t value)
@ -71,28 +68,28 @@ value_t lookup_builtin(const char *name)
#define SS(x) STRUCTURE_SLOT_ ## x
static void register_structure(gc_root_t *ms_root)
static void register_structure(void)
{
/* (Meta-)Structure: Instances of this structure describe structures. */
ms_root->value = make_struct(UNDEFINED, STRUCTURE_SLOTS);
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(ms_root->value)->type = ms_root->value;
_get_struct(structure_type_root.value)->type = structure_type_root.value;
/* Slot 1: Name */
_get_struct(ms_root->value)->slots[SS(NAME)] = string_to_value("structure");
WRITE_BARRIER(ms_root->value);
/* Slot 2: Super/parent structure type, or FALSE_VALUE */
_get_struct(ms_root->value)->slots[SS(SUPER)] = FALSE_VALUE;
_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(ms_root->value)->slots[SS(SLOTS)] = make_vector(STRUCTURE_SLOTS, UNDEFINED);
WRITE_BARRIER(ms_root->value);
_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(ms_root->value)->slots[SS(SLOTS)]);
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(SUPER)] = string_to_value("super");
_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);
@ -104,13 +101,13 @@ static void register_structure(gc_root_t *ms_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;
_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, ms_root->value);
register_builtin(BI_STRUCTURE, structure_type_root.value);
}
static void register_template(gc_root_t *ms_root)
static void register_template(void)
{
gc_root_t tmp_root;
@ -118,14 +115,14 @@ static void register_template(gc_root_t *ms_root)
/* 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_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: Super/parent structure type, or FALSE_VALUE */
_get_struct(tmp_root.value)->slots[SS(SUPER)] = FALSE_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);
@ -159,21 +156,21 @@ static void register_template(gc_root_t *ms_root)
#undef TS
}
static void register_lambda(gc_root_t *ms_root)
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(ms_root->value, STRUCTURE_SLOTS));
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: Super/parent structure type, or FALSE_VALUE */
_get_struct(tmp_root.value)->slots[SS(SUPER)] = FALSE_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);
@ -209,6 +206,48 @@ static void register_lambda(gc_root_t *ms_root)
#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;

8
builtin.h
View File

@ -20,8 +20,11 @@
/* Name of builtin function */
#define BI_STRING_TO_NUMBER "string->number"
/* Ex: _SLOT_VALUE(STRUCTURE, v, NAME) */
#define _SLOT_VALUE(t,v,s) (_get_struct(v)->slots[t ## _SLOT_ ## s])
#define STRUCTURE_SLOT_NAME 0
#define STRUCTURE_SLOT_SUPER 1
#define STRUCTURE_SLOT_SUPERS 1
#define STRUCTURE_SLOT_SLOTS 2
#define STRUCTURE_SLOT_CALLABLE 3
#define STRUCTURE_SLOT_MUTABLE 4
@ -51,5 +54,8 @@ void builtin_init(void);
void register_builtin(const char *name, value_t value);
value_t lookup_builtin(const char *name);
/* True if 'value' is (1) a structure, and (2) an instance of 'type'. */
bool struct_is_a(value_t value, value_t type);
#endif
/* vim:set sw=2 expandtab: */

2
doc/bytecode.txt
View File

@ -133,6 +133,8 @@ binary-expr: up to 63 (01..3f), 1 out, 2 in
27 (set! out (nextafter in1 in2)) ; float float
28 (set! out (remainder in1 in2)) ; float float
29 (set! out (scalb in1 in2)) ; float float
30 (set! out (kind-of? in1 in2)) ; value struct-type
conditional: 1 out, 3 in
; 0x80 <= AA <= 0xf7 (f0-f119)
AA (set! AA (if in1 in2 in3)) ; in3 if in1 == #f, in2 otherwise

29
interp.c
View File

@ -16,11 +16,8 @@
#include "builtin.h"
#include "interp.h"
/* Ex: _SLOT_VALUE(STRUCTURE, v, NAME) */
#define _SLOT_VALUE(t,v,s) (_get_struct(v)->slots[t ## _SLOT_ ## s])
#define _LAMBDA_SLOT(v,s) _SLOT_VALUE(LAMBDA, v, s)
/* Shorthand for frequently-used fields */
#define _LAMBDA_SLOT(v,s) _SLOT_VALUE(LAMBDA, v, s)
#define ST1 (state->in1.value)
#define ST2 (state->in2.value)
#define ST3 (state->in3.value)
@ -34,8 +31,6 @@ static gc_root_t lambda_type_root;
* Local helper routines
*/
static bool struct_is_a(value_t s, value_t type);
static value_t vector_ref(value_t v, fixnum_t idx);
static char byte_string_ref(value_t v, fixnum_t idx);
static value_t struct_ref(value_t v, fixnum_t idx);
@ -149,27 +144,6 @@ value_t run_interpreter(value_t lambda, value_t argv)
return state.argv.value;
}
/* TODO: Permit derivatives of 'structure', and improve detection of cycles. */
static bool struct_is_a(value_t s, value_t type)
{
/* Detect unbounded loops w/ cyclic 'super' links. */
int ttl = 256;
if (!is_struct(s))
return false;
for (value_t t = _get_struct(s)->type; t != type; t = _SLOT_VALUE(STRUCTURE, t, SUPER), --ttl)
{
if (t == FALSE_VALUE)
return false;
release_assert(get_struct(t)->type == structure_type_root.value);
release_assert(ttl > 0);
}
return true;
}
static value_t vector_ref(value_t v, fixnum_t idx)
{
vector_t *vec = get_vector(v);
@ -399,6 +373,7 @@ static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1,
case 0x27: return make_float(nextafter(get_float(ST1), get_float(ST2)));
case 0x28: return make_float(remainder(get_float(ST1), get_float(ST2)));
case 0x29: return make_float(scalb(get_float(ST1), get_float(ST2)));
case 0x30: return boolean_value(struct_is_a(ST1, ST2));
default: release_assert(NOTREACHED("Invalid byte-code!"));
}

3
libcompiler/primitives.scm
View File

@ -120,7 +120,8 @@
(%yn #x26 yn)
(%nextafter #x27 nextafter)
(%remainder #x28 remainder)
(%scalb #x29 scalb)))
(%scalb #x29 scalb)
(%kind-of? #x30 kind-of?)))
(define unary-statement-primitives
'((%goto-end-if #x40 #f)

1
src/lib/primitives.rls
View File

@ -102,6 +102,7 @@
(define (nextafter x y) (nextafter x y))
(define (remainder x y) (remainder x y))
(define (scalb x y) (scalb x y))
(define (kind-of? x y) (kind-of? x y))
; Binary statement primitives
(define (set-box! x y) (set-box! x y))