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
};
#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
View File

@ -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;

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.
* 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
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)
{
/*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;
}

1
lib/hcl-cmn.h
View File

@ -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.

21
lib/hcl-prv.h
View File

@ -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
View File

@ -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,

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");

137
lib/obj.c
View File

@ -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,55 +392,30 @@ 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);
bucket = (hcl_oop_oop_t)hcl_makearray (hcl, inisize);
hcl_poptmp (hcl);
@ -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
View File

@ -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;
}

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 */
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;