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