rosella/builtin.c

#include <assert.h>
#include <inttypes.h>
#include <stdbool.h>
#include <stdlib.h>
#include <string.h>

#include "gc.h"
#include "builtin.h"

static gc_root_t builtin_list;

/* Returns a byte string w/ bytes from 's' (excl. terminating NUL). */
static value_t string_to_value(const char *s);

/* Return value is a new C string which must be free()'d by caller. */
static char *value_to_string(value_t v);

/* Like strcmp(), but for byte strings. */
static int byte_strcmp(value_t s1, value_t s2);

void builtin_init(void)
{
  gc_root_t ms_root, tmp_root;

  register_gc_root(&builtin_list, NIL);

#define SS(x) STRUCTURE_SLOT_ ## x

  /* (Meta-)Structure: Instances of this structure describe structures. */
  register_gc_root(&ms_root, make_struct(NIL, STRUCTURE_SLOTS));
  register_builtin(BI_STRUCTURE, ms_root.value);

  /* 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;
  /* Slot 1: Name */
  _get_struct(ms_root.value)->slots[SS(NAME)] = string_to_value("structure");
  /* Slot 2: Super/parent structure type, or NIL */
  _get_struct(ms_root.value)->slots[SS(SUPER)] = 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, NIL);
  {
    gc_root_t vec_root;
    register_gc_root(&vec_root, _get_struct(ms_root.value)->slots[SS(SLOTS)]);
    _get_vector(vec_root.value)->elements[SS(NAME)] = string_to_value("name");
    _get_vector(vec_root.value)->elements[SS(SUPER)] = string_to_value("super");
    _get_vector(vec_root.value)->elements[SS(SLOTS)] = string_to_value("slots");
    _get_vector(vec_root.value)->elements[SS(CALLABLE)] = string_to_value("callable");
    unregister_gc_root(&vec_root);
  }
  /* Slot 4: Callable object used as proxy when structure is APPLY'd. */
  /* Can be LAMBDA or callable structure instance. */
  _get_struct(ms_root.value)->slots[SS(CALLABLE)] = NIL;

#define TS(x) TEMPLATE_SLOT_ ## x

  /* 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_builtin(BI_TEMPLATE, tmp_root.value);

  /* Slot 1: Name */
  _get_struct(tmp_root.value)->slots[SS(NAME)] = string_to_value("template");
  /* Slot 2: Super/parent structure type, or NIL */
  _get_struct(tmp_root.value)->slots[SS(SUPER)] = NIL;
  /* Slot 3: Vector of slot names; size == total number of slots */
  _get_struct(tmp_root.value)->slots[SS(SLOTS)] = make_vector(TEMPLATE_SLOTS, NIL);
  {
    gc_root_t vec_root;
    register_gc_root(&vec_root, _get_struct(tmp_root.value)->slots[SS(SLOTS)]);
    _get_vector(vec_root.value)->elements[TS(GLOBAL_VARS)]   = string_to_value("global-vars");
    _get_vector(vec_root.value)->elements[TS(INSTANCE_VARS)] = string_to_value("instance-vars");
    _get_vector(vec_root.value)->elements[TS(FRAME_VARS)]    = string_to_value("frame-vars");
    _get_vector(vec_root.value)->elements[TS(BYTE_CODE)]     = string_to_value("byte-code");
    _get_vector(vec_root.value)->elements[TS(TAIL_CALL)]     = string_to_value("tail-call");
    _get_vector(vec_root.value)->elements[TS(ARG_LIST)]      = string_to_value("argument-list");
    _get_vector(vec_root.value)->elements[TS(CONTINUATION)]  = string_to_value("continuation");
    _get_vector(vec_root.value)->elements[TS(CONTEXT)]       = string_to_value("context");
    unregister_gc_root(&vec_root);
  }
  /* Slot 4: Callable object used as proxy when structure is apply'd. */
  _get_struct(tmp_root.value)->slots[SS(CALLABLE)] = NIL;

  unregister_gc_root(&tmp_root);

#undef TS
#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_builtin(BI_LAMBDA, tmp_root.value);

  /* Slot 1: Name */
  _get_struct(tmp_root.value)->slots[SS(NAME)] = string_to_value("lambda");
  /* Slot 2: Super/parent structure type, or NIL */
  _get_struct(tmp_root.value)->slots[SS(SUPER)] = NIL;
  /* Slot 3: Vector of slot names; size == total number of slots */
  _get_struct(tmp_root.value)->slots[SS(SLOTS)] = make_vector(LAMBDA_SLOTS, NIL);
  {
    gc_root_t vec_root;
    register_gc_root(&vec_root, _get_struct(tmp_root.value)->slots[SS(SLOTS)]);
    _get_vector(vec_root.value)->elements[LS(GLOBAL_VARS)]   = string_to_value("global-vars");
    _get_vector(vec_root.value)->elements[LS(INSTANCE_VARS)] = string_to_value("instance-vars");
    _get_vector(vec_root.value)->elements[LS(FRAME_VARS)]    = string_to_value("frame-vars");
    _get_vector(vec_root.value)->elements[LS(BYTE_CODE)]     = string_to_value("byte-code");
    _get_vector(vec_root.value)->elements[LS(TAIL_CALL)]     = string_to_value("tail-call");
    _get_vector(vec_root.value)->elements[LS(ARG_LIST)]      = string_to_value("argument-list");
    _get_vector(vec_root.value)->elements[LS(CONTINUATION)]  = string_to_value("continuation");
    _get_vector(vec_root.value)->elements[LS(CONTEXT)]       = string_to_value("context");
    unregister_gc_root(&vec_root);
  }
  /* Slot 4: Callable object used as proxy when structure is apply'd. */
  _get_struct(tmp_root.value)->slots[SS(CALLABLE)] = NIL;

  unregister_gc_root(&tmp_root);

#undef LS
#undef SS

  unregister_gc_root(&ms_root);
}

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;
}

static value_t string_to_value(const char *s)
{
  size_t len = strlen(s);
  value_t v = make_byte_string(len, '\0');
  memcpy(_get_byte_string(v)->bytes, s, len);
  return v;
}

static char *value_to_string(value_t v)
{
  byte_string_t *str = get_byte_string(v);
  char *s = (char*)malloc(str->size + 1);

  memcpy(s, str->bytes, str->size);
  s[str->size] = '\0';

  return s;
}

static int byte_strcmp(value_t s1, value_t s2)
{
  byte_string_t *str1 = get_byte_string(s1);
  byte_string_t *str2 = get_byte_string(s2);

  if (str1->size < str2->size)
    return -1;
  else if (str1->size > str2->size)
    return 1;
  else
    return memcmp(str1->bytes, str2->bytes, str1->size);
}

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