added some code for executing byte codes
This commit is contained in:
parent
bdfc72d48d
commit
badf66c9d4
45
lib/comp.c
45
lib/comp.c
@ -32,6 +32,7 @@ enum
|
||||
VAR_INDEXED
|
||||
};
|
||||
|
||||
#define CODE_BUFFER_ALIGN 1024 /* TODO: set a bigger value */
|
||||
#define TV_BUFFER_ALIGN 256
|
||||
#define BLK_TMPRCNT_BUFFER_ALIGN 128
|
||||
|
||||
@ -154,27 +155,38 @@ static int store_temporary_variable_count_for_block (hcl_t* hcl, hcl_oow_t tmpr_
|
||||
static HCL_INLINE void patch_instruction (hcl_t* hcl, hcl_oow_t index, hcl_oob_t bc)
|
||||
{
|
||||
HCL_ASSERT (index < hcl->code.bc.len);
|
||||
((hcl_oop_byte_t)hcl->code.bc.arr)->slot[index] = bc;
|
||||
hcl->code.bc.arr->slot[index] = bc;
|
||||
}
|
||||
|
||||
static int emit_byte_instruction (hcl_t* hcl, hcl_oob_t bc)
|
||||
{
|
||||
hcl_oow_t capa;
|
||||
|
||||
/* the context object has the ip field. it should be representable
|
||||
* in a small integer. for simplicity, limit the total byte code length
|
||||
* to fit in a small integer. because 'ip' points to the next instruction
|
||||
* to execute, he upper bound should be (max - 1) so that i stays
|
||||
* at the max when incremented */
|
||||
if (hcl->code.bc.len == HCL_SMOOI_MAX - 1)
|
||||
{
|
||||
hcl->errnum = HCL_EBCFULL; /* byte code full/too big */
|
||||
return -1;
|
||||
}
|
||||
|
||||
capa = HCL_OBJ_GET_SIZE(hcl->code.bc.arr);
|
||||
if (hcl->code.bc.len >= capa)
|
||||
{
|
||||
hcl_oop_t tmp;
|
||||
hcl_oow_t newcapa;
|
||||
|
||||
newcapa = capa + 20000; /* TODO: set a better resizing policy */
|
||||
tmp = hcl_remakengcbytearray (hcl, hcl->code.bc.arr, newcapa);
|
||||
newcapa = HCL_ALIGN (capa + 1, CODE_BUFFER_ALIGN);
|
||||
tmp = hcl_remakengcbytearray (hcl, (hcl_oop_t)hcl->code.bc.arr, newcapa);
|
||||
if (!tmp) return -1;
|
||||
|
||||
hcl->code.bc.arr = tmp;
|
||||
hcl->code.bc.arr = (hcl_oop_byte_t)tmp;
|
||||
}
|
||||
|
||||
((hcl_oop_byte_t)hcl->code.bc.arr)->slot[hcl->code.bc.len++] = bc;
|
||||
hcl->code.bc.arr->slot[hcl->code.bc.len++] = bc;
|
||||
return 0;
|
||||
}
|
||||
|
||||
@ -920,9 +932,18 @@ static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_oop_t obj)
|
||||
/* check if a symbol is a local variable */
|
||||
if (find_temporary_variable_backward (hcl, obj, &index) <= -1)
|
||||
{
|
||||
hcl_oop_t cons;
|
||||
/* TODO: if i require all variables to be declared, this part is not needed and should handle it as an error */
|
||||
/* TODO: change the scheme... allow declaration??? */
|
||||
/* global variable */
|
||||
if (add_literal(hcl, obj, &index) <= -1 ||
|
||||
cons = (hcl_oop_t)hcl_getatsysdic (hcl, obj);
|
||||
if (!cons)
|
||||
{
|
||||
cons = (hcl_oop_t)hcl_putatsysdic (hcl, obj, hcl->_nil);
|
||||
if (!cons) return -1;
|
||||
}
|
||||
|
||||
if (add_literal(hcl, cons, &index) <= -1 ||
|
||||
emit_single_param_instruction (hcl, HCL_CODE_PUSH_OBJECT_0, index) <= -1) return -1;
|
||||
|
||||
return 0;
|
||||
@ -1053,9 +1074,11 @@ static HCL_INLINE int emit_lambda (hcl_t* hcl)
|
||||
/* no body in lambda - (lambda (a b c)) */
|
||||
/* TODO: is this correct??? */
|
||||
if (emit_byte_instruction(hcl, HCL_CODE_PUSH_NIL) <= -1) return -1;
|
||||
block_code_size++;
|
||||
}
|
||||
|
||||
if (emit_byte_instruction (hcl, HCL_CODE_RETURN_FROM_BLOCK) <= -1) return -1;
|
||||
block_code_size++;
|
||||
|
||||
if (block_code_size > MAX_CODE_JUMP * 2)
|
||||
{
|
||||
@ -1132,10 +1155,18 @@ static HCL_INLINE int emit_set (hcl_t* hcl)
|
||||
if (cf->u.set.var_type == VAR_NAMED)
|
||||
{
|
||||
hcl_oow_t index;
|
||||
hcl_oop_t cons;
|
||||
|
||||
HCL_ASSERT (HCL_IS_SYMBOL(hcl, cf->operand));
|
||||
|
||||
if (add_literal(hcl, cf->operand, &index) <= -1 ||
|
||||
cons = (hcl_oop_t)hcl_getatsysdic (hcl, cf->operand);
|
||||
if (!cons)
|
||||
{
|
||||
cons = (hcl_oop_t)hcl_putatsysdic (hcl, cf->operand, hcl->_nil);
|
||||
if (!cons) return -1;
|
||||
}
|
||||
|
||||
if (add_literal(hcl, cons, &index) <= -1 ||
|
||||
emit_single_param_instruction(hcl, HCL_CODE_STORE_INTO_OBJECT_0, index) <= -1) return -1;
|
||||
}
|
||||
else
|
||||
|
||||
70
lib/decode.c
70
lib/decode.c
@ -47,15 +47,18 @@
|
||||
#endif
|
||||
|
||||
/* TODO: check if ip shoots beyond the maximum length in fetching code and parameters */
|
||||
int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
|
||||
int hcl_decode (hcl_t* hcl, hcl_ooi_t start, hcl_ooi_t end)
|
||||
{
|
||||
hcl_oob_t bcode, * cdptr;
|
||||
hcl_oow_t ip = start;
|
||||
hcl_ooi_t b1, b2;
|
||||
hcl_ooi_t ip = start;
|
||||
hcl_oow_t b1, b2;
|
||||
|
||||
/* the instruction at the offset 'end' is not decoded.
|
||||
* decoding offset range is from start to end - 1. */
|
||||
HCL_ASSERT (end <= hcl->code.bc.len);
|
||||
|
||||
HCL_ASSERT (start >= 0 && end >= 0);
|
||||
HCL_ASSERT (hcl->code.bc.len < HCL_SMOOI_MAX); /* asserted by the compiler */
|
||||
HCL_ASSERT (end <= hcl->code.bc.len); /* not harmful though this fails */
|
||||
|
||||
ip = start;
|
||||
cdptr = ((hcl_oop_byte_t)hcl->code.bc.arr)->slot;
|
||||
@ -80,7 +83,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
|
||||
case BCODE_PUSH_INSTVAR_7:
|
||||
b1 = bcode & 0x7; /* low 3 bits */
|
||||
push_instvar:
|
||||
LOG_INST_1 (hcl, "push_instvar %zd", b1);
|
||||
LOG_INST_1 (hcl, "push_instvar %zu", b1);
|
||||
break;
|
||||
|
||||
/* ------------------------------------------------- */
|
||||
@ -98,7 +101,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
|
||||
case BCODE_STORE_INTO_INSTVAR_7:
|
||||
b1 = bcode & 0x7; /* low 3 bits */
|
||||
store_instvar:
|
||||
LOG_INST_1 (hcl, "store_into_instvar %zd", b1);
|
||||
LOG_INST_1 (hcl, "store_into_instvar %zu", b1);
|
||||
break;
|
||||
|
||||
case BCODE_POP_INTO_INSTVAR_X:
|
||||
@ -114,7 +117,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
|
||||
case BCODE_POP_INTO_INSTVAR_7:
|
||||
b1 = bcode & 0x7; /* low 3 bits */
|
||||
pop_into_instvar:
|
||||
LOG_INST_1 (hcl, "pop_into_instvar %zd", b1);
|
||||
LOG_INST_1 (hcl, "pop_into_instvar %zu", b1);
|
||||
break;
|
||||
|
||||
/* ------------------------------------------------- */
|
||||
@ -154,7 +157,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
|
||||
if ((bcode >> 4) & 1)
|
||||
{
|
||||
/* push - bit 4 on */
|
||||
LOG_INST_1 (hcl, "push_tempvar %zd", b1);
|
||||
LOG_INST_1 (hcl, "push_tempvar %zu", b1);
|
||||
}
|
||||
else
|
||||
{
|
||||
@ -162,11 +165,11 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
|
||||
if ((bcode >> 3) & 1)
|
||||
{
|
||||
/* pop - bit 3 on */
|
||||
LOG_INST_1 (hcl, "pop_into_tempvar %zd", b1);
|
||||
LOG_INST_1 (hcl, "pop_into_tempvar %zu", b1);
|
||||
}
|
||||
else
|
||||
{
|
||||
LOG_INST_1 (hcl, "store_into_tempvar %zd", b1);
|
||||
LOG_INST_1 (hcl, "store_into_tempvar %zu", b1);
|
||||
}
|
||||
}
|
||||
break;
|
||||
@ -196,7 +199,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
|
||||
case HCL_CODE_PUSH_LITERAL_7:
|
||||
b1 = bcode & 0x7; /* low 3 bits */
|
||||
push_literal:
|
||||
LOG_INST_1 (hcl, "push_literal @%zd", b1);
|
||||
LOG_INST_1 (hcl, "push_literal @%zu", b1);
|
||||
break;
|
||||
|
||||
/* ------------------------------------------------- */
|
||||
@ -224,16 +227,16 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
|
||||
{
|
||||
if ((bcode >> 2) & 1)
|
||||
{
|
||||
LOG_INST_1 (hcl, "pop_into_object @%zd", b1);
|
||||
LOG_INST_1 (hcl, "pop_into_object @%zu", b1);
|
||||
}
|
||||
else
|
||||
{
|
||||
LOG_INST_1 (hcl, "store_into_object @%zd", b1);
|
||||
LOG_INST_1 (hcl, "store_into_object @%zu", b1);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
LOG_INST_1 (hcl, "push_object @%zd", b1);
|
||||
LOG_INST_1 (hcl, "push_object @%zu", b1);
|
||||
}
|
||||
break;
|
||||
|
||||
@ -241,19 +244,19 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
|
||||
|
||||
case HCL_CODE_JUMP_FORWARD_X:
|
||||
FETCH_PARAM_CODE_TO (hcl, b1);
|
||||
LOG_INST_1 (hcl, "jump_forward %zd", b1);
|
||||
LOG_INST_1 (hcl, "jump_forward %zu", b1);
|
||||
break;
|
||||
|
||||
case HCL_CODE_JUMP_FORWARD_0:
|
||||
case HCL_CODE_JUMP_FORWARD_1:
|
||||
case HCL_CODE_JUMP_FORWARD_2:
|
||||
case HCL_CODE_JUMP_FORWARD_3:
|
||||
LOG_INST_1 (hcl, "jump_forward %zd", (bcode & 0x3)); /* low 2 bits */
|
||||
LOG_INST_1 (hcl, "jump_forward %zu", (hcl_oow_t)(bcode & 0x3)); /* low 2 bits */
|
||||
break;
|
||||
|
||||
case HCL_CODE_JUMP_BACKWARD_X:
|
||||
FETCH_PARAM_CODE_TO (hcl, b1);
|
||||
LOG_INST_1 (hcl, "jump_backward %zd", b1);
|
||||
LOG_INST_1 (hcl, "jump_backward %zu", b1);
|
||||
hcl->ip += b1;
|
||||
break;
|
||||
|
||||
@ -261,7 +264,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
|
||||
case HCL_CODE_JUMP_BACKWARD_1:
|
||||
case HCL_CODE_JUMP_BACKWARD_2:
|
||||
case HCL_CODE_JUMP_BACKWARD_3:
|
||||
LOG_INST_1 (hcl, "jump_backward %zd", (bcode & 0x3)); /* low 2 bits */
|
||||
LOG_INST_1 (hcl, "jump_backward %zu", (hcl_oow_t)(bcode & 0x3)); /* low 2 bits */
|
||||
break;
|
||||
|
||||
case BCODE_JUMP_IF_TRUE_X:
|
||||
@ -280,12 +283,12 @@ return -1;
|
||||
|
||||
case HCL_CODE_JUMP2_FORWARD:
|
||||
FETCH_PARAM_CODE_TO (hcl, b1);
|
||||
LOG_INST_1 (hcl, "jump2_forward %zd", b1);
|
||||
LOG_INST_1 (hcl, "jump2_forward %zu", b1);
|
||||
break;
|
||||
|
||||
case HCL_CODE_JUMP2_BACKWARD:
|
||||
FETCH_PARAM_CODE_TO (hcl, b1);
|
||||
LOG_INST_1 (hcl, "jump2_backward %zd", b1);
|
||||
LOG_INST_1 (hcl, "jump2_backward %zu", b1);
|
||||
break;
|
||||
|
||||
/* -------------------------------------------------------- */
|
||||
@ -300,7 +303,7 @@ return -1;
|
||||
case HCL_CODE_CALL_3:
|
||||
b1 = bcode & 0x3; /* low 2 bits */
|
||||
handle_call:
|
||||
LOG_INST_1 (hcl, "call %zd", b1);
|
||||
LOG_INST_1 (hcl, "call %zu", b1);
|
||||
break;
|
||||
|
||||
/* -------------------------------------------------------- */
|
||||
@ -333,17 +336,17 @@ return -1;
|
||||
|
||||
if ((bcode >> 2) & 1)
|
||||
{
|
||||
LOG_INST_2 (hcl, "pop_into_ctxtempvar %zd %zd", b1, b2);
|
||||
LOG_INST_2 (hcl, "pop_into_ctxtempvar %zu %zu", b1, b2);
|
||||
}
|
||||
else
|
||||
{
|
||||
LOG_INST_2 (hcl, "store_into_ctxtempvar %zd %zd", b1, b2);
|
||||
LOG_INST_2 (hcl, "store_into_ctxtempvar %zu %zu", b1, b2);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
/* push */
|
||||
LOG_INST_2 (hcl, "push_ctxtempvar %zd %zd", b1, b2);
|
||||
LOG_INST_2 (hcl, "push_ctxtempvar %zu %zu", b1, b2);
|
||||
}
|
||||
|
||||
break;
|
||||
@ -379,16 +382,16 @@ return -1;
|
||||
/* store or pop */
|
||||
if ((bcode >> 2) & 1)
|
||||
{
|
||||
LOG_INST_2 (hcl, "pop_into_objvar %zd %zd", b1, b2);
|
||||
LOG_INST_2 (hcl, "pop_into_objvar %zu %zu", b1, b2);
|
||||
}
|
||||
else
|
||||
{
|
||||
LOG_INST_2 (hcl, "store_into_objvar %zd %zd", b1, b2);
|
||||
LOG_INST_2 (hcl, "store_into_objvar %zu %zu", b1, b2);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
LOG_INST_2 (hcl, "push_objvar %zd %zd", b1, b2);
|
||||
LOG_INST_2 (hcl, "push_objvar %zu %zu", b1, b2);
|
||||
}
|
||||
|
||||
break;
|
||||
@ -414,7 +417,7 @@ return -1;
|
||||
FETCH_BYTE_CODE_TO (hcl, b2);
|
||||
|
||||
handle_send_message:
|
||||
LOG_INST_3 (hcl, "send_message%hs %zd @%zd", (((bcode >> 2) & 1)? "_to_super": ""), b1, b2);
|
||||
LOG_INST_3 (hcl, "send_message%hs %zu @%zu", (((bcode >> 2) & 1)? "_to_super": ""), b1, b2);
|
||||
break;
|
||||
|
||||
/* -------------------------------------------------------- */
|
||||
@ -461,17 +464,17 @@ return -1;
|
||||
|
||||
case HCL_CODE_PUSH_INTLIT:
|
||||
FETCH_PARAM_CODE_TO (hcl, b1);
|
||||
LOG_INST_1 (hcl, "push_intlit %zd", b1);
|
||||
LOG_INST_1 (hcl, "push_intlit %zu", b1);
|
||||
break;
|
||||
|
||||
case HCL_CODE_PUSH_NEGINTLIT:
|
||||
FETCH_PARAM_CODE_TO (hcl, b1);
|
||||
LOG_INST_1 (hcl, "push_negintlit %zd", -b1);
|
||||
LOG_INST_1 (hcl, "push_negintlit %zu", b1);
|
||||
break;
|
||||
|
||||
case HCL_CODE_PUSH_CHARLIT:
|
||||
FETCH_PARAM_CODE_TO (hcl, b1);
|
||||
LOG_INST_1 (hcl, "push_charlit %zd", b1);
|
||||
LOG_INST_1 (hcl, "push_charlit %zu", b1);
|
||||
break;
|
||||
/* -------------------------------------------------------- */
|
||||
|
||||
@ -501,7 +504,7 @@ return -1;
|
||||
FETCH_PARAM_CODE_TO (hcl, b1);
|
||||
FETCH_PARAM_CODE_TO (hcl, b2);
|
||||
|
||||
LOG_INST_2 (hcl, "make_block %zd %zd", b1, b2);
|
||||
LOG_INST_2 (hcl, "make_block %zu %zu", b1, b2);
|
||||
|
||||
HCL_ASSERT (b1 >= 0);
|
||||
HCL_ASSERT (b2 >= b1);
|
||||
@ -520,14 +523,13 @@ return -1;
|
||||
LOG_INST_1 (hcl, "UNKNOWN BYTE CODE ENCOUNTERED %x", (int)bcode);
|
||||
hcl->errnum = HCL_EINTERN;
|
||||
break;
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
/* print literal frame contents */
|
||||
for (ip = 0; ip < hcl->code.lit.len; ip++)
|
||||
{
|
||||
LOG_INST_2 (hcl, " @%-3lu %O", (unsigned long int)ip, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[ip]);
|
||||
LOG_INST_2 (hcl, " @%-3zd %O", ip, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[ip]);
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
@ -94,9 +94,9 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_set_t dic, hcl_oop_cha
|
||||
|
||||
/* the system dictionary is not a generic dictionary.
|
||||
* it accepts only a symbol as a key. */
|
||||
HCL_ASSERT (HCL_BRANDOF(hcl,key) == HCL_BRAND_SYMBOL);
|
||||
HCL_ASSERT (HCL_IS_SYMBOL(hcl,key));
|
||||
HCL_ASSERT (HCL_OOP_IS_SMOOI(dic->tally));
|
||||
HCL_ASSERT (HCL_BRANDOF(hcl,dic->bucket) == HCL_BRAND_INTEGER);
|
||||
HCL_ASSERT (HCL_IS_ARRAY(hcl,dic->bucket));
|
||||
|
||||
index = hcl_hashchars(key->slot, HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket);
|
||||
|
||||
@ -225,13 +225,13 @@ static hcl_oop_cons_t lookup (hcl_t* hcl, hcl_oop_set_t dic, const hcl_oocs_t* n
|
||||
|
||||
hcl_oop_cons_t hcl_putatsysdic (hcl_t* hcl, hcl_oop_t key, hcl_oop_t value)
|
||||
{
|
||||
HCL_ASSERT (HCL_BRANDOF(hcl,key) == HCL_BRAND_SYMBOL);
|
||||
HCL_ASSERT (HCL_IS_SYMBOL(hcl,key));
|
||||
return find_or_upsert (hcl, hcl->sysdic, (hcl_oop_char_t)key, value);
|
||||
}
|
||||
|
||||
hcl_oop_cons_t hcl_getatsysdic (hcl_t* hcl, hcl_oop_t key)
|
||||
{
|
||||
HCL_ASSERT (HCL_BRANDOF(hcl,key) == HCL_BRAND_SYMBOL);
|
||||
HCL_ASSERT (HCL_IS_SYMBOL(hcl,key));
|
||||
return find_or_upsert (hcl, hcl->sysdic, (hcl_oop_char_t)key, HCL_NULL);
|
||||
}
|
||||
|
||||
|
||||
2220
lib/exec.c
2220
lib/exec.c
File diff suppressed because it is too large
Load Diff
66
lib/gc.c
66
lib/gc.c
@ -285,9 +285,10 @@ void hcl_gc (hcl_t* hcl)
|
||||
|
||||
if (hcl->active_context)
|
||||
{
|
||||
/*HCL_ASSERT ((hcl_oop_t)hcl->processor != hcl->_nil);
|
||||
if ((hcl_oop_t)hcl->processor->active != hcl->_nil)*/
|
||||
hcl->processor->active->sp = HCL_SMOOI_TO_OOP(hcl->sp);
|
||||
HCL_ASSERT ((hcl_oop_t)hcl->processor != hcl->_nil);
|
||||
HCL_ASSERT ((hcl_oop_t)hcl->processor->active != hcl->_nil);
|
||||
/* store the stack pointer to the active process */
|
||||
hcl->processor->active->sp = HCL_SMOOI_TO_OOP(hcl->sp);
|
||||
|
||||
/* store the instruction pointer to the active context */
|
||||
hcl->active_context->ip = HCL_SMOOI_TO_OOP(hcl->ip);
|
||||
@ -347,10 +348,10 @@ void hcl_gc (hcl_t* hcl)
|
||||
*hcl->tmp_stack[i] = hcl_moveoop (hcl, *hcl->tmp_stack[i]);
|
||||
}
|
||||
|
||||
if (hcl->initial_context)
|
||||
hcl->initial_context = (hcl_oop_context_t)hcl_moveoop (hcl, (hcl_oop_t)hcl->initial_context);
|
||||
if (hcl->active_context)
|
||||
hcl->active_context = (hcl_oop_context_t)hcl_moveoop (hcl, (hcl_oop_t)hcl->active_context);
|
||||
if (hcl->active_method)
|
||||
hcl->active_method = (hcl_oop_method_t)hcl_moveoop (hcl, (hcl_oop_t)hcl->active_method);
|
||||
|
||||
for (cb = hcl->cblist; cb; cb = cb->next)
|
||||
{
|
||||
@ -385,26 +386,29 @@ void hcl_gc (hcl_t* hcl)
|
||||
hcl->curheap = hcl->newheap;
|
||||
hcl->newheap = tmp;
|
||||
|
||||
|
||||
/*
|
||||
{
|
||||
hcl_oow_t index;
|
||||
hcl_oop_oop_t buc;
|
||||
printf ("=== SURVIVING SYMBOLS ===\n");
|
||||
buc = (hcl_oop_oop_t) hcl->symtab->slot[HCL_SYMTAB_BUCKET];
|
||||
for (index = 0; index < buc->size; index++)
|
||||
{
|
||||
if ((hcl_oop_t)buc->slot[index] != hcl->_nil)
|
||||
if (hcl->symtab && HCL_LOG_ENABLED(hcl, HCL_LOG_GC | HCL_LOG_DEBUG))
|
||||
{
|
||||
const hcl_oop_char_t* p = ((hcl_oop_char_t)buc->slot[index])->slot;
|
||||
printf ("SYM [");
|
||||
while (*p) printf ("%c", *p++);
|
||||
printf ("]\n");
|
||||
hcl_oow_t index;
|
||||
hcl_oop_oop_t buc;
|
||||
HCL_LOG0 (hcl, HCL_LOG_GC | HCL_LOG_DEBUG, "--------- SURVIVING SYMBOLS IN GC ----------\n");
|
||||
buc = (hcl_oop_oop_t) hcl->symtab->bucket;
|
||||
for (index = 0; index < HCL_OBJ_GET_SIZE(buc); index++)
|
||||
{
|
||||
if ((hcl_oop_t)buc->slot[index] != hcl->_nil)
|
||||
{
|
||||
HCL_LOG1 (hcl, HCL_LOG_GC | HCL_LOG_DEBUG, "\t%O\n", buc->slot[index]);
|
||||
}
|
||||
}
|
||||
HCL_LOG0 (hcl, HCL_LOG_GC | HCL_LOG_DEBUG, "--------------------------------------------\n");
|
||||
}
|
||||
}
|
||||
printf ("===========================\n");
|
||||
}
|
||||
*/
|
||||
if (hcl->active_method) SET_ACTIVE_METHOD_CODE (hcl); /* update hcl->active_code */
|
||||
|
||||
/* TODO: include some gc statstics like number of live objects, gc performance, etc */
|
||||
HCL_LOG4 (hcl, HCL_LOG_GC | HCL_LOG_INFO,
|
||||
"Finished GC curheap base %p ptr %p newheap base %p ptr %p\n",
|
||||
hcl->curheap->base, hcl->curheap->ptr, hcl->newheap->base, hcl->newheap->ptr);
|
||||
}
|
||||
|
||||
|
||||
@ -496,6 +500,24 @@ int hcl_ignite (hcl_t* hcl)
|
||||
*(hcl_oop_t*)((hcl_uint8_t*)hcl + syminfo[i].offset) = tmp;
|
||||
}
|
||||
|
||||
|
||||
if (!hcl->nil_process)
|
||||
{
|
||||
/* Create a nil process used to simplify nil check in GC.
|
||||
* only accessible by VM. not exported via the global dictionary. */
|
||||
hcl->nil_process = (hcl_oop_process_t)hcl_allocoopobj (hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS);
|
||||
if (!hcl->nil_process) return -1;
|
||||
hcl->nil_process->sp = HCL_SMOOI_TO_OOP(-1);
|
||||
}
|
||||
|
||||
if (!hcl->processor)
|
||||
{
|
||||
hcl->processor = (hcl_oop_process_scheduler_t)hcl_allocoopobj (hcl, HCL_BRAND_PROCESS_SCHEDULER, HCL_PROCESS_SCHEDULER_NAMED_INSTVARS);
|
||||
if (!hcl->processor) return -1;
|
||||
hcl->processor->tally = HCL_SMOOI_TO_OOP(0);
|
||||
hcl->processor->active = hcl->nil_process;
|
||||
}
|
||||
|
||||
if (!hcl->code.bc.arr)
|
||||
{
|
||||
hcl->code.bc.arr = hcl_makengcbytearray (hcl, HCL_NULL, 20000); /* TODO: set a proper intial size */
|
||||
@ -504,7 +526,7 @@ int hcl_ignite (hcl_t* hcl)
|
||||
|
||||
if (!hcl->code.lit.arr)
|
||||
{
|
||||
hcl->code.lit.arr = hcl_makengcarray (hcl, 20000); /* TOOD: set a proper initial size */
|
||||
hcl->code.lit.arr = (hcl_oop_oop_t)hcl_makengcarray (hcl, 20000); /* TOOD: set a proper initial size */
|
||||
if (!hcl->code.lit.arr) return -1;
|
||||
}
|
||||
|
||||
|
||||
@ -447,7 +447,6 @@ struct hcl_ntime_t
|
||||
#define HCL_ORBITS(type,value,offset,length,bits) \
|
||||
(value = (((type)(value)) | (((bits) & HCL_LBMASK(type,length)) << (offset))))
|
||||
|
||||
|
||||
/**
|
||||
* The HCL_BITS_MAX() macros calculates the maximum value that the 'nbits'
|
||||
* bits of an unsigned integer of the given 'type' can hold.
|
||||
|
||||
@ -52,7 +52,7 @@
|
||||
/* this is for gc debugging */
|
||||
/*#define HCL_DEBUG_PROCESSOR*/
|
||||
#define HCL_DEBUG_GC
|
||||
|
||||
#define HCL_DEBUG_VM_EXEC
|
||||
|
||||
/* limit the maximum object size such that:
|
||||
* 1. an index to an object field can be represented in a small integer.
|
||||
@ -377,16 +377,8 @@ struct hcl_compiler_t
|
||||
hcl_oow_t tmprcnt_capa;
|
||||
} blk; /* lambda block */
|
||||
};
|
||||
|
||||
#endif
|
||||
|
||||
#if defined(HCL_USE_OBJECT_TRAILER)
|
||||
/* let it point to the trailer of the method */
|
||||
# define SET_ACTIVE_METHOD_CODE(hcl) ((hcl)->active_code = (hcl_oob_t*)&(hcl)->active_method->slot[HCL_OBJ_GET_SIZE((hcl)->active_method) + 1 - HCL_METHOD_NAMED_INSTVARS])
|
||||
#else
|
||||
/* let it point to the payload of the code byte array */
|
||||
# define SET_ACTIVE_METHOD_CODE(hcl) ((hcl)->active_code = (hcl)->active_method->code->slot)
|
||||
#endif
|
||||
|
||||
#if defined(HCL_BCODE_LONG_PARAM_SIZE) && (HCL_BCODE_LONG_PARAM_SIZE == 1)
|
||||
# define MAX_CODE_INDEX (0xFFu)
|
||||
@ -757,6 +749,7 @@ void* hcl_allocbytes (
|
||||
*/
|
||||
hcl_oop_t hcl_allocoopobj (
|
||||
hcl_t* hcl,
|
||||
int brand,
|
||||
hcl_oow_t size
|
||||
);
|
||||
|
||||
@ -771,24 +764,28 @@ hcl_oop_t hcl_allocoopobjwithtrailer (
|
||||
|
||||
hcl_oop_t hcl_alloccharobj (
|
||||
hcl_t* hcl,
|
||||
int brand,
|
||||
const hcl_ooch_t* ptr,
|
||||
hcl_oow_t len
|
||||
);
|
||||
|
||||
hcl_oop_t hcl_allocbyteobj (
|
||||
hcl_t* hcl,
|
||||
const hcl_oob_t* ptr,
|
||||
hcl_oow_t len
|
||||
hcl_t* hcl,
|
||||
int brand,
|
||||
const hcl_oob_t* ptr,
|
||||
hcl_oow_t len
|
||||
);
|
||||
|
||||
hcl_oop_t hcl_allochalfwordobj (
|
||||
hcl_t* hcl,
|
||||
int brand,
|
||||
const hcl_oohw_t* ptr,
|
||||
hcl_oow_t len
|
||||
);
|
||||
|
||||
hcl_oop_t hcl_allocwordobj (
|
||||
hcl_t* hcl,
|
||||
int brand,
|
||||
const hcl_oow_t* ptr,
|
||||
hcl_oow_t len
|
||||
);
|
||||
|
||||
66
lib/hcl.h
66
lib/hcl.h
@ -53,6 +53,7 @@ enum hcl_errnum_t
|
||||
HCL_ERANGE, /**< range error. overflow and underflow */
|
||||
HCL_ENOENT, /**< no matching entry */
|
||||
HCL_EEXIST, /**< duplicate entry */
|
||||
HCL_EBCFULL, /**< byte-code full */
|
||||
HCL_EDFULL, /**< dictionary full */
|
||||
HCL_EPFULL, /**< processor full */
|
||||
HCL_ESHFULL, /**< semaphore heap full */
|
||||
@ -597,11 +598,11 @@ struct hcl_context_t
|
||||
};
|
||||
|
||||
|
||||
#define HCL_PROCESS_NAMED_INSTVARS 7
|
||||
#define HCL_PROCESS_NAMED_INSTVARS 7 /* TODO: RENAME THIS TO SOMETHING ELSE */
|
||||
typedef struct hcl_process_t hcl_process_t;
|
||||
typedef struct hcl_process_t* hcl_oop_process_t;
|
||||
|
||||
#define HCL_SEMAPHORE_NAMED_INSTVARS 6
|
||||
#define HCL_SEMAPHORE_NAMED_INSTVARS 6 /* TODO: RENAME THIS TO SOMETHIGN ELSE */
|
||||
typedef struct hcl_semaphore_t hcl_semaphore_t;
|
||||
typedef struct hcl_semaphore_t* hcl_oop_semaphore_t;
|
||||
|
||||
@ -938,12 +939,13 @@ struct hcl_t
|
||||
hcl_oow_t tmp_count;
|
||||
|
||||
/* == EXECUTION REGISTERS == */
|
||||
hcl_oop_context_t initial_context; /* fake initial context */
|
||||
hcl_oop_context_t active_context;
|
||||
hcl_oop_method_t active_method;
|
||||
hcl_oob_t* active_code;
|
||||
hcl_ooi_t sp;
|
||||
hcl_ooi_t ip;
|
||||
int proc_switched; /* TODO: this is temporary. implement something else to skip immediate context switching */
|
||||
int switch_proc;
|
||||
hcl_ntime_t vm_time_offset;
|
||||
/* == END EXECUTION REGISTERS == */
|
||||
|
||||
/* == BIGINT CONVERSION == */
|
||||
@ -958,13 +960,13 @@ struct hcl_t
|
||||
{
|
||||
struct
|
||||
{
|
||||
hcl_oop_t arr; /* byte code array - not part of object memory */
|
||||
hcl_oop_byte_t arr; /* byte code array - not part of object memory */
|
||||
hcl_oow_t len;
|
||||
} bc;
|
||||
|
||||
struct
|
||||
{
|
||||
hcl_oop_t arr; /* literal array - not part of object memory */
|
||||
hcl_oop_oop_t arr; /* literal array - not part of object memory */
|
||||
hcl_oow_t len;
|
||||
} lit;
|
||||
} code;
|
||||
@ -987,6 +989,33 @@ struct hcl_t
|
||||
#endif
|
||||
};
|
||||
|
||||
|
||||
/* TODO: stack bound check when pushing */
|
||||
#define HCL_STACK_PUSH(hcl,v) \
|
||||
do { \
|
||||
(hcl)->sp = (hcl)->sp + 1; \
|
||||
(hcl)->processor->active->slot[(hcl)->sp] = v; \
|
||||
} while (0)
|
||||
|
||||
#define HCL_STACK_GET(hcl,v_sp) ((hcl)->processor->active->slot[v_sp])
|
||||
#define HCL_STACK_SET(hcl,v_sp,v_obj) ((hcl)->processor->active->slot[v_sp] = v_obj)
|
||||
|
||||
#define HCL_STACK_GETTOP(hcl) HCL_STACK_GET(hcl, (hcl)->sp)
|
||||
#define HCL_STACK_SETTOP(hcl,v_obj) HCL_STACK_SET(hcl, (hcl)->sp, v_obj)
|
||||
|
||||
#define HCL_STACK_POP(hcl) ((hcl)->sp = (hcl)->sp - 1)
|
||||
#define HCL_STACK_POPS(hcl,count) ((hcl)->sp = (hcl)->sp - (count))
|
||||
#define HCL_STACK_ISEMPTY(hcl) ((hcl)->sp <= -1)
|
||||
|
||||
#define HCL_STACK_GETARG(hcl,nargs,idx) HCL_STACK_GET(hcl, (hcl)->sp - ((nargs) - (idx) - 1))
|
||||
#define HCL_STACK_GETRCV(hcl,nargs) HCL_STACK_GET(hcl, (hcl)->sp - nargs);
|
||||
|
||||
/* you can't access arguments and receiver after this macro.
|
||||
* also you must not call this macro more than once */
|
||||
#define HCL_STACK_SETRET(hcl,nargs,retv) (HCL_STACK_POPS(hcl, nargs), HCL_STACK_SETTOP(hcl, retv))
|
||||
#define HCL_STACK_SETRETTORCV(hcl,nargs) (HCL_STACK_POPS(hcl, nargs))
|
||||
|
||||
|
||||
/* =========================================================================
|
||||
* HCL VM LOGGING
|
||||
* ========================================================================= */
|
||||
@ -1036,7 +1065,7 @@ typedef enum hcl_log_mask_t hcl_log_mask_t;
|
||||
* ========================================================================= */
|
||||
enum
|
||||
{
|
||||
HCL_BRAND_NIL,
|
||||
HCL_BRAND_NIL = 1,
|
||||
HCL_BRAND_TRUE,
|
||||
HCL_BRAND_FALSE,
|
||||
HCL_BRAND_CHARACTER,
|
||||
@ -1049,10 +1078,12 @@ enum
|
||||
HCL_BRAND_STRING,
|
||||
HCL_BRAND_SET,
|
||||
|
||||
HCL_BRAND_ENVIRONMENT,
|
||||
HCL_BRAND_CFRAME,/* compiler frame */
|
||||
|
||||
HCL_BRAND_PROCESS
|
||||
HCL_BRAND_CONTEXT,
|
||||
HCL_BRAND_PROCESS,
|
||||
HCL_BRAND_PROCESS_SCHEDULER,
|
||||
HCL_BRAND_SEMAPHORE
|
||||
};
|
||||
|
||||
enum
|
||||
@ -1078,7 +1109,10 @@ typedef struct hcl_cons_t* hcl_oop_cons_t;
|
||||
#define HCL_IS_NIL(hcl,v) (v == (hcl)->_nil)
|
||||
#define HCL_IS_SYMBOL(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL)
|
||||
#define HCL_IS_SYMBOL_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL_ARRAY)
|
||||
#define HCL_IS_CONTEXT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONTEXT)
|
||||
#define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS)
|
||||
#define HCL_IS_CONS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONS)
|
||||
#define HCL_IS_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_ARRAY)
|
||||
|
||||
#define HCL_CONS_CAR(v) (((hcl_cons_t*)(v))->car)
|
||||
#define HCL_CONS_CDR(v) (((hcl_cons_t*)(v))->cdr)
|
||||
@ -1266,8 +1300,8 @@ HCL_EXPORT void hcl_poptmps (
|
||||
|
||||
HCL_EXPORT int hcl_decode (
|
||||
hcl_t* hcl,
|
||||
hcl_oow_t start,
|
||||
hcl_oow_t end
|
||||
hcl_ooi_t start,
|
||||
hcl_ooi_t end
|
||||
);
|
||||
|
||||
/* Syntax error handling */
|
||||
@ -1365,6 +1399,16 @@ HCL_EXPORT hcl_oop_t hcl_makeset (
|
||||
hcl_oow_t inisize /* initial bucket size */
|
||||
);
|
||||
|
||||
HCL_EXPORT hcl_oop_t hcl_makeprocess (
|
||||
hcl_t* hcl,
|
||||
hcl_oow_t stksize
|
||||
);
|
||||
|
||||
HCL_EXPORT hcl_oop_t hcl_makecontext (
|
||||
hcl_t* hcl,
|
||||
hcl_ooi_t ntmprs
|
||||
);
|
||||
|
||||
|
||||
HCL_EXPORT void hcl_freengcobj (
|
||||
hcl_t* hcl,
|
||||
|
||||
@ -621,6 +621,13 @@ int main (int argc, char* argv[])
|
||||
}
|
||||
}
|
||||
|
||||
hcl_decode (hcl, 0, hcl->code.bc.len);
|
||||
HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n");
|
||||
if (hcl_execute (hcl) <= -1)
|
||||
{
|
||||
printf ("ERROR: cannot execute - %d\n", hcl_geterrnum(hcl));
|
||||
}
|
||||
|
||||
|
||||
{
|
||||
HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n");
|
||||
|
||||
135
lib/obj.c
135
lib/obj.c
@ -46,7 +46,7 @@ void* hcl_allocbytes (hcl_t* hcl, hcl_oow_t size)
|
||||
return ptr;
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_allocoopobj (hcl_t* hcl, hcl_oow_t size)
|
||||
hcl_oop_t hcl_allocoopobj (hcl_t* hcl, int brand, hcl_oow_t size)
|
||||
{
|
||||
hcl_oop_oop_t hdr;
|
||||
hcl_oow_t nbytes, nbytes_aligned;
|
||||
@ -67,6 +67,7 @@ hcl_oop_t hcl_allocoopobj (hcl_t* hcl, hcl_oow_t size)
|
||||
hdr->_flags = HCL_OBJ_MAKE_FLAGS(HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 0, 0, 0, 0, 0);
|
||||
HCL_OBJ_SET_SIZE (hdr, size);
|
||||
HCL_OBJ_SET_CLASS (hdr, hcl->_nil);
|
||||
HCL_OBJ_SET_FLAGS_BRAND (hdr, brand);
|
||||
|
||||
while (size > 0) hdr->slot[--size] = hcl->_nil;
|
||||
|
||||
@ -109,7 +110,7 @@ hcl_oop_t hcl_allocoopobjwithtrailer (hcl_t* hcl, hcl_oow_t size, const hcl_oob_
|
||||
}
|
||||
#endif
|
||||
|
||||
static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, const void* ptr, hcl_oow_t len, hcl_obj_type_t type, hcl_oow_t unit, int extra, int ngc)
|
||||
static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, int brand, const void* ptr, hcl_oow_t len, hcl_obj_type_t type, hcl_oow_t unit, int extra, int ngc)
|
||||
{
|
||||
/* allocate a variable object */
|
||||
|
||||
@ -137,6 +138,7 @@ static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, const void* ptr, hc
|
||||
hdr->_size = len;
|
||||
HCL_OBJ_SET_SIZE (hdr, len);
|
||||
HCL_OBJ_SET_CLASS (hdr, hcl->_nil);
|
||||
HCL_OBJ_SET_FLAGS_BRAND (hdr, brand);
|
||||
|
||||
if (ptr)
|
||||
{
|
||||
@ -153,24 +155,24 @@ static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, const void* ptr, hc
|
||||
return hdr;
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_alloccharobj (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len)
|
||||
hcl_oop_t hcl_alloccharobj (hcl_t* hcl, int brand, const hcl_ooch_t* ptr, hcl_oow_t len)
|
||||
{
|
||||
return alloc_numeric_array (hcl, ptr, len, HCL_OBJ_TYPE_CHAR, HCL_SIZEOF(hcl_ooch_t), 1, 0);
|
||||
return alloc_numeric_array (hcl, brand, ptr, len, HCL_OBJ_TYPE_CHAR, HCL_SIZEOF(hcl_ooch_t), 1, 0);
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_allocbyteobj (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t len)
|
||||
hcl_oop_t hcl_allocbyteobj (hcl_t* hcl, int brand, const hcl_oob_t* ptr, hcl_oow_t len)
|
||||
{
|
||||
return alloc_numeric_array (hcl, ptr, len, HCL_OBJ_TYPE_BYTE, HCL_SIZEOF(hcl_oob_t), 0, 0);
|
||||
return alloc_numeric_array (hcl, brand, ptr, len, HCL_OBJ_TYPE_BYTE, HCL_SIZEOF(hcl_oob_t), 0, 0);
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_allochalfwordobj (hcl_t* hcl, const hcl_oohw_t* ptr, hcl_oow_t len)
|
||||
hcl_oop_t hcl_allochalfwordobj (hcl_t* hcl, int brand, const hcl_oohw_t* ptr, hcl_oow_t len)
|
||||
{
|
||||
return alloc_numeric_array (hcl, ptr, len, HCL_OBJ_TYPE_HALFWORD, HCL_SIZEOF(hcl_oohw_t), 0, 0);
|
||||
return alloc_numeric_array (hcl, brand, ptr, len, HCL_OBJ_TYPE_HALFWORD, HCL_SIZEOF(hcl_oohw_t), 0, 0);
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_allocwordobj (hcl_t* hcl, const hcl_oow_t* ptr, hcl_oow_t len)
|
||||
hcl_oop_t hcl_allocwordobj (hcl_t* hcl, int brand, const hcl_oow_t* ptr, hcl_oow_t len)
|
||||
{
|
||||
return alloc_numeric_array (hcl, ptr, len, HCL_OBJ_TYPE_WORD, HCL_SIZEOF(hcl_oow_t), 0, 0);
|
||||
return alloc_numeric_array (hcl, brand, ptr, len, HCL_OBJ_TYPE_WORD, HCL_SIZEOF(hcl_oow_t), 0, 0);
|
||||
}
|
||||
|
||||
|
||||
@ -227,6 +229,7 @@ static HCL_INLINE int decode_spec (hcl_t* hcl, hcl_oop_t _class, hcl_oow_t vlen,
|
||||
|
||||
hcl_oop_t hcl_instantiate (hcl_t* hcl, hcl_oop_t _class, const void* vptr, hcl_oow_t vlen)
|
||||
{
|
||||
#if 0
|
||||
hcl_oop_t oop;
|
||||
hcl_obj_type_t type;
|
||||
hcl_oow_t alloclen;
|
||||
@ -292,12 +295,17 @@ hcl_oop_t hcl_instantiate (hcl_t* hcl, hcl_oop_t _class, const void* vptr, hcl_o
|
||||
if (oop) HCL_OBJ_SET_CLASS (oop, _class);
|
||||
hcl_poptmps (hcl, tmp_count);
|
||||
return oop;
|
||||
#endif
|
||||
|
||||
hcl->errnum = HCL_ENOIMPL;
|
||||
return HCL_NULL;
|
||||
}
|
||||
|
||||
#if defined(HCL_USE_OBJECT_TRAILER)
|
||||
|
||||
hcl_oop_t hcl_instantiatewithtrailer (hcl_t* hcl, hcl_oop_t _class, hcl_oow_t vlen, const hcl_oob_t* tptr, hcl_oow_t tlen)
|
||||
{
|
||||
#if 0
|
||||
hcl_oop_t oop;
|
||||
hcl_obj_type_t type;
|
||||
hcl_oow_t alloclen;
|
||||
@ -329,6 +337,10 @@ hcl_oop_t hcl_instantiatewithtrailer (hcl_t* hcl, hcl_oop_t _class, hcl_oow_t vl
|
||||
if (oop) HCL_OBJ_SET_CLASS (oop, _class);
|
||||
hcl_poptmps (hcl, tmp_count);
|
||||
return oop;
|
||||
#endif
|
||||
|
||||
hcl->errnum = HCL_ENOIMPL;
|
||||
return HCL_NULL;
|
||||
}
|
||||
#endif
|
||||
|
||||
@ -340,56 +352,23 @@ hcl_oop_t hcl_instantiatewithtrailer (hcl_t* hcl, hcl_oop_t _class, hcl_oow_t vl
|
||||
|
||||
hcl_oop_t hcl_makenil (hcl_t* hcl)
|
||||
{
|
||||
hcl_oop_t obj;
|
||||
|
||||
obj = hcl_allocoopobj (hcl, 0);
|
||||
if (obj)
|
||||
{
|
||||
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_NIL);
|
||||
}
|
||||
|
||||
return obj;
|
||||
return hcl_allocoopobj (hcl, HCL_BRAND_NIL, 0);
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_maketrue (hcl_t* hcl)
|
||||
{
|
||||
hcl_oop_t obj;
|
||||
|
||||
obj = hcl_allocoopobj (hcl, 0);
|
||||
if (obj)
|
||||
{
|
||||
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_TRUE);
|
||||
}
|
||||
|
||||
return obj;
|
||||
return hcl_allocoopobj (hcl, HCL_BRAND_TRUE, 0);
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_makefalse (hcl_t* hcl)
|
||||
{
|
||||
hcl_oop_t obj;
|
||||
|
||||
obj = hcl_allocoopobj (hcl, 0);
|
||||
if (obj)
|
||||
{
|
||||
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_FALSE);
|
||||
}
|
||||
|
||||
return obj;
|
||||
return hcl_allocoopobj (hcl, HCL_BRAND_FALSE, 0);
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_makeinteger (hcl_t* hcl, hcl_ooi_t v)
|
||||
{
|
||||
hcl_oop_t obj;
|
||||
|
||||
if (HCL_IN_SMOOI_RANGE(v)) return HCL_SMOOI_TO_OOP(v);
|
||||
|
||||
obj = hcl_allocwordobj (hcl, (hcl_oow_t*)&v, 1);
|
||||
if (obj)
|
||||
{
|
||||
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_INTEGER);
|
||||
}
|
||||
|
||||
return obj;
|
||||
return hcl_allocwordobj (hcl, HCL_BRAND_INTEGER, (hcl_oow_t*)&v, 1);
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_makecons (hcl_t* hcl, hcl_oop_t car, hcl_oop_t cdr)
|
||||
@ -399,12 +378,11 @@ hcl_oop_t hcl_makecons (hcl_t* hcl, hcl_oop_t car, hcl_oop_t cdr)
|
||||
hcl_pushtmp (hcl, &car);
|
||||
hcl_pushtmp (hcl, &cdr);
|
||||
|
||||
cons = (hcl_oop_cons_t)hcl_allocoopobj (hcl, 2);
|
||||
cons = (hcl_oop_cons_t)hcl_allocoopobj (hcl, HCL_BRAND_CONS, 2);
|
||||
if (cons)
|
||||
{
|
||||
cons->car = car;
|
||||
cons->cdr = cdr;
|
||||
HCL_OBJ_SET_FLAGS_BRAND (cons, HCL_BRAND_CONS);
|
||||
}
|
||||
|
||||
hcl_poptmps (hcl, 2);
|
||||
@ -414,53 +392,28 @@ hcl_oop_t hcl_makecons (hcl_t* hcl, hcl_oop_t car, hcl_oop_t cdr)
|
||||
|
||||
hcl_oop_t hcl_makearray (hcl_t* hcl, hcl_oow_t size)
|
||||
{
|
||||
hcl_oop_t obj;
|
||||
|
||||
obj = hcl_allocoopobj (hcl, size);
|
||||
if (obj)
|
||||
{
|
||||
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_ARRAY);
|
||||
}
|
||||
|
||||
return obj;
|
||||
return hcl_allocoopobj (hcl, HCL_BRAND_ARRAY, size);
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_makebytearray (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t size)
|
||||
{
|
||||
hcl_oop_t obj;
|
||||
|
||||
obj = hcl_allocbyteobj (hcl, ptr, size);
|
||||
if (obj)
|
||||
{
|
||||
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_BYTE_ARRAY);
|
||||
}
|
||||
|
||||
return obj;
|
||||
return hcl_allocbyteobj (hcl, HCL_BRAND_BYTE_ARRAY, ptr, size);
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_makestring (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len)
|
||||
{
|
||||
hcl_oop_t obj;
|
||||
|
||||
obj = hcl_alloccharobj (hcl, ptr, len);
|
||||
if (obj)
|
||||
{
|
||||
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_STRING);
|
||||
}
|
||||
|
||||
return obj;
|
||||
return hcl_alloccharobj (hcl, HCL_BRAND_STRING, ptr, len);
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_makeset (hcl_t* hcl, hcl_oow_t inisize)
|
||||
{
|
||||
hcl_oop_set_t obj;
|
||||
|
||||
obj = (hcl_oop_set_t)hcl_allocoopobj (hcl, 2);
|
||||
obj = (hcl_oop_set_t)hcl_allocoopobj (hcl, HCL_BRAND_SET, 2);
|
||||
if (obj)
|
||||
{
|
||||
hcl_oop_oop_t bucket;
|
||||
|
||||
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_SET);
|
||||
obj->tally = HCL_SMOOI_TO_OOP(0);
|
||||
|
||||
hcl_pushtmp (hcl, (hcl_oop_t*)&obj);
|
||||
@ -475,6 +428,12 @@ hcl_oop_t hcl_makeset (hcl_t* hcl, hcl_oow_t inisize)
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
/* ------------------------------------------------------------------------ *
|
||||
* NGC HANDLING
|
||||
* ------------------------------------------------------------------------ */
|
||||
|
||||
void hcl_freengcobj (hcl_t* hcl, hcl_oop_t obj)
|
||||
{
|
||||
if (HCL_OOP_IS_POINTER(obj) && HCL_OBJ_GET_FLAGS_NGC(obj)) hcl_freemem (hcl, obj);
|
||||
@ -482,15 +441,7 @@ void hcl_freengcobj (hcl_t* hcl, hcl_oop_t obj)
|
||||
|
||||
hcl_oop_t hcl_makengcbytearray (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t len)
|
||||
{
|
||||
hcl_oop_t obj;
|
||||
|
||||
obj = alloc_numeric_array (hcl, ptr, len, HCL_OBJ_TYPE_BYTE, HCL_SIZEOF(hcl_oob_t), 0, 1);
|
||||
if (obj)
|
||||
{
|
||||
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_BYTE_ARRAY);
|
||||
}
|
||||
|
||||
return obj;
|
||||
return alloc_numeric_array (hcl, HCL_BRAND_BYTE_ARRAY, ptr, len, HCL_OBJ_TYPE_BYTE, HCL_SIZEOF(hcl_oob_t), 0, 1);
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_remakengcbytearray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize)
|
||||
@ -518,15 +469,7 @@ hcl_oop_t hcl_remakengcbytearray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize)
|
||||
|
||||
hcl_oop_t hcl_makengcarray (hcl_t* hcl, hcl_oow_t len)
|
||||
{
|
||||
hcl_oop_t obj;
|
||||
|
||||
obj = alloc_numeric_array (hcl, HCL_NULL, len, HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 1);
|
||||
if (obj)
|
||||
{
|
||||
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_ARRAY);
|
||||
}
|
||||
|
||||
return obj;
|
||||
return alloc_numeric_array (hcl, HCL_BRAND_ARRAY, HCL_NULL, len, HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 1);
|
||||
}
|
||||
|
||||
hcl_oop_t hcl_remakengcarray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize)
|
||||
|
||||
78
lib/print.c
78
lib/print.c
@ -188,6 +188,39 @@ static HCL_INLINE int print_char (printer_t* pr, hcl_ooch_t ch)
|
||||
return 0;
|
||||
}
|
||||
|
||||
enum
|
||||
{
|
||||
WORD_NIL,
|
||||
WORD_TRUE,
|
||||
WORD_FALSE,
|
||||
|
||||
|
||||
WORD_SET,
|
||||
WORD_CFRAME,
|
||||
WORD_CONTEXT,
|
||||
WORD_PROCESS,
|
||||
WORD_PROCESS_SCHEDULER,
|
||||
WORD_SEMAPHORE
|
||||
};
|
||||
|
||||
static struct
|
||||
{
|
||||
hcl_oow_t len;
|
||||
hcl_ooch_t ptr[20];
|
||||
} word[] =
|
||||
{
|
||||
{ 4, { '#','n', 'i', 'l' } },
|
||||
{ 5, { '#','t', 'r', 'u', 'e' } },
|
||||
{ 6, { '#','f', 'a', 'l', 's', 'e' } },
|
||||
|
||||
{ 6, { '#','<','S','E','T','>' } },
|
||||
{ 9, { '#','<','C','F','R','A','M','E','>' } },
|
||||
{ 10, { '#','<','C','O','N','T','E','X','T','>' } },
|
||||
{ 10, { '#','<','P','R','O','C','E','S','S','>' } },
|
||||
{ 20, { '#','<','P','R','O','C','E','S','S','-','S','C','H','E','D','U','L','E','R','>' } },
|
||||
{ 12, { '#','<','S','E','M','A','P','H','O','R','E','>' } }
|
||||
};
|
||||
|
||||
static int print_object (printer_t* pr, hcl_oop_t obj)
|
||||
{
|
||||
hcl_t* hcl;
|
||||
@ -195,17 +228,6 @@ static int print_object (printer_t* pr, hcl_oop_t obj)
|
||||
print_stack_t ps;
|
||||
int brand;
|
||||
|
||||
static struct
|
||||
{
|
||||
hcl_oow_t len;
|
||||
hcl_ooch_t ptr[10];
|
||||
} word[] =
|
||||
{
|
||||
{ 4, { '#','n', 'i', 'l' } },
|
||||
{ 5, { '#','t', 'r', 'u', 'e' } },
|
||||
{ 6, { '#','f', 'a', 'l', 's', 'e' } }
|
||||
};
|
||||
|
||||
hcl = pr->hcl;
|
||||
|
||||
next:
|
||||
@ -223,15 +245,15 @@ next:
|
||||
switch ((brand = HCL_OBJ_GET_FLAGS_BRAND(obj)))
|
||||
{
|
||||
case HCL_BRAND_NIL:
|
||||
OUTPUT_STRX (pr, word[0].ptr, word[0].len);
|
||||
OUTPUT_STRX (pr, word[WORD_NIL].ptr, word[WORD_NIL].len);
|
||||
break;
|
||||
|
||||
case HCL_BRAND_TRUE:
|
||||
OUTPUT_STRX (pr, word[1].ptr, word[1].len);
|
||||
OUTPUT_STRX (pr, word[WORD_TRUE].ptr, word[WORD_TRUE].len);
|
||||
break;
|
||||
|
||||
case HCL_BRAND_FALSE:
|
||||
OUTPUT_STRX (pr, word[2].ptr, word[2].len);
|
||||
OUTPUT_STRX (pr, word[WORD_FALSE].ptr, word[WORD_FALSE].len);
|
||||
break;
|
||||
|
||||
case HCL_BRAND_INTEGER:
|
||||
@ -428,6 +450,11 @@ next:
|
||||
OUTPUT_CHAR (pr, '|');
|
||||
break;
|
||||
}
|
||||
|
||||
case HCL_BRAND_SET:
|
||||
OUTPUT_STRX (pr, word[WORD_SET].ptr, word[WORD_SET].len);
|
||||
break;
|
||||
|
||||
#if 0
|
||||
case HCL_BRAND_PROCEDURE:
|
||||
OUTPUT_STR (pr, "#<PROCEDURE>");
|
||||
@ -438,9 +465,30 @@ next:
|
||||
break;
|
||||
#endif
|
||||
|
||||
|
||||
case HCL_BRAND_CFRAME:
|
||||
OUTPUT_STRX (pr, word[WORD_CFRAME].ptr, word[WORD_CFRAME].len);
|
||||
break;
|
||||
|
||||
case HCL_BRAND_CONTEXT:
|
||||
OUTPUT_STRX (pr, word[WORD_CONTEXT].ptr, word[WORD_CONTEXT].len);
|
||||
break;
|
||||
|
||||
case HCL_BRAND_PROCESS:
|
||||
OUTPUT_STRX (pr, word[WORD_PROCESS].ptr, word[WORD_PROCESS].len);
|
||||
break;
|
||||
|
||||
case HCL_BRAND_PROCESS_SCHEDULER:
|
||||
OUTPUT_STRX (pr, word[WORD_PROCESS_SCHEDULER].ptr, word[WORD_PROCESS_SCHEDULER].len);
|
||||
break;
|
||||
|
||||
case HCL_BRAND_SEMAPHORE:
|
||||
OUTPUT_STRX (pr, word[WORD_SEMAPHORE].ptr, word[WORD_SEMAPHORE].len);
|
||||
break;
|
||||
|
||||
default:
|
||||
HCL_ASSERT ("Unknown object type" == HCL_NULL);
|
||||
HCL_DEBUG3 (hcl, "Internal error - unknown object type %d at %s:%d\n", (int)brand, __FILE__, __LINE__);
|
||||
HCL_ASSERT ("Unknown object type" == HCL_NULL);
|
||||
hcl->errnum = HCL_EINTERN;
|
||||
return -1;
|
||||
}
|
||||
|
||||
@ -160,11 +160,9 @@ static hcl_oop_t find_or_make_symbol (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow
|
||||
}
|
||||
|
||||
/* create a new symbol since it isn't found in the symbol table */
|
||||
symbol = (hcl_oop_char_t)hcl_alloccharobj (hcl, ptr, len);
|
||||
symbol = (hcl_oop_char_t)hcl_alloccharobj (hcl, HCL_BRAND_SYMBOL, ptr, len);
|
||||
if (symbol)
|
||||
{
|
||||
HCL_OBJ_SET_FLAGS_BRAND (symbol, HCL_BRAND_SYMBOL);
|
||||
|
||||
HCL_ASSERT (tally < HCL_SMOOI_MAX);
|
||||
hcl->symtab->tally = HCL_SMOOI_TO_OOP(tally + 1);
|
||||
hcl->symtab->bucket->slot[index] = (hcl_oop_t)symbol;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user