// eval_sequence may return an object with a refcount of zero.
// This is because it's the interface to the interpreter and so the
// return value may be the result of a computation that only has
// one reference inside the created vm context. On the other hand
// it may return an object with multiple references (if the object
// returned is referenced in the passed environment, for example).
struct object *
eval_sequence(struct pair *forms, struct environment *env)
{
struct code *prog = compile(forms);
INC_REF(&prog->obj);
struct codeptr *pc = make_codeptr(prog, 0);
INC_REF(&pc->obj);
struct stack *stk = make_stack(1024);
// push magic "end of instructions" return address
stack_push(stk, NULL);
stack_push(stk, &env->obj);
INC_REF(&env->obj);
struct vm_context *ctx = make_vm_context(pc, stk, env);
INC_REF(&ctx->obj);
struct vm_context **pctx = &ctx;
eval_instructions(pctx);
struct object *value = stack_pop((*pctx)->stk);
// decrement the refcount if it's positive, but don't deallocate
// the object
if (value->refcount > 0) {
--(value->refcount);
}
DEC_REF(&prog->obj);
assert(stack_empty((*pctx)->stk));
DEC_REF(&ctx->obj);
return value;
}
int
main(int argc, char* argv[])
{
init_symbol_table();
init_builtin_types();
init_global_env();
init_singleton_objects();
init_primitive_procs();
struct vm_context *global_ctx = make_vm_context(NULL, NULL,
global_env);
INC_REF(&global_ctx->obj);
struct vm_context **pctx = &global_ctx;
struct object *value;
value = load("prelude.scm", pctx);
YIELD_OBJ(value);
init_compiler();
value = load("stage2.scm", pctx);
YIELD_OBJ(value);
struct vm_context *repl_ctx;
repl_ctx = make_vm_context(NULL, make_stack(1024),
make_environment(global_env));
INC_REF(&repl_ctx->obj);
pctx = &repl_ctx;
struct object *ret = env_lookup(global_env, "initial-repl");
assert(ret->type->code == PROCEDURE_TYPE);
struct procedure *repl = container_of(ret, struct procedure, obj);
apply_and_run(repl, NIL, pctx);
return 0;
}
BLEIO_SEQ_RESULT schedule_write(
BLEIO_SEQ_HANDLE_DATA* handle_data,
BLEIO_SEQ_INSTRUCTION* instruction,
ON_INTERNAL_IO_COMPLETE on_internal_read_complete
)
{
BLEIO_SEQ_RESULT result;
WRITE_CONTEXT* context = (WRITE_CONTEXT*)malloc(sizeof(WRITE_CONTEXT));
/*Codes_SRS_BLEIO_SEQ_13_014: [ BLEIO_Seq_Run shall return BLEIO_SEQ_ERROR if an underlying platform call fails. ]*/
if (context == NULL)
{
LogError("malloc failed");
result = BLEIO_SEQ_ERROR;
}
else
{
context->handle_data = handle_data;
context->instruction = instruction;
context->on_internal_read_complete = on_internal_read_complete;
const unsigned char* buffer = BUFFER_u_char(instruction->data.buffer);
size_t buffer_size = BUFFER_length(instruction->data.buffer);
// add ref to the handle data object since we now will have an
// outstanding I/O operation; the reason why we increment the
// reference here as opposed to when we know that BLEIO_gatt_read_char_by_uuid
// was successful is because the operation could potentially complete
// even before we hit the if check after this call and 'on_read_complete'
// might have run by then in which case it would have done a DEC_REF and
// the ref counts will be out of whack
INC_REF(BLEIO_SEQ_HANDLE_DATA, handle_data);
int write_result = BLEIO_gatt_write_char_by_uuid(
handle_data->bleio_gatt_handle,
STRING_c_str(instruction->characteristic_uuid),
buffer,
buffer_size,
on_write_complete,
context
);
if (write_result != 0)
{
/*Codes_SRS_BLEIO_SEQ_13_014: [ BLEIO_Seq_Run shall return BLEIO_SEQ_ERROR if an underlying platform call fails. ]*/
result = BLEIO_SEQ_ERROR;
free(context);
DEC_REF(BLEIO_SEQ_HANDLE_DATA, handle_data);
LogError("BLEIO_gatt_write_char_by_uuid failed with %d.", write_result);
}
else
{
result = BLEIO_SEQ_OK;
}
}
return result;
}
POS_HANDLE Pos_Clone(POS_HANDLE posHandle)
{
if (posHandle != NULL)
{
pos* p = posHandle;
INC_REF(pos, p);
}
return posHandle;
}
void Broker_IncRef(BROKER_HANDLE broker)
{
/*Codes_SRS_BROKER_13_108: [If `broker` is NULL then Broker_IncRef shall do nothing.]*/
if (broker == NULL)
{
LogError("invalid arg: broker is NULL");
}
else
{
/*Codes_SRS_BROKER_13_109: [Otherwise, Broker_IncRef shall increment the internal ref count.]*/
INC_REF(BROKER_HANDLE_DATA, broker);
}
}
void constbuffer_array_inc_ref(CONSTBUFFER_ARRAY_HANDLE constbuffer_array_handle)
{
if (constbuffer_array_handle == NULL)
{
/* Codes_SRS_CONSTBUFFER_ARRAY_01_017: [ If `constbuffer_array_handle` is `NULL` then `constbuffer_array_inc_ref` shall return. ]*/
LogError("invalid argument CONSTBUFFER_ARRAY_HANDLE constbuffer_array_handle=%p", constbuffer_array_handle);
}
else
{
/* Codes_SRS_CONSTBUFFER_ARRAY_01_018: [ Otherwise `constbuffer_array_inc_ref` shall increment the reference count for `constbuffer_array_handle`. ]*/
INC_REF(CONSTBUFFER_ARRAY_HANDLE_DATA, constbuffer_array_handle);
}
}
CONSTBUFFER_HANDLE CONSTBUFFER_Clone(CONSTBUFFER_HANDLE constbufferHandle)
{
if (constbufferHandle == NULL)
{
/*Codes_SRS_CONSTBUFFER_02_013: [If constbufferHandle is NULL then CONSTBUFFER_Clone shall fail and return NULL.]*/
LogError("invalid arg");
}
else
{
/*Codes_SRS_CONSTBUFFER_02_014: [Otherwise, CONSTBUFFER_Clone shall increment the reference count and return constbufferHandle.]*/
INC_REF(CONSTBUFFER_HANDLE_DATA, constbufferHandle);
}
return constbufferHandle;
}
CONSTMAP_HANDLE ConstMap_Clone(CONSTMAP_HANDLE handle)
{
/*Codes_SRS_CONSTMAP_17_038: [ConstMap_Clone returns NULL if parameter handle is NULL.] */
if (handle == NULL)
{
LOG_CONSTMAP_ERROR(CONSTMAP_INVALIDARG);
}
else
{
/*Codes_SRS_CONSTMAP_17_039: [ConstMap_Clone shall increase the internal reference count of the immutable map indicated by parameter handle]*/
/*Codes_SRS_CONSTMAP_17_050: [ConstMap_Clone shall return the non-NULL handle. ]*/
INC_REF(CONSTMAP_HANDLE_DATA, handle);
}
return (handle);
}
struct symbol *
get_symbol(char *name)
{
struct symbol *sym;
int i;
int size = array_size(&symbol_table);
for (i = 0; i < size; ++i) {
sym = *(struct symbol**) array_ref(&symbol_table, i);
if (strcmp(name, sym->value) == 0) {
return sym;
}
}
sym = make_symbol(strdup(name));
INC_REF(&sym->obj);
array_add(&symbol_table, &sym);
return sym;
}
struct vm_context *
clone_context(struct vm_context *ctx)
{
struct codeptr *new_pc = make_codeptr(ctx->pc->base,
ctx->pc->offset);
struct stack *new_stack = make_stack(ctx->stk->size);
int i;
for (i = 0; i < ctx->stk->top; ++i) {
stack_push(new_stack, ctx->stk->elems[i]);
if (ctx->stk->elems[i]) {
INC_REF(ctx->stk->elems[i]);
}
}
struct vm_context *new_ctx;
new_ctx = make_vm_context(new_pc, new_stack, ctx->env);
return new_ctx;
}
MESSAGE_HANDLE Message_Clone(MESSAGE_HANDLE message)
{
if (message == NULL)
{
LogError("invalid arg: message is NULL");
/*Codes_SRS_MESSAGE_02_007: [If messageHandle is NULL then Message_Clone shall return NULL.] */
}
else
{
/*Codes_SRS_MESSAGE_02_008: [Otherwise, Message_Clone shall increment the internal ref count.] */
INC_REF(MESSAGE_HANDLE_DATA, message);
MESSAGE_HANDLE_DATA* messageData = (MESSAGE_HANDLE_DATA*)message;
/*Codes_SRS_MESSAGE_17_001: [Message_Clone shall clone the CONSTMAP handle.]*/
(void)ConstMap_Clone(messageData->properties);
/*Codes_SRS_MESSAGE_17_004: [Message_Clone shall clone the CONSTBUFFER handle]*/
(void)CONSTBUFFER_Clone(messageData->content);
}
/*Codes_SRS_MESSAGE_02_010: [Message_Clone shall return messageHandle.]*/
return message;
}
struct object *
invoke_continuation(struct object *cont, struct object *value,
struct vm_context **ctx)
{
if (cont->type->code != CONTINUATION_TYPE) {
printf("Wrong type for invoke-continuation: %s\n",
cont->type->name);
exit(1);
}
struct vm_context *new_ctx;
new_ctx = container_of(cont, struct vm_context, obj);
struct vm_context *clone = clone_context(new_ctx);
INC_REF(&clone->obj);
/* XXX: */
/* DEC_REF(&(*ctx)->obj); */
*ctx = clone;
return value;
}
struct object *
call_cc(struct object *proc, struct vm_context **ctx)
{
if (proc->type->code != PROCEDURE_TYPE) {
printf("Wrong type for call/cc: %s\n",
proc->type->name);
exit(1);
}
// this is an awful hack. we're using the same call
// instruction that invoked call_cc to invoke the passed procedure
struct vm_context *new_ctx = clone_context(*ctx);
INC_REF(&new_ctx->obj);
struct vm_context *old_ctx = *ctx;
*ctx = new_ctx;
struct pair *args = make_pair(&old_ctx->obj, &NIL->obj);
apply(container_of(proc, struct procedure, obj), args, ctx);
YIELD_OBJ(&args->obj);
return NULL;
}
int
eval_instruction(struct vm_context **ctx)
{
struct symbol *sym;
struct object *value;
struct compound_proc *template;
switch (INS_AT((*ctx)->pc)->op) {
case NONE:
printf("Error: tried to execute a NONE op\n");
exit(1);
break;
case PUSH:
/* printf("PUSH instruction\n"); */
stack_push((*ctx)->stk, INS_AT((*ctx)->pc)->arg);
INC_REF(INS_AT((*ctx)->pc)->arg);
++(*ctx)->pc->offset;
break;
case POP:
/* printf("POP instruction\n"); */
value = stack_pop((*ctx)->stk);
DEC_REF(value);
++(*ctx)->pc->offset;
break;
case LOOKUP:
/* printf("LOOKUP instruction\n"); */
assert(INS_AT((*ctx)->pc)->arg->type->code == SYMBOL_TYPE);
sym = container_of(INS_AT((*ctx)->pc)->arg, struct symbol, obj);
value = env_lookup((*ctx)->env, sym->value);
if (! value) {
char buf[1024];
debug_loc_str(INS_AT((*ctx)->pc)->arg, buf, 1024);
printf("%s: unbound name: %s\n", buf, sym->value);
exit(1);
}
stack_push((*ctx)->stk, value);
INC_REF(value);
++(*ctx)->pc->offset;
break;
case CALL:
case TAILCALL:
/* printf("CALL instruction @ %p\n", *pc); */
eval_call(ctx);
break;
case RET:
value = stack_pop((*ctx)->stk);
struct object *orig_env = stack_pop((*ctx)->stk);
assert(orig_env->type->code == ENVIRONMENT_TYPE);
DEC_REF(orig_env);
struct object *retaddr = stack_pop((*ctx)->stk);
/* printf("RET instruction @ %p to %p\n", *pc, retaddr->cval); */
stack_push((*ctx)->stk, value);
DEC_REF(&(*ctx)->env->obj);
(*ctx)->env = container_of(orig_env, struct environment, obj);
if (retaddr == NULL) {
(*ctx)->pc = NULL;
return 1;
}
assert(retaddr->type->code == CODEPTR_TYPE);
*(*ctx)->pc = *container_of(retaddr, struct codeptr, obj);
/* XXX: */
/* DEC_REF(retaddr); */
break;
case DEFINE:
/* printf("DEFINE instruction\n"); */
value = stack_pop((*ctx)->stk);
assert(INS_AT((*ctx)->pc)->arg->type->code == SYMBOL_TYPE);
sym = container_of(INS_AT((*ctx)->pc)->arg, struct symbol, obj);
env_define((*ctx)->env, sym->value, value);
DEC_REF(value);
++(*ctx)->pc->offset;
break;
case SET:
value = stack_pop((*ctx)->stk);
assert(INS_AT((*ctx)->pc)->arg->type->code == SYMBOL_TYPE);
sym = container_of(INS_AT((*ctx)->pc)->arg, struct symbol, obj);
env_set((*ctx)->env, sym->value, value);
DEC_REF(value);
++(*ctx)->pc->offset;
break;
case LAMBDA:
/* printf("LAMBDA instruction\n"); */
value = INS_AT((*ctx)->pc)->arg;
assert(INS_AT((*ctx)->pc)->arg->type->code == PROCEDURE_TYPE);