Add a helper function for creating structure types.

builtin.c

@@ -9,27 +9,23 @@
 #include "interp.h"
 
 static gc_root_t builtin_list;
-static gc_root_t template_type_root;
 static gc_root_t lambda_type_root;
+static gc_root_t template_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);
 static void bi_freeze(interp_state_t *state);
 static void bi_immutable_p(interp_state_t *state);
+static void bi_string_to_number(interp_state_t *state);
 
 void builtin_init(void)
 {
   register_gc_root(&builtin_list,        NIL);
-  register_gc_root(&template_type_root,  UNDEFINED);
+  register_gc_root(&lambda_type_root,    make_struct_type(NIL, LAMBDA_SLOTS, FALSE_VALUE));
-  register_gc_root(&lambda_type_root,    UNDEFINED);
+  register_gc_root(&template_type_root,  make_struct_type(NIL, TEMPLATE_SLOTS, FALSE_VALUE));
 
   register_builtin(BI_UNDEFINED, UNDEFINED);
-  register_builtin(BI_STRING_TO_NUMBER,  make_builtin_fn(bi_string_to_number));
+  register_builtin(BI_STRUCTURE, get_structure_type());
-  register_builtin(BI_FREEZE,            make_builtin_fn(bi_freeze));
+  register_builtin(BI_LAMBDA,    lambda_type_root.value);
-  register_builtin(BI_IMMUTABLE_P,       make_builtin_fn(bi_immutable_p));
+  register_builtin(BI_TEMPLATE,  template_type_root.value);
 
 #ifdef NAN
   register_builtin(BI_POS_NAN, make_float(NAN));
@@ -41,9 +37,10 @@ void builtin_init(void)
   register_builtin(BI_NEG_INFINITY, make_float(-INFINITY));
 #endif
 
-  register_structure();
+  register_builtin(BI_FREEZE,      make_builtin_fn(bi_freeze));
-  register_template();
+  register_builtin(BI_IMMUTABLE_P, make_builtin_fn(bi_immutable_p));
-  register_lambda();
+
+  register_builtin(BI_STRING_TO_NUMBER, make_builtin_fn(bi_string_to_number));
 }
 
 void register_builtin(const char *name, value_t value)
@@ -82,69 +79,6 @@ value_t get_lambda_type(void)
   return lambda_type_root.value;
 }
 
-#define SS(x) STRUCTURE_SLOT_ ## x
-
-static void register_structure(void)
-{
-  register_builtin(BI_STRUCTURE, get_structure_type());
-}
-
-static void register_template(void)
-{
-  /* Template: Instances of this structure describe what a LAMBDA
-   * will look like when instanciated with the 'lambda' bytecode. */
-  template_type_root.value = make_struct(get_structure_type());
-
-  /* Slot 1: List of superclasses, most to least specific */
-  _get_struct(template_type_root.value)->slots[SS(SUPERS)] = NIL;
-  /* Slot 2: Total number of slots (excl. type) */
-  _get_struct(template_type_root.value)->slots[SS(NSLOTS)] = fixnum_value(TEMPLATE_SLOTS);
-  /* Slot 3: Callable object used as proxy when structure is APPLY'd. */
-  _get_struct(template_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
-
-  _get_struct(template_type_root.value)->immutable = true;
-
-  register_builtin(BI_TEMPLATE, template_type_root.value);
-}
-
-static void register_lambda(void)
-{
-  /* Lambda: Instances of this structure are fundamental callable objects. */
-  lambda_type_root.value = make_struct(get_structure_type());
-
-  /* Slot 1: List of superclasses, most to least specific */
-  _get_struct(lambda_type_root.value)->slots[SS(SUPERS)] = NIL;
-  /* Slot 2: Total number of slots (excl. type) */
-  _get_struct(lambda_type_root.value)->slots[SS(NSLOTS)] = fixnum_value(LAMBDA_SLOTS);
-  /* Slot 3: Callable object used as proxy when structure is APPLY'd. */
-  _get_struct(lambda_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
-
-  _get_struct(lambda_type_root.value)->immutable = true;
-
-  register_builtin(BI_LAMBDA, lambda_type_root.value);
-}
-
-#undef SS
-
-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 = fixnum_value(num);
-  else
-    rval = FALSE_VALUE;
-
-  interp_return_values(state, cons(rval, NIL));
-}
-
 static void bi_freeze(interp_state_t *state)
 {
   value_t val = CAR(state->argv.value);
@@ -193,4 +127,23 @@ static void bi_immutable_p(interp_state_t *state)
   interp_return_values(state, cons(boolean_value(frozen), NIL));
 }
 
+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 = fixnum_value(num);
+  else
+    rval = FALSE_VALUE;
+
+  interp_return_values(state, cons(rval, NIL));
+}
+
 /* vim:set sw=2 expandtab: */

builtin.h

@@ -10,25 +10,19 @@
 /* Names of fundamental builtin values */
 #define BI_UNDEFINED     "undefined"
 #define BI_STRUCTURE     "structure"
-#define BI_TEMPLATE      "template"
 #define BI_LAMBDA        "lambda"
+#define BI_TEMPLATE      "template"
 #define BI_POS_NAN       "+NaN"
 #define BI_NEG_NAN       "-NaN"
 #define BI_POS_INFINITY  "+infinity"
 #define BI_NEG_INFINITY  "-infinity"
 
 /* Names of builtin functions */
-#define BI_STRING_TO_NUMBER "string->number"
 #define BI_FREEZE           "freeze!"
 #define BI_IMMUTABLE_P      "immutable?"
+#define BI_STRING_TO_NUMBER "string->number"
 
-#define TEMPLATE_SLOT_GLOBAL_VARS   0
+/* Lambda: Instances of this structure are fundamental callable objects. */
-#define TEMPLATE_SLOT_INSTANCE_VARS 1
-#define TEMPLATE_SLOT_FRAME_VARS    2
-#define TEMPLATE_SLOT_BYTE_CODE     3
-#define TEMPLATE_SLOT_TAIL_CALL     4
-#define TEMPLATE_SLOTS              5
-
 #define LAMBDA_SLOT_GLOBAL_VARS   0
 #define LAMBDA_SLOT_INSTANCE_VARS 1
 #define LAMBDA_SLOT_FRAME_VARS    2
@@ -36,8 +30,17 @@
 #define LAMBDA_SLOT_TAIL_CALL     4
 #define LAMBDA_SLOTS              5
 
-value_t get_template_type(void);
+/* Template: Instances of this structure describe what a LAMBDA
+ * will look like when instanciated with the 'lambda' bytecode. */
+#define TEMPLATE_SLOT_GLOBAL_VARS   0
+#define TEMPLATE_SLOT_INSTANCE_VARS 1
+#define TEMPLATE_SLOT_FRAME_VARS    2
+#define TEMPLATE_SLOT_BYTE_CODE     3
+#define TEMPLATE_SLOT_TAIL_CALL     4
+#define TEMPLATE_SLOTS              5
+
 value_t get_lambda_type(void);
+value_t get_template_type(void);
 
 void builtin_init(void);
 void register_builtin(const char *name, value_t value);

gc.c

@@ -276,19 +276,45 @@ static void structure_init(void)
 
   register_gc_root(&structure_type_root, object_value(s));
 
-#define SS(x) STRUCTURE_SLOT_ ## x
   /* Slot 1: List of superclasses, most to least specific */
-  _get_struct(structure_type_root.value)->slots[SS(SUPERS)] = NIL;
+  _get_struct(structure_type_root.value)->slots[STRUCTURE_SLOT_SUPERS] = NIL;
+
   /* Slot 2: Total number of slots (excl. type) */
-  _get_struct(structure_type_root.value)->slots[SS(NSLOTS)] = fixnum_value(STRUCTURE_SLOTS);
+  _get_struct(structure_type_root.value)->slots[STRUCTURE_SLOT_NSLOTS] = fixnum_value(STRUCTURE_SLOTS);
+
   /* Slot 3: Callable object used as proxy when structure is APPLY'd. */
   /* Can be LAMBDA, callable structure instance, builtin, or FALSE_VALUE. */
-  _get_struct(structure_type_root.value)->slots[SS(CALLABLE)] = FALSE_VALUE;
+  _get_struct(structure_type_root.value)->slots[STRUCTURE_SLOT_CALLABLE] = FALSE_VALUE;
-#undef SS
 
   _get_struct(structure_type_root.value)->immutable = true;
 }
 
+value_t get_structure_type(void)
+{
+  return structure_type_root.value;
+}
+
+value_t make_struct_type(value_t supers, fixnum_t nslots, value_t callable)
+{
+  gc_root_t supers_root;
+  gc_root_t callable_root;
+  value_t result;
+
+  register_gc_root(&supers_root,   supers);
+  register_gc_root(&callable_root, callable);
+
+  result = make_struct(get_structure_type());
+  _get_struct(result)->slots[STRUCTURE_SLOT_SUPERS] = supers;
+  _get_struct(result)->slots[STRUCTURE_SLOT_NSLOTS] = fixnum_value(nslots);
+  _get_struct(result)->slots[STRUCTURE_SLOT_CALLABLE] = callable;
+  _get_struct(result)->immutable = true;
+
+  unregister_gc_root(&supers_root);
+  unregister_gc_root(&callable_root);
+
+  return result;
+}
+
 bool struct_is_a(value_t value, value_t type)
 {
   value_t tortoise, hare;
@@ -327,11 +353,6 @@ bool struct_is_a(value_t value, value_t type)
   return false;
 }
 
-value_t get_structure_type(void)
-{
-  return structure_type_root.value;
-}
-
 struct_t *get_struct(value_t v)
 {
   release_assert(is_struct(v));

gc.h

@@ -229,6 +229,9 @@ value_t make_struct(value_t type);
 struct_t *get_struct(value_t v);
 value_t get_structure_type(void);
 
+/* Instantiates a structure type. Result is immutable. */
+value_t make_struct_type(value_t supers, fixnum_t nslots, value_t callable);
+
 /* True if 'value' is (1) a structure, and (2) an instance of 'type'. */
 bool struct_is_a(value_t value, value_t type);