hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added some code for executing byte codes

Browse Source
This commit is contained in:
hyung-hwan 2016-10-04 17:56:28 +00:00
parent bdfc72d48d
commit badf66c9d4
12 changed files with 2517 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
lib/comp.c
View File

@ -32,6 +32,7 @@ enum
VAR_INDEXED VAR_INDEXED
}; };
#define CODE_BUFFER_ALIGN 1024 /* TODO: set a bigger value */
#define TV_BUFFER_ALIGN 256 #define TV_BUFFER_ALIGN 256
#define BLK_TMPRCNT_BUFFER_ALIGN 128 #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) 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_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) static int emit_byte_instruction (hcl_t* hcl, hcl_oob_t bc)
{ {
hcl_oow_t capa; 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); capa = HCL_OBJ_GET_SIZE(hcl->code.bc.arr);
if (hcl->code.bc.len >= capa) if (hcl->code.bc.len >= capa)
{ {
hcl_oop_t tmp; hcl_oop_t tmp;
hcl_oow_t newcapa; hcl_oow_t newcapa;
newcapa = capa + 20000; /* TODO: set a better resizing policy */ newcapa = HCL_ALIGN (capa + 1, CODE_BUFFER_ALIGN);
tmp = hcl_remakengcbytearray (hcl, hcl->code.bc.arr, newcapa); tmp = hcl_remakengcbytearray (hcl, (hcl_oop_t)hcl->code.bc.arr, newcapa);
if (!tmp) return -1; 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; 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 */ /* check if a symbol is a local variable */
if (find_temporary_variable_backward (hcl, obj, &index) <= -1) 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: 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 */ /* 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; emit_single_param_instruction (hcl, HCL_CODE_PUSH_OBJECT_0, index) <= -1) return -1;
return 0; return 0;
@ -1053,9 +1074,11 @@ static HCL_INLINE int emit_lambda (hcl_t* hcl)
/* no body in lambda - (lambda (a b c)) */ /* no body in lambda - (lambda (a b c)) */
/* TODO: is this correct??? */ /* TODO: is this correct??? */
if (emit_byte_instruction(hcl, HCL_CODE_PUSH_NIL) <= -1) return -1; 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; if (emit_byte_instruction (hcl, HCL_CODE_RETURN_FROM_BLOCK) <= -1) return -1;
block_code_size++;
if (block_code_size > MAX_CODE_JUMP * 2) 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) if (cf->u.set.var_type == VAR_NAMED)
{ {
hcl_oow_t index; hcl_oow_t index;
hcl_oop_t cons;
HCL_ASSERT (HCL_IS_SYMBOL(hcl, cf->operand)); 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; emit_single_param_instruction(hcl, HCL_CODE_STORE_INTO_OBJECT_0, index) <= -1) return -1;
} }
else else

70
lib/decode.c
View File

@ -47,15 +47,18 @@
#endif #endif
/* TODO: check if ip shoots beyond the maximum length in fetching code and parameters */ /* 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_oob_t bcode, * cdptr;
hcl_oow_t ip = start; hcl_ooi_t ip = start;
hcl_ooi_t b1, b2; hcl_oow_t b1, b2;
/* the instruction at the offset 'end' is not decoded. /* the instruction at the offset 'end' is not decoded.
* decoding offset range is from start to end - 1. */ * 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; ip = start;
cdptr = ((hcl_oop_byte_t)hcl->code.bc.arr)->slot; 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: case BCODE_PUSH_INSTVAR_7:
b1 = bcode & 0x7; /* low 3 bits */ b1 = bcode & 0x7; /* low 3 bits */
push_instvar: push_instvar:
LOG_INST_1 (hcl, "push_instvar %zd", b1); LOG_INST_1 (hcl, "push_instvar %zu", b1);
break; 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: case BCODE_STORE_INTO_INSTVAR_7:
b1 = bcode & 0x7; /* low 3 bits */ b1 = bcode & 0x7; /* low 3 bits */
store_instvar: store_instvar:
LOG_INST_1 (hcl, "store_into_instvar %zd", b1); LOG_INST_1 (hcl, "store_into_instvar %zu", b1);
break; break;
case BCODE_POP_INTO_INSTVAR_X: 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: case BCODE_POP_INTO_INSTVAR_7:
b1 = bcode & 0x7; /* low 3 bits */ b1 = bcode & 0x7; /* low 3 bits */
pop_into_instvar: pop_into_instvar:
LOG_INST_1 (hcl, "pop_into_instvar %zd", b1); LOG_INST_1 (hcl, "pop_into_instvar %zu", b1);
break; break;
/* ------------------------------------------------- */ /* ------------------------------------------------- */
@ -154,7 +157,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
if ((bcode >> 4) & 1) if ((bcode >> 4) & 1)
{ {
/* push - bit 4 on */ /* push - bit 4 on */
LOG_INST_1 (hcl, "push_tempvar %zd", b1); LOG_INST_1 (hcl, "push_tempvar %zu", b1);
} }
else else
{ {
@ -162,11 +165,11 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
if ((bcode >> 3) & 1) if ((bcode >> 3) & 1)
{ {
/* pop - bit 3 on */ /* pop - bit 3 on */
LOG_INST_1 (hcl, "pop_into_tempvar %zd", b1); LOG_INST_1 (hcl, "pop_into_tempvar %zu", b1);
} }
else else
{ {
LOG_INST_1 (hcl, "store_into_tempvar %zd", b1); LOG_INST_1 (hcl, "store_into_tempvar %zu", b1);
} }
} }
break; 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: case HCL_CODE_PUSH_LITERAL_7:
b1 = bcode & 0x7; /* low 3 bits */ b1 = bcode & 0x7; /* low 3 bits */
push_literal: push_literal:
LOG_INST_1 (hcl, "push_literal @%zd", b1); LOG_INST_1 (hcl, "push_literal @%zu", b1);
break; break;
/* ------------------------------------------------- */ /* ------------------------------------------------- */
@ -224,16 +227,16 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
{ {
if ((bcode >> 2) & 1) if ((bcode >> 2) & 1)
{ {
LOG_INST_1 (hcl, "pop_into_object @%zd", b1); LOG_INST_1 (hcl, "pop_into_object @%zu", b1);
} }
else else
{ {
LOG_INST_1 (hcl, "store_into_object @%zd", b1); LOG_INST_1 (hcl, "store_into_object @%zu", b1);
} }
} }
else else
{ {
LOG_INST_1 (hcl, "push_object @%zd", b1); LOG_INST_1 (hcl, "push_object @%zu", b1);
} }
break; 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: case HCL_CODE_JUMP_FORWARD_X:
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "jump_forward %zd", b1); LOG_INST_1 (hcl, "jump_forward %zu", b1);
break; break;
case HCL_CODE_JUMP_FORWARD_0: case HCL_CODE_JUMP_FORWARD_0:
case HCL_CODE_JUMP_FORWARD_1: case HCL_CODE_JUMP_FORWARD_1:
case HCL_CODE_JUMP_FORWARD_2: case HCL_CODE_JUMP_FORWARD_2:
case HCL_CODE_JUMP_FORWARD_3: 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; break;
case HCL_CODE_JUMP_BACKWARD_X: case HCL_CODE_JUMP_BACKWARD_X:
FETCH_PARAM_CODE_TO (hcl, b1); 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; hcl->ip += b1;
break; 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_1:
case HCL_CODE_JUMP_BACKWARD_2: case HCL_CODE_JUMP_BACKWARD_2:
case HCL_CODE_JUMP_BACKWARD_3: 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; break;
case BCODE_JUMP_IF_TRUE_X: case BCODE_JUMP_IF_TRUE_X:
@ -280,12 +283,12 @@ return -1;
case HCL_CODE_JUMP2_FORWARD: case HCL_CODE_JUMP2_FORWARD:
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "jump2_forward %zd", b1); LOG_INST_1 (hcl, "jump2_forward %zu", b1);
break; break;
case HCL_CODE_JUMP2_BACKWARD: case HCL_CODE_JUMP2_BACKWARD:
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "jump2_backward %zd", b1); LOG_INST_1 (hcl, "jump2_backward %zu", b1);
break; break;
/* -------------------------------------------------------- */ /* -------------------------------------------------------- */
@ -300,7 +303,7 @@ return -1;
case HCL_CODE_CALL_3: case HCL_CODE_CALL_3:
b1 = bcode & 0x3; /* low 2 bits */ b1 = bcode & 0x3; /* low 2 bits */
handle_call: handle_call:
LOG_INST_1 (hcl, "call %zd", b1); LOG_INST_1 (hcl, "call %zu", b1);
break; break;
/* -------------------------------------------------------- */ /* -------------------------------------------------------- */
@ -333,17 +336,17 @@ return -1;
if ((bcode >> 2) & 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 else
{ {
LOG_INST_2 (hcl, "store_into_ctxtempvar %zd %zd", b1, b2); LOG_INST_2 (hcl, "store_into_ctxtempvar %zu %zu", b1, b2);
} }
} }
else else
{ {
/* push */ /* push */
LOG_INST_2 (hcl, "push_ctxtempvar %zd %zd", b1, b2); LOG_INST_2 (hcl, "push_ctxtempvar %zu %zu", b1, b2);
} }
break; break;
@ -379,16 +382,16 @@ return -1;
/* store or pop */ /* store or pop */
if ((bcode >> 2) & 1) 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 else
{ {
LOG_INST_2 (hcl, "store_into_objvar %zd %zd", b1, b2); LOG_INST_2 (hcl, "store_into_objvar %zu %zu", b1, b2);
} }
} }
else else
{ {
LOG_INST_2 (hcl, "push_objvar %zd %zd", b1, b2); LOG_INST_2 (hcl, "push_objvar %zu %zu", b1, b2);
} }
break; break;
@ -414,7 +417,7 @@ return -1;
FETCH_BYTE_CODE_TO (hcl, b2); FETCH_BYTE_CODE_TO (hcl, b2);
handle_send_message: 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; break;
/* -------------------------------------------------------- */ /* -------------------------------------------------------- */
@ -461,17 +464,17 @@ return -1;
case HCL_CODE_PUSH_INTLIT: case HCL_CODE_PUSH_INTLIT:
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "push_intlit %zd", b1); LOG_INST_1 (hcl, "push_intlit %zu", b1);
break; break;
case HCL_CODE_PUSH_NEGINTLIT: case HCL_CODE_PUSH_NEGINTLIT:
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "push_negintlit %zd", -b1); LOG_INST_1 (hcl, "push_negintlit %zu", b1);
break; break;
case HCL_CODE_PUSH_CHARLIT: case HCL_CODE_PUSH_CHARLIT:
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "push_charlit %zd", b1); LOG_INST_1 (hcl, "push_charlit %zu", b1);
break; break;
/* -------------------------------------------------------- */ /* -------------------------------------------------------- */
@ -501,7 +504,7 @@ return -1;
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
FETCH_PARAM_CODE_TO (hcl, b2); 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 (b1 >= 0);
HCL_ASSERT (b2 >= b1); HCL_ASSERT (b2 >= b1);
@ -520,14 +523,13 @@ return -1;
LOG_INST_1 (hcl, "UNKNOWN BYTE CODE ENCOUNTERED %x", (int)bcode); LOG_INST_1 (hcl, "UNKNOWN BYTE CODE ENCOUNTERED %x", (int)bcode);
hcl->errnum = HCL_EINTERN; hcl->errnum = HCL_EINTERN;
break; break;
} }
} }
/* print literal frame contents */ /* print literal frame contents */
for (ip = 0; ip < hcl->code.lit.len; ip++) 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; return 0;

8
lib/dic.c
View File

@ -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. /* the system dictionary is not a generic dictionary.
* it accepts only a symbol as a key. */ * 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_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); 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_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); 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_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); return find_or_upsert (hcl, hcl->sysdic, (hcl_oop_char_t)key, HCL_NULL);
} }

2220
lib/exec.c
View File

File diff suppressed because it is too large Load Diff

66
lib/gc.c
View File

@ -285,9 +285,10 @@ void hcl_gc (hcl_t* hcl)
if (hcl->active_context) if (hcl->active_context)
{ {
/*HCL_ASSERT ((hcl_oop_t)hcl->processor != hcl->_nil); HCL_ASSERT ((hcl_oop_t)hcl->processor != hcl->_nil);
if ((hcl_oop_t)hcl->processor->active != hcl->_nil)*/ HCL_ASSERT ((hcl_oop_t)hcl->processor->active != hcl->_nil);
hcl->processor->active->sp = HCL_SMOOI_TO_OOP(hcl->sp); /* 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 */ /* store the instruction pointer to the active context */
hcl->active_context->ip = HCL_SMOOI_TO_OOP(hcl->ip); 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]); *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) if (hcl->active_context)
hcl->active_context = (hcl_oop_context_t)hcl_moveoop (hcl, (hcl_oop_t)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) for (cb = hcl->cblist; cb; cb = cb->next)
{ {
@ -385,26 +386,29 @@ void hcl_gc (hcl_t* hcl)
hcl->curheap = hcl->newheap; hcl->curheap = hcl->newheap;
hcl->newheap = tmp; hcl->newheap = tmp;
/* /*
{ if (hcl->symtab && HCL_LOG_ENABLED(hcl, HCL_LOG_GC | HCL_LOG_DEBUG))
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)
{ {
const hcl_oop_char_t* p = ((hcl_oop_char_t)buc->slot[index])->slot; hcl_oow_t index;
printf ("SYM ["); hcl_oop_oop_t buc;
while (*p) printf ("%c", *p++); HCL_LOG0 (hcl, HCL_LOG_GC | HCL_LOG_DEBUG, "--------- SURVIVING SYMBOLS IN GC ----------\n");
printf ("]\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; *(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) if (!hcl->code.bc.arr)
{ {
hcl->code.bc.arr = hcl_makengcbytearray (hcl, HCL_NULL, 20000); /* TODO: set a proper intial size */ 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) 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; if (!hcl->code.lit.arr) return -1;
} }

1
lib/hcl-cmn.h
View File

@ -447,7 +447,6 @@ struct hcl_ntime_t
#define HCL_ORBITS(type,value,offset,length,bits) \ #define HCL_ORBITS(type,value,offset,length,bits) \
(value = (((type)(value)) | (((bits) & HCL_LBMASK(type,length)) << (offset)))) (value = (((type)(value)) | (((bits) & HCL_LBMASK(type,length)) << (offset))))
/** /**
* The HCL_BITS_MAX() macros calculates the maximum value that the 'nbits' * The HCL_BITS_MAX() macros calculates the maximum value that the 'nbits'
* bits of an unsigned integer of the given 'type' can hold. * bits of an unsigned integer of the given 'type' can hold.

21
lib/hcl-prv.h
View File

@ -52,7 +52,7 @@
/* this is for gc debugging */ /* this is for gc debugging */
/*#define HCL_DEBUG_PROCESSOR*/ /*#define HCL_DEBUG_PROCESSOR*/
#define HCL_DEBUG_GC #define HCL_DEBUG_GC
#define HCL_DEBUG_VM_EXEC
/* limit the maximum object size such that: /* limit the maximum object size such that:
* 1. an index to an object field can be represented in a small integer. * 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; hcl_oow_t tmprcnt_capa;
} blk; /* lambda block */ } blk; /* lambda block */
}; };
#endif #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) #if defined(HCL_BCODE_LONG_PARAM_SIZE) && (HCL_BCODE_LONG_PARAM_SIZE == 1)
# define MAX_CODE_INDEX (0xFFu) # define MAX_CODE_INDEX (0xFFu)
@ -757,6 +749,7 @@ void* hcl_allocbytes (
*/ */
hcl_oop_t hcl_allocoopobj ( hcl_oop_t hcl_allocoopobj (
hcl_t* hcl, hcl_t* hcl,
int brand,
hcl_oow_t size hcl_oow_t size
); );
@ -771,24 +764,28 @@ hcl_oop_t hcl_allocoopobjwithtrailer (
hcl_oop_t hcl_alloccharobj ( hcl_oop_t hcl_alloccharobj (
hcl_t* hcl, hcl_t* hcl,
int brand,
const hcl_ooch_t* ptr, const hcl_ooch_t* ptr,
hcl_oow_t len hcl_oow_t len
); );
hcl_oop_t hcl_allocbyteobj ( hcl_oop_t hcl_allocbyteobj (
hcl_t* hcl, hcl_t* hcl,
const hcl_oob_t* ptr, int brand,
hcl_oow_t len const hcl_oob_t* ptr,
hcl_oow_t len
); );
hcl_oop_t hcl_allochalfwordobj ( hcl_oop_t hcl_allochalfwordobj (
hcl_t* hcl, hcl_t* hcl,
int brand,
const hcl_oohw_t* ptr, const hcl_oohw_t* ptr,
hcl_oow_t len hcl_oow_t len
); );
hcl_oop_t hcl_allocwordobj ( hcl_oop_t hcl_allocwordobj (
hcl_t* hcl, hcl_t* hcl,
int brand,
const hcl_oow_t* ptr, const hcl_oow_t* ptr,
hcl_oow_t len hcl_oow_t len
); );

66
lib/hcl.h
View File

@ -53,6 +53,7 @@ enum hcl_errnum_t
HCL_ERANGE, /**< range error. overflow and underflow */ HCL_ERANGE, /**< range error. overflow and underflow */
HCL_ENOENT, /**< no matching entry */ HCL_ENOENT, /**< no matching entry */
HCL_EEXIST, /**< duplicate entry */ HCL_EEXIST, /**< duplicate entry */
HCL_EBCFULL, /**< byte-code full */
HCL_EDFULL, /**< dictionary full */ HCL_EDFULL, /**< dictionary full */
HCL_EPFULL, /**< processor full */ HCL_EPFULL, /**< processor full */
HCL_ESHFULL, /**< semaphore heap 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_process_t;
typedef struct hcl_process_t* hcl_oop_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_semaphore_t;
typedef struct hcl_semaphore_t* hcl_oop_semaphore_t; typedef struct hcl_semaphore_t* hcl_oop_semaphore_t;
@ -938,12 +939,13 @@ struct hcl_t
hcl_oow_t tmp_count; hcl_oow_t tmp_count;
/* == EXECUTION REGISTERS == */ /* == EXECUTION REGISTERS == */
hcl_oop_context_t initial_context; /* fake initial context */
hcl_oop_context_t active_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 sp;
hcl_ooi_t ip; hcl_ooi_t ip;
int proc_switched; /* TODO: this is temporary. implement something else to skip immediate context switching */ 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 == */ /* == END EXECUTION REGISTERS == */
/* == BIGINT CONVERSION == */ /* == BIGINT CONVERSION == */
@ -958,13 +960,13 @@ struct hcl_t
{ {
struct 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; hcl_oow_t len;
} bc; } bc;
struct 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; hcl_oow_t len;
} lit; } lit;
} code; } code;
@ -987,6 +989,33 @@ struct hcl_t
#endif #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 * HCL VM LOGGING
* ========================================================================= */ * ========================================================================= */
@ -1036,7 +1065,7 @@ typedef enum hcl_log_mask_t hcl_log_mask_t;
* ========================================================================= */ * ========================================================================= */
enum enum
{ {
HCL_BRAND_NIL, HCL_BRAND_NIL = 1,
HCL_BRAND_TRUE, HCL_BRAND_TRUE,
HCL_BRAND_FALSE, HCL_BRAND_FALSE,
HCL_BRAND_CHARACTER, HCL_BRAND_CHARACTER,
@ -1049,10 +1078,12 @@ enum
HCL_BRAND_STRING, HCL_BRAND_STRING,
HCL_BRAND_SET, HCL_BRAND_SET,
HCL_BRAND_ENVIRONMENT,
HCL_BRAND_CFRAME,/* compiler frame */ HCL_BRAND_CFRAME,/* compiler frame */
HCL_BRAND_PROCESS HCL_BRAND_CONTEXT,
HCL_BRAND_PROCESS,
HCL_BRAND_PROCESS_SCHEDULER,
HCL_BRAND_SEMAPHORE
}; };
enum 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_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(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_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_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_CAR(v) (((hcl_cons_t*)(v))->car)
#define HCL_CONS_CDR(v) (((hcl_cons_t*)(v))->cdr) #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_EXPORT int hcl_decode (
hcl_t* hcl, hcl_t* hcl,
hcl_oow_t start, hcl_ooi_t start,
hcl_oow_t end hcl_ooi_t end
); );
/* Syntax error handling */ /* Syntax error handling */
@ -1365,6 +1399,16 @@ HCL_EXPORT hcl_oop_t hcl_makeset (
hcl_oow_t inisize /* initial bucket size */ 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_EXPORT void hcl_freengcobj (
hcl_t* hcl, hcl_t* hcl,

7
lib/main.c
View File

@ -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"); HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n");

135
lib/obj.c
View File

@ -46,7 +46,7 @@ void* hcl_allocbytes (hcl_t* hcl, hcl_oow_t size)
return ptr; 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_oop_oop_t hdr;
hcl_oow_t nbytes, nbytes_aligned; 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); 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_SIZE (hdr, size);
HCL_OBJ_SET_CLASS (hdr, hcl->_nil); HCL_OBJ_SET_CLASS (hdr, hcl->_nil);
HCL_OBJ_SET_FLAGS_BRAND (hdr, brand);
while (size > 0) hdr->slot[--size] = hcl->_nil; 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 #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 */ /* 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; hdr->_size = len;
HCL_OBJ_SET_SIZE (hdr, len); HCL_OBJ_SET_SIZE (hdr, len);
HCL_OBJ_SET_CLASS (hdr, hcl->_nil); HCL_OBJ_SET_CLASS (hdr, hcl->_nil);
HCL_OBJ_SET_FLAGS_BRAND (hdr, brand);
if (ptr) if (ptr)
{ {
@ -153,24 +155,24 @@ static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, const void* ptr, hc
return hdr; 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) 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_oop_t oop;
hcl_obj_type_t type; hcl_obj_type_t type;
hcl_oow_t alloclen; 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); if (oop) HCL_OBJ_SET_CLASS (oop, _class);
hcl_poptmps (hcl, tmp_count); hcl_poptmps (hcl, tmp_count);
return oop; return oop;
#endif
hcl->errnum = HCL_ENOIMPL;
return HCL_NULL;
} }
#if defined(HCL_USE_OBJECT_TRAILER) #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) 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_oop_t oop;
hcl_obj_type_t type; hcl_obj_type_t type;
hcl_oow_t alloclen; 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); if (oop) HCL_OBJ_SET_CLASS (oop, _class);
hcl_poptmps (hcl, tmp_count); hcl_poptmps (hcl, tmp_count);
return oop; return oop;
#endif
hcl->errnum = HCL_ENOIMPL;
return HCL_NULL;
} }
#endif #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 hcl_makenil (hcl_t* hcl)
{ {
hcl_oop_t obj; return hcl_allocoopobj (hcl, HCL_BRAND_NIL, 0);
obj = hcl_allocoopobj (hcl, 0);
if (obj)
{
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_NIL);
}
return obj;
} }
hcl_oop_t hcl_maketrue (hcl_t* hcl) hcl_oop_t hcl_maketrue (hcl_t* hcl)
{ {
hcl_oop_t obj; return hcl_allocoopobj (hcl, HCL_BRAND_TRUE, 0);
obj = hcl_allocoopobj (hcl, 0);
if (obj)
{
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_TRUE);
}
return obj;
} }
hcl_oop_t hcl_makefalse (hcl_t* hcl) hcl_oop_t hcl_makefalse (hcl_t* hcl)
{ {
hcl_oop_t obj; return hcl_allocoopobj (hcl, HCL_BRAND_FALSE, 0);
obj = hcl_allocoopobj (hcl, 0);
if (obj)
{
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_FALSE);
}
return obj;
} }
hcl_oop_t hcl_makeinteger (hcl_t* hcl, hcl_ooi_t v) 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); if (HCL_IN_SMOOI_RANGE(v)) return HCL_SMOOI_TO_OOP(v);
return hcl_allocwordobj (hcl, HCL_BRAND_INTEGER, (hcl_oow_t*)&v, 1);
obj = hcl_allocwordobj (hcl, (hcl_oow_t*)&v, 1);
if (obj)
{
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_INTEGER);
}
return obj;
} }
hcl_oop_t hcl_makecons (hcl_t* hcl, hcl_oop_t car, hcl_oop_t cdr) 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, &car);
hcl_pushtmp (hcl, &cdr); 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) if (cons)
{ {
cons->car = car; cons->car = car;
cons->cdr = cdr; cons->cdr = cdr;
HCL_OBJ_SET_FLAGS_BRAND (cons, HCL_BRAND_CONS);
} }
hcl_poptmps (hcl, 2); 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 hcl_makearray (hcl_t* hcl, hcl_oow_t size)
{ {
hcl_oop_t obj; return hcl_allocoopobj (hcl, HCL_BRAND_ARRAY, size);
obj = hcl_allocoopobj (hcl, size);
if (obj)
{
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_ARRAY);
}
return obj;
} }
hcl_oop_t hcl_makebytearray (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t size) hcl_oop_t hcl_makebytearray (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t size)
{ {
hcl_oop_t obj; return hcl_allocbyteobj (hcl, HCL_BRAND_BYTE_ARRAY, ptr, size);
obj = hcl_allocbyteobj (hcl, ptr, size);
if (obj)
{
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_BYTE_ARRAY);
}
return obj;
} }
hcl_oop_t hcl_makestring (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len) hcl_oop_t hcl_makestring (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len)
{ {
hcl_oop_t obj; return hcl_alloccharobj (hcl, HCL_BRAND_STRING, ptr, len);
obj = hcl_alloccharobj (hcl, ptr, len);
if (obj)
{
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_STRING);
}
return obj;
} }
hcl_oop_t hcl_makeset (hcl_t* hcl, hcl_oow_t inisize) hcl_oop_t hcl_makeset (hcl_t* hcl, hcl_oow_t inisize)
{ {
hcl_oop_set_t obj; 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) if (obj)
{ {
hcl_oop_oop_t bucket; hcl_oop_oop_t bucket;
HCL_OBJ_SET_FLAGS_BRAND (obj, HCL_BRAND_SET);
obj->tally = HCL_SMOOI_TO_OOP(0); obj->tally = HCL_SMOOI_TO_OOP(0);
hcl_pushtmp (hcl, (hcl_oop_t*)&obj); 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) 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); 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 hcl_makengcbytearray (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t len)
{ {
hcl_oop_t obj; return alloc_numeric_array (hcl, HCL_BRAND_BYTE_ARRAY, ptr, len, HCL_OBJ_TYPE_BYTE, HCL_SIZEOF(hcl_oob_t), 0, 1);
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;
} }
hcl_oop_t hcl_remakengcbytearray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize) 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 hcl_makengcarray (hcl_t* hcl, hcl_oow_t len)
{ {
hcl_oop_t obj; return alloc_numeric_array (hcl, HCL_BRAND_ARRAY, HCL_NULL, len, HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 1);
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;
} }
hcl_oop_t hcl_remakengcarray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize) hcl_oop_t hcl_remakengcarray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize)

78
lib/print.c
View File

@ -188,6 +188,39 @@ static HCL_INLINE int print_char (printer_t* pr, hcl_ooch_t ch)
return 0; 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) static int print_object (printer_t* pr, hcl_oop_t obj)
{ {
hcl_t* hcl; hcl_t* hcl;
@ -195,17 +228,6 @@ static int print_object (printer_t* pr, hcl_oop_t obj)
print_stack_t ps; print_stack_t ps;
int brand; 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; hcl = pr->hcl;
next: next:
@ -223,15 +245,15 @@ next:
switch ((brand = HCL_OBJ_GET_FLAGS_BRAND(obj))) switch ((brand = HCL_OBJ_GET_FLAGS_BRAND(obj)))
{ {
case HCL_BRAND_NIL: 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; break;
case HCL_BRAND_TRUE: 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; break;
case HCL_BRAND_FALSE: 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; break;
case HCL_BRAND_INTEGER: case HCL_BRAND_INTEGER:
@ -428,6 +450,11 @@ next:
OUTPUT_CHAR (pr, '|'); OUTPUT_CHAR (pr, '|');
break; break;
} }
case HCL_BRAND_SET:
OUTPUT_STRX (pr, word[WORD_SET].ptr, word[WORD_SET].len);
break;
#if 0 #if 0
case HCL_BRAND_PROCEDURE: case HCL_BRAND_PROCEDURE:
OUTPUT_STR (pr, "#<PROCEDURE>"); OUTPUT_STR (pr, "#<PROCEDURE>");
@ -438,9 +465,30 @@ next:
break; break;
#endif #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: 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_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; hcl->errnum = HCL_EINTERN;
return -1; return -1;
} }

4
lib/sym.c
View File

@ -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 */ /* 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) if (symbol)
{ {
HCL_OBJ_SET_FLAGS_BRAND (symbol, HCL_BRAND_SYMBOL);
HCL_ASSERT (tally < HCL_SMOOI_MAX); HCL_ASSERT (tally < HCL_SMOOI_MAX);
hcl->symtab->tally = HCL_SMOOI_TO_OOP(tally + 1); hcl->symtab->tally = HCL_SMOOI_TO_OOP(tally + 1);
hcl->symtab->bucket->slot[index] = (hcl_oop_t)symbol; hcl->symtab->bucket->slot[index] = (hcl_oop_t)symbol;