diff --git a/builtin.c b/builtin.c index 07810d1..b413b23 100644 --- a/builtin.c +++ b/builtin.c @@ -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; diff --git a/builtin.h b/builtin.h index 93ce808..1e8dd25 100644 --- a/builtin.h +++ b/builtin.h @@ -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: */ diff --git a/doc/bytecode.txt b/doc/bytecode.txt index 0d6fa94..8d5da93 100644 --- a/doc/bytecode.txt +++ b/doc/bytecode.txt @@ -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 diff --git a/interp.c b/interp.c index 13e3a35..b1c8995 100644 --- a/interp.c +++ b/interp.c @@ -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!")); } diff --git a/libcompiler/primitives.scm b/libcompiler/primitives.scm index f17af46..beeb7a5 100644 --- a/libcompiler/primitives.scm +++ b/libcompiler/primitives.scm @@ -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) diff --git a/src/lib/primitives.rls b/src/lib/primitives.rls index f4a668c..39bd85d 100644 --- a/src/lib/primitives.rls +++ b/src/lib/primitives.rls @@ -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))