rosella/builtin.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 gc_root_t template_type_root;
static gc_root_t lambda_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_gc_root(&template_type_root,  UNDEFINED);
  register_gc_root(&lambda_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;
}

value_t get_structure_type(void)
{
  return structure_type_root.value;
}

value_t get_template_type(void)
{
  return template_type_root.value;
}

value_t get_lambda_type(void)
{
  return lambda_type_root.value;
}

#define SS(x) STRUCTURE_SLOT_ ## x

static void register_structure(void)
{
  /* Structure: Instances of this structure describe structures. */
  /* It is both a structure and a structure description, and thus an instance of itself. */
  structure_type_root.value = make_struct(UNDEFINED, STRUCTURE_SLOTS);
  _get_struct(structure_type_root.value)->type = structure_type_root.value;

  /* Slot 1: List of superclasses, most to least specific */
  _get_struct(structure_type_root.value)->slots[SS(SUPERS)] = NIL;
  /* Slot 2: Total number of slots (excl. type) */
  _get_struct(structure_type_root.value)->slots[SS(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;

  register_builtin(BI_STRUCTURE, structure_type_root.value);
}

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(structure_type_root.value, STRUCTURE_SLOTS);

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

  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(structure_type_root.value, STRUCTURE_SLOTS);

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

  register_builtin(BI_LAMBDA, lambda_type_root.value);
}

#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 = fixnum_value(num);
  else
    rval = FALSE_VALUE;

  interp_return_values(state, cons(rval, NIL));
}

/* vim:set sw=2 expandtab: */