rosella/builtin.c

#include <assert.h>
#include <inttypes.h>
#include <stdbool.h>
#include <stdlib.h>
#include <stdio.h>
#include <math.h>

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

typedef struct seen_value
{
  value_t value;
  struct seen_value *prev;
} seen_value_t;

static gc_root_t builtin_list;
static gc_root_t lambda_type_root;
static gc_root_t template_type_root;

static void bi_string_to_builtin(interp_state_t *state);
static void bi_builtin_to_string(interp_state_t *state);

static void bi_values(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);
static void bi_display(interp_state_t *state);
static void bi_register_finalizer(interp_state_t *state);
static void bi_current_context(interp_state_t *state);
static void bi_call_with_context(interp_state_t *state);
static void bi_exit(interp_state_t *state);
static void bi_float_to_string(interp_state_t *state);

static void bi_hash_by_id(interp_state_t *state);
static void bi_hash_by_value(interp_state_t *state);

void builtin_init(void)
{
  register_gc_root(&builtin_list,        NIL);
  register_gc_root(&lambda_type_root,    make_struct_type(FALSE_VALUE, LAMBDA_SLOTS, FALSE_VALUE));
  register_gc_root(&template_type_root,  make_struct_type(FALSE_VALUE, TEMPLATE_SLOTS, FALSE_VALUE));

  register_builtin(BI_UNDEFINED, UNDEFINED);
  register_builtin(BI_STRUCTURE, get_structure_type());
  register_builtin(BI_LAMBDA,    lambda_type_root.value);
  register_builtin(BI_TEMPLATE,  template_type_root.value);

#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_builtin(BI_VALUES,      make_builtin_fn(bi_values));
  register_builtin(BI_FREEZE,      make_builtin_fn(bi_freeze));
  register_builtin(BI_IMMUTABLE_P, make_builtin_fn(bi_immutable_p));
  register_builtin(BI_DISPLAY,     make_builtin_fn(bi_display));

  register_builtin(BI_STRING_TO_NUMBER,   make_builtin_fn(bi_string_to_number));
  register_builtin(BI_REGISTER_FINALIZER, make_builtin_fn(bi_register_finalizer));

  register_builtin(BI_STRING_TO_BUILTIN,  make_builtin_fn(bi_string_to_builtin));
  register_builtin(BI_BUILTIN_TO_STRING,  make_builtin_fn(bi_builtin_to_string));

  register_builtin(BI_CURRENT_CONTEXT,    make_builtin_fn(bi_current_context));
  register_builtin(BI_CALL_WITH_CONTEXT,  make_builtin_fn(bi_call_with_context));

  register_builtin(BI_EXIT,               make_builtin_fn(bi_exit));

  register_builtin(BI_FLOAT_TO_STRING,    make_builtin_fn(bi_float_to_string));

  register_builtin(BI_HASH_BY_ID,         make_builtin_fn(bi_hash_by_id));
  register_builtin(BI_HASH_BY_VALUE,      make_builtin_fn(bi_hash_by_value));
}

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 = make_pair(value, builtin_list.value);
  builtin_list.value = make_pair(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 reverse_lookup_builtin(value_t value)
{
  for (value_t list = builtin_list.value; !is_nil(list);
       list = CDDR(list))
  {
    if (CADR(list) == value)
    {
      return CAR(list);
    }
  }

  return FALSE_VALUE;
}

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

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

static void bi_string_to_builtin(interp_state_t *state)
{
  char *str;
  value_t rval;

  str = value_to_string(CAR(state->argv.value));
  rval = lookup_builtin(str);
  free(str);

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

static void bi_builtin_to_string(interp_state_t *state)
{
  value_t rval = reverse_lookup_builtin(CAR(state->argv.value));
  interp_return_values(state, make_pair(rval, NIL));
}

static void bi_values(interp_state_t *state)
{
  interp_return_values(state, state->argv.value);
}

static void bi_freeze(interp_state_t *state)
{
  value_t val = CAR(state->argv.value);

  if (is_vector(val))
  {
    get_vector(val)->immutable = true;
  }
  else if (is_byte_string(val))
  {
    get_byte_string(val)->immutable = true;
  }
  else if (is_struct(val))
  {
    get_struct(val)->immutable = true;
  }

  interp_return_values(state, make_pair(val, NIL));
}

static void bi_immutable_p(interp_state_t *state)
{
  value_t val;
  bool frozen;

  val = CAR(state->argv.value);

  if (is_vector(val))
  {
    frozen = get_vector(val)->immutable;
  }
  else if (is_byte_string(val))
  {
    frozen = get_byte_string(val)->immutable;
  }
  else if (is_struct(val))
  {
    frozen = get_struct(val)->immutable;
  }
  else
  {
    /* These values can't be changed, and thus can be considered frozen: */
    frozen = !is_object(val) || is_float(val) || is_builtin_fn(val);
  }

  interp_return_values(state, make_pair(make_boolean(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 = (fixnum_t)strtoll(str, &end, 0);

  if ((*end == '\0') && (get_fixnum(make_fixnum(num)) == num))
    rval = make_fixnum(num);
  else
    rval = FALSE_VALUE;

  free(str);
  interp_return_values(state, make_pair(rval, NIL));
}

static void bi_display(interp_state_t *state)
{
  fprint_value(stdout, CAR(state->argv.value));
  fflush(stdout);
  interp_return_values(state, NIL);
}

static void bi_register_finalizer(interp_state_t *state)
{
  register_finalizer(CAR(state->argv.value), CAR(CDR(state->argv.value)));
  interp_return_values(state, NIL);
}

static void bi_current_context(interp_state_t *state)
{
  interp_return_values(state, make_pair(state->ctx.value, NIL));
}

static void bi_call_with_context(interp_state_t *state)
{
  state->ctx.value     = CAR(state->argv.value);
  state->lambda.value  = CAR(CDR(state->argv.value));
  state->argv.value    = NIL;
  state->kw_args.value = NIL;
  state->kw_vals.value = NIL;
}

static void bi_exit(interp_state_t *state)
{
  state->ctx.value     = NIL;
  state->lambda.value  = END_PROGRAM;
  state->kw_args.value = NIL;
  state->kw_vals.value = NIL;
}

static void bi_float_to_string(interp_state_t *state)
{
  char buffer[32];
  fpnum_t flt = get_float(CAR(state->argv.value));

  snprintf(buffer, sizeof buffer, "%.18g", (double)flt);

  interp_return_values(state, make_pair(string_to_value(buffer), NIL));
}

static fixnum_t dbj2_hash(uint8_t *bytes, size_t size)
{
  fixnum_t hash = 5381;

  for (size_t i = 0; i < size; ++i)
  {
    hash = (33 * hash) ^ (size_t)bytes[i];
  }

  return hash;
}

static void bi_hash_by_id(interp_state_t *state)
{
  value_t value = CAR(state->argv.value);
  fixnum_t hash;

  if (is_float(value))
  {
    fpnum_t fpnum = get_float(value);
    hash = dbj2_hash((uint8_t*)&fpnum, sizeof fpnum);
  }
  else if (is_builtin_fn(value))
  {
    builtin_fn_t *fn = get_builtin_fn(value);
    hash = dbj2_hash((uint8_t*)&fn, sizeof fn);
  }
  else
  {
    hash = dbj2_hash((uint8_t*)&value, sizeof value);
  }

  interp_return_values(state, make_pair(make_fixnum((value_t)hash >> 1), NIL));
}

static fixnum_t combine_hashes(fixnum_t h1, fixnum_t h2)
{
  return h1 ^ (h2 + 0x9e3779b9 + (h1 << 6) + (h1 >> 2));
}

static fixnum_t hash_by_value(value_t v, seen_value_t *seen)
{
  if (is_float(v))
  {
    fpnum_t fpnum = get_float(v);
    return dbj2_hash((uint8_t*)&fpnum, sizeof fpnum);
  }
  else if (is_builtin_fn(v))
  {
    builtin_fn_t *fn = get_builtin_fn(v);
    return dbj2_hash((uint8_t*)&fn, sizeof fn);
  }
  else if (is_byte_string(v))
  {
    byte_string_t *str = get_byte_string(v);
    return dbj2_hash(str->bytes, str->nbytes);
  }
  else if (!is_object(v))
  {
    /* Non-objects compare by value */
    return dbj2_hash((uint8_t*)&v, sizeof v);
  }
  else
  {
    seen_value_t new_seen = { v, seen };

    for (seen_value_t *sv = seen; sv; sv = sv->prev)
    {
      if (v == sv->value)
      {
        return 0;
      }
    }

    if (is_box(v))
    {
      return combine_hashes(OBJECT_TAG_BOX,
          hash_by_value(get_box(v)->value, &new_seen));
    }
    else if (is_weak_box(v))
    {
      return combine_hashes(OBJECT_TAG_WEAK_BOX,
          hash_by_value(get_weak_box(v)->value, &new_seen));
    }
    else if (is_pair(v))
    {
      return combine_hashes(OBJECT_TAG_PAIR,
                            combine_hashes(hash_by_value(CAR(v), &new_seen),
                                           hash_by_value(CDR(v), &new_seen)));
    }
    else if (is_vector(v))
    {
      vector_t *vec = get_vector(v);
      fixnum_t hash = OBJECT_TAG_VECTOR;
      int i;

      for (i = 0; i < vec->nelements; ++i)
        hash = combine_hashes(hash, hash_by_value(vec->elements[i], &new_seen));

      return hash;
    }
    else if (is_struct(v))
    {
      struct_t *str = get_struct(v);
      fixnum_t hash = combine_hashes(OBJECT_TAG_STRUCT, hash_by_value(str->type, &new_seen));
      int i;

      for (i = 0; i < str->nslots; ++i)
        hash = combine_hashes(hash, hash_by_value(str->slots[i], &new_seen));

      return hash;
    }
    else
    {
      /* Shouldn't encounter anything else, but if so, use the object ID */
      return dbj2_hash((uint8_t*)&v, sizeof v);
    }
  }
}

static void bi_hash_by_value(interp_state_t *state)
{
  value_t value = CAR(state->argv.value);
  fixnum_t hash = hash_by_value(value, NULL);
  interp_return_values(state, make_pair(make_fixnum((value_t)hash >> 1), NIL));
}

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