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

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_structure(void);
-static void register_template(gc_root_t *ms_root);
+static void register_template(void);
-static void register_lambda(gc_root_t *ms_root);
+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_structure();
-  register_template(&ms_root);
+  register_template();
-  register_lambda(&ms_root);
+  register_lambda();
-
-  unregister_gc_root(&ms_root);
 }
 
 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");
+  _get_struct(structure_type_root.value)->slots[SS(NAME)] = string_to_value("structure");
-  WRITE_BARRIER(ms_root->value);
+  WRITE_BARRIER(structure_type_root.value);
-  /* Slot 2: Super/parent structure type, or FALSE_VALUE */
+  /* Slot 2: List of superclasses, most to least specific */
-  _get_struct(ms_root->value)->slots[SS(SUPER)] = FALSE_VALUE;
+  _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);
+  _get_struct(structure_type_root.value)->slots[SS(SLOTS)] = make_vector(STRUCTURE_SLOTS, UNDEFINED);
-  WRITE_BARRIER(ms_root->value);
+  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(structure_type_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(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 */
+  /* Slot 2: List of superclasses, most to least specific */
-  _get_struct(tmp_root.value)->slots[SS(SUPER)] = FALSE_VALUE;
+  _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 */
+  /* Slot 2: List of superclasses, most to least specific */
-  _get_struct(tmp_root.value)->slots[SS(SUPER)] = FALSE_VALUE;
+  _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;

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: */

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

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!"));
   }
 

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)

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))