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

added hcl_getlastretv().

Browse Source 
enhanced hcl_hashobj() to return hash values for nil, true, false
This commit is contained in:
hyung-hwan 2018-02-22 07:41:03 +00:00
parent dbeac10a38
commit 4876d1775c
8 changed files with 109 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
lib/dic.c
View File

@ -64,7 +64,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
} }
hcl_pushtmp (hcl, (hcl_oop_t*)&oldbuc); hcl_pushtmp (hcl, (hcl_oop_t*)&oldbuc);
newbuc = (hcl_oop_oop_t)hcl_makearray (hcl, newsz); newbuc = (hcl_oop_oop_t)hcl_makearray (hcl, newsz, 0);
hcl_poptmp (hcl); hcl_poptmp (hcl);
if (!newbuc) return HCL_NULL; if (!newbuc) return HCL_NULL;
@ -268,7 +268,7 @@ hcl_oop_t hcl_makedic (hcl_t* hcl, hcl_oow_t inisize)
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);
bucket = (hcl_oop_oop_t)hcl_makearray(hcl, inisize); bucket = (hcl_oop_oop_t)hcl_makearray(hcl, inisize, 0);
hcl_poptmp (hcl); hcl_poptmp (hcl);
if (!bucket) obj = HCL_NULL; if (!bucket) obj = HCL_NULL;

21
lib/exec.c
View File

@ -1798,7 +1798,7 @@ static int execute (hcl_t* hcl)
LOG_INST_1 (hcl, "make_array %zu", b1); LOG_INST_1 (hcl, "make_array %zu", b1);
/* create an empty array */ /* create an empty array */
t = hcl_makearray (hcl, b1); t = hcl_makearray (hcl, b1, 0);
if (!t) goto oops; if (!t) goto oops;
HCL_STACK_PUSH (hcl, t); /* push the array created */ HCL_STACK_PUSH (hcl, t); /* push the array created */
@ -1894,6 +1894,12 @@ static int execute (hcl_t* hcl)
case HCL_CODE_POP_STACKTOP: case HCL_CODE_POP_STACKTOP:
LOG_INST_0 (hcl, "pop_stacktop"); LOG_INST_0 (hcl, "pop_stacktop");
HCL_ASSERT (hcl, !HCL_STACK_ISEMPTY(hcl)); HCL_ASSERT (hcl, !HCL_STACK_ISEMPTY(hcl));
/* at the top level, the value is just popped off the stack
* after evaluation of an expressio. so it's likely the
* return value of the last expression unless explicit
* returning is performed */
hcl->last_retv = HCL_STACK_GETTOP(hcl);
HCL_STACK_POP (hcl); HCL_STACK_POP (hcl);
break; break;
@ -1917,7 +1923,6 @@ static int execute (hcl_t* hcl)
/* decrement the instruction pointer back to the return instruction. /* decrement the instruction pointer back to the return instruction.
* even if the context is reentered, it will just return. * even if the context is reentered, it will just return.
*hcl->ip--;*/ *hcl->ip--;*/
terminate_process (hcl, hcl->processor->active); terminate_process (hcl, hcl->processor->active);
} }
else else
@ -2009,6 +2014,7 @@ static int execute (hcl_t* hcl)
LOG_INST_0 (hcl, "return_from_block"); LOG_INST_0 (hcl, "return_from_block");
HCL_ASSERT(hcl, HCL_IS_CONTEXT(hcl, hcl->active_context)); HCL_ASSERT(hcl, HCL_IS_CONTEXT(hcl, hcl->active_context));
hcl->last_retv = HCL_STACK_GETTOP(hcl);
if (hcl->active_context == hcl->processor->active->initial_context) if (hcl->active_context == hcl->processor->active->initial_context)
{ {
/* the active context to return from is an initial context of /* the active context to return from is an initial context of
@ -2183,7 +2189,7 @@ static int execute (hcl_t* hcl)
done: done:
vm_cleanup (hcl); vm_cleanup (hcl);
#if defined(HCL_PROFILE_VM) #if defined(HCL_PROFILE_VM)
HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_INFO, "TOTAL_INST_COUTNER = %zu\n", inst_counter); HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_INFO, "TOTAL INST COUTNER = %zu\n", inst_counter);
#endif #endif
return 0; return 0;
@ -2191,7 +2197,7 @@ oops:
/* TODO: anything to do here? */ /* TODO: anything to do here? */
if (hcl->processor->active != hcl->nil_process) if (hcl->processor->active != hcl->nil_process)
{ {
HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_INFO, "TERMINATING ACTIVE PROCESS ... = %zd\n", HCL_OOP_TO_SMOOI(hcl->processor->active->id)); HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_INFO, "TERMINATING ACTIVE PROCESS %zd for execution error\n", HCL_OOP_TO_SMOOI(hcl->processor->active->id));
terminate_process (hcl, hcl->processor->active); terminate_process (hcl, hcl->processor->active);
} }
return -1; return -1;
@ -2199,8 +2205,7 @@ HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_INFO, "TERMINATING ACTIVE PROCESS ... = %zd\
int hcl_executefromip (hcl_t* hcl, hcl_ooi_t initial_ip) int hcl_executefromip (hcl_t* hcl, hcl_ooi_t initial_ip)
{ {
int n; int n, log_default_type_mask;
int log_default_type_mask;
log_default_type_mask = hcl->log.default_type_mask; log_default_type_mask = hcl->log.default_type_mask;
hcl->log.default_type_mask |= HCL_LOG_VM; hcl->log.default_type_mask |= HCL_LOG_VM;
@ -2208,11 +2213,15 @@ int hcl_executefromip (hcl_t* hcl, hcl_ooi_t initial_ip)
HCL_ASSERT (hcl, hcl->initial_context == HCL_NULL); HCL_ASSERT (hcl, hcl->initial_context == HCL_NULL);
HCL_ASSERT (hcl, hcl->active_context == HCL_NULL); HCL_ASSERT (hcl, hcl->active_context == HCL_NULL);
hcl->last_retv = hcl->_nil;
if (start_initial_process_and_context(hcl, initial_ip) <= -1) return -1; if (start_initial_process_and_context(hcl, initial_ip) <= -1) return -1;
hcl->initial_context = hcl->processor->active->initial_context; hcl->initial_context = hcl->processor->active->initial_context;
n = execute (hcl); n = execute (hcl);
HCL_INFO1 (hcl, "RETURNED VALUE - %O\n", hcl->last_retv);
/* TODO: reset processor fields. set processor->tally to zero. processor->active to nil_process... */ /* TODO: reset processor fields. set processor->tally to zero. processor->active to nil_process... */
hcl->initial_context = HCL_NULL; hcl->initial_context = HCL_NULL;
hcl->active_context = HCL_NULL; hcl->active_context = HCL_NULL;

33
lib/gc.c
View File

@ -309,56 +309,53 @@ void hcl_gc (hcl_t* hcl)
old_nil = hcl->_nil; old_nil = hcl->_nil;
/* move _nil and the root object table */ /* move _nil and the root object table */
hcl->_nil = hcl_moveoop (hcl, hcl->_nil); hcl->_nil = hcl_moveoop(hcl, hcl->_nil);
hcl->_true = hcl_moveoop (hcl, hcl->_true); hcl->_true = hcl_moveoop(hcl, hcl->_true);
hcl->_false = hcl_moveoop (hcl, hcl->_false); hcl->_false = hcl_moveoop(hcl, hcl->_false);
for (i = 0; i < HCL_COUNTOF(syminfo); i++) for (i = 0; i < HCL_COUNTOF(syminfo); i++)
{ {
hcl_oop_t tmp; hcl_oop_t tmp;
tmp = *(hcl_oop_t*)((hcl_uint8_t*)hcl + syminfo[i].offset); tmp = *(hcl_oop_t*)((hcl_uint8_t*)hcl + syminfo[i].offset);
tmp = hcl_moveoop (hcl, tmp); tmp = hcl_moveoop(hcl, tmp);
*(hcl_oop_t*)((hcl_uint8_t*)hcl + syminfo[i].offset) = tmp; *(hcl_oop_t*)((hcl_uint8_t*)hcl + syminfo[i].offset) = tmp;
} }
hcl->_character = hcl_moveoop (hcl, hcl->_character); hcl->sysdic = (hcl_oop_dic_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->sysdic);
hcl->_small_integer = hcl_moveoop (hcl, hcl->_small_integer); hcl->processor = (hcl_oop_process_scheduler_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->processor);
hcl->_large_positive_integer = hcl_moveoop (hcl, hcl->_large_positive_integer); hcl->nil_process = (hcl_oop_process_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->nil_process);
hcl->_large_negative_integer = hcl_moveoop (hcl, hcl->_large_negative_integer);
hcl->sysdic = (hcl_oop_dic_t) hcl_moveoop (hcl, (hcl_oop_t)hcl->sysdic);
hcl->processor = (hcl_oop_process_scheduler_t) hcl_moveoop (hcl, (hcl_oop_t)hcl->processor);
hcl->nil_process = (hcl_oop_process_t) hcl_moveoop (hcl, (hcl_oop_t)hcl->nil_process);
for (i = 0; i < hcl->code.lit.len; i++) for (i = 0; i < hcl->code.lit.len; i++)
{ {
/* the literal array ia a NGC object. but the literal objects /* the literal array ia a NGC object. but the literal objects
* pointed by the elements of this array must be gabage-collected. */ * pointed by the elements of this array must be gabage-collected. */
((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i] = ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i] =
hcl_moveoop (hcl, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i]); hcl_moveoop(hcl, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i]);
} }
hcl->p.e = hcl_moveoop (hcl, hcl->p.e); hcl->p.e = hcl_moveoop (hcl, hcl->p.e);
for (i = 0; i < hcl->sem_list_count; i++) for (i = 0; i < hcl->sem_list_count; i++)
{ {
hcl->sem_list[i] = (hcl_oop_semaphore_t)hcl_moveoop (hcl, (hcl_oop_t)hcl->sem_list[i]); hcl->sem_list[i] = (hcl_oop_semaphore_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->sem_list[i]);
} }
for (i = 0; i < hcl->sem_heap_count; i++) for (i = 0; i < hcl->sem_heap_count; i++)
{ {
hcl->sem_heap[i] = (hcl_oop_semaphore_t)hcl_moveoop (hcl, (hcl_oop_t)hcl->sem_heap[i]); hcl->sem_heap[i] = (hcl_oop_semaphore_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->sem_heap[i]);
} }
for (i = 0; i < hcl->tmp_count; i++) for (i = 0; i < hcl->tmp_count; i++)
{ {
*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) if (hcl->initial_context)
hcl->initial_context = (hcl_oop_context_t)hcl_moveoop (hcl, (hcl_oop_t)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->last_retv) hcl->last_retv = hcl_moveoop(hcl, hcl->last_retv);
for (cb = hcl->cblist; cb; cb = cb->next) for (cb = hcl->cblist; cb; cb = cb->next)
{ {

27
lib/hcl.h
View File

@ -1007,14 +1007,6 @@ struct hcl_t
hcl_oop_t _until; /* symbol */ hcl_oop_t _until; /* symbol */
hcl_oop_t _while; /* symbol */ hcl_oop_t _while; /* symbol */
/* == NEVER CHANGE THE ORDER OF FIELDS BELOW == */
/* hcl_ignite() assumes this order. make sure to update symnames in ignite_3() */
hcl_oop_t _character;
hcl_oop_t _small_integer; /* SmallInteger */
hcl_oop_t _large_positive_integer; /* LargePositiveInteger */
hcl_oop_t _large_negative_integer; /* LargeNegativeInteger */
/* == NEVER CHANGE THE ORDER OF FIELDS ABOVE == */
hcl_oop_dic_t symtab; /* system-wide symbol table. */ hcl_oop_dic_t symtab; /* system-wide symbol table. */
hcl_oop_dic_t sysdic; /* system dictionary. */ hcl_oop_dic_t sysdic; /* system dictionary. */
hcl_oop_process_scheduler_t processor; /* instance of ProcessScheduler */ hcl_oop_process_scheduler_t processor; /* instance of ProcessScheduler */
@ -1045,6 +1037,7 @@ struct hcl_t
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; int switch_proc;
hcl_oop_t last_retv;
hcl_ntime_t exec_start_time; hcl_ntime_t exec_start_time;
hcl_ntime_t exec_end_time; hcl_ntime_t exec_end_time;
@ -1466,16 +1459,11 @@ HCL_EXPORT int hcl_executefromip (
hcl_ooi_t initial_ip hcl_ooi_t initial_ip
); );
/** #if defined(HCL_HAVE_INLINE)
* The hcl_invoke() function sends a message named \a mthname to an object static HCL_INLINE hcl_oop_t hcl_getlastretv (hcl_t* hcl) { return hcl->last_retv; }
* named \a objname. #else
*/ # define hcl_getlastretv(hcl) ((hcl)->last_retv)
HCL_EXPORT int hcl_invoke ( #endif
hcl_t* hcl,
const hcl_oocs_t* objname,
const hcl_oocs_t* mthname
);
HCL_EXPORT int hcl_attachio ( HCL_EXPORT int hcl_attachio (
hcl_t* hcl, hcl_t* hcl,
@ -1646,7 +1634,8 @@ HCL_EXPORT hcl_oop_t hcl_makecons (
HCL_EXPORT hcl_oop_t hcl_makearray ( HCL_EXPORT hcl_oop_t hcl_makearray (
hcl_t* hcl, hcl_t* hcl,
hcl_oow_t size hcl_oow_t size,
int ngc
); );
HCL_EXPORT hcl_oop_t hcl_makebytearray ( HCL_EXPORT hcl_oop_t hcl_makebytearray (

9
lib/main.c
View File

@ -1663,6 +1663,10 @@ int main (int argc, char* argv[])
{ {
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot execute - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot execute - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl));
} }
else
{
hcl_logbfmt (hcl, HCL_LOG_STDERR, "OK: EXITED WITH %O\n", hcl_getlastretv(hcl));
}
//cancel_tick(); //cancel_tick();
g_hcl = HCL_NULL; g_hcl = HCL_NULL;
} }
@ -1680,12 +1684,15 @@ int main (int argc, char* argv[])
{ {
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot execute - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot execute - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl));
} }
else
{
hcl_logbfmt (hcl, HCL_LOG_STDERR, "OK: EXITED WITH %O\n", hcl_getlastretv(hcl));
}
//cancel_tick(); //cancel_tick();
g_hcl = HCL_NULL; g_hcl = HCL_NULL;
/*hcl_dumpsymtab (hcl);*/ /*hcl_dumpsymtab (hcl);*/
} }
hcl_close (hcl); hcl_close (hcl);
return 0; return 0;

88
lib/obj.c
View File

@ -35,7 +35,7 @@ void* hcl_allocbytes (hcl_t* hcl, hcl_oow_t size)
if ((hcl->option.trait & HCL_DEBUG_GC) && !(hcl->option.trait & HCL_NOGC)) hcl_gc (hcl); if ((hcl->option.trait & HCL_DEBUG_GC) && !(hcl->option.trait & HCL_NOGC)) hcl_gc (hcl);
#endif #endif
ptr = hcl_allocheapmem (hcl, hcl->curheap, size); ptr = hcl_allocheapmem(hcl, hcl->curheap, size);
if (!ptr && hcl->errnum == HCL_EOOMEM && !(hcl->option.trait & HCL_NOGC)) if (!ptr && hcl->errnum == HCL_EOOMEM && !(hcl->option.trait & HCL_NOGC))
{ {
hcl_gc (hcl); hcl_gc (hcl);
@ -52,7 +52,7 @@ void* hcl_allocbytes (hcl_t* hcl, hcl_oow_t size)
return ptr; return ptr;
} }
hcl_oop_t hcl_allocoopobj (hcl_t* hcl, int brand, hcl_oow_t size) static HCL_INLINE hcl_oop_t alloc_oop_array (hcl_t* hcl, int brand, hcl_oow_t size, int ngc)
{ {
hcl_oop_oop_t hdr; hcl_oop_oop_t hdr;
hcl_oow_t nbytes, nbytes_aligned; hcl_oow_t nbytes, nbytes_aligned;
@ -63,14 +63,21 @@ hcl_oop_t hcl_allocoopobj (hcl_t* hcl, int brand, hcl_oow_t size)
* aligned already. */ * aligned already. */
nbytes_aligned = HCL_ALIGN(nbytes, HCL_SIZEOF(hcl_oop_t)); nbytes_aligned = HCL_ALIGN(nbytes, HCL_SIZEOF(hcl_oop_t));
/* making the number of bytes to allocate a multiple of if (HCL_UNLIKELY(ngc))
* HCL_SIZEOF(hcl_oop_t) will guarantee the starting address {
* of the allocated space to be an even number. hdr = hcl_callocmem(hcl, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned);
* see HCL_OOP_IS_NUMERIC() and HCL_OOP_IS_POINTER() */ }
hdr = hcl_allocbytes (hcl, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned); else
{
/* making the number of bytes to allocate a multiple of
* HCL_SIZEOF(hcl_oop_t) will guarantee the starting address
* of the allocated space to be an even number.
* see HCL_OOP_IS_NUMERIC() and HCL_OOP_IS_POINTER() */
hdr = hcl_allocbytes(hcl, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned);
}
if (!hdr) return HCL_NULL; if (!hdr) return HCL_NULL;
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, ngc, 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); HCL_OBJ_SET_FLAGS_BRAND (hdr, brand);
@ -80,6 +87,12 @@ hcl_oop_t hcl_allocoopobj (hcl_t* hcl, int brand, hcl_oow_t size)
return (hcl_oop_t)hdr; return (hcl_oop_t)hdr;
} }
hcl_oop_t hcl_allocoopobj (hcl_t* hcl, int brand, hcl_oow_t size)
{
return alloc_oop_array (hcl, brand, size, 0);
}
#if defined(HCL_USE_OBJECT_TRAILER) #if defined(HCL_USE_OBJECT_TRAILER)
hcl_oop_t hcl_allocoopobjwithtrailer (hcl_t* hcl, hcl_oow_t size, const hcl_oob_t* bptr, hcl_oow_t blen) hcl_oop_t hcl_allocoopobjwithtrailer (hcl_t* hcl, hcl_oow_t size, const hcl_oob_t* bptr, hcl_oow_t blen)
{ {
@ -91,7 +104,7 @@ hcl_oop_t hcl_allocoopobjwithtrailer (hcl_t* hcl, hcl_oow_t size, const hcl_oob_
nbytes = (size + 1) * HCL_SIZEOF(hcl_oop_t) + blen; nbytes = (size + 1) * HCL_SIZEOF(hcl_oop_t) + blen;
nbytes_aligned = HCL_ALIGN(nbytes, HCL_SIZEOF(hcl_oop_t)); nbytes_aligned = HCL_ALIGN(nbytes, HCL_SIZEOF(hcl_oop_t));
hdr = hcl_allocbytes (hcl, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned); hdr = hcl_allocbytes(hcl, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned);
if (!hdr) return HCL_NULL; if (!hdr) return HCL_NULL;
hdr->_flags = HCL_OBJ_MAKE_FLAGS(HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 0, 0, 0, 1, 0); hdr->_flags = HCL_OBJ_MAKE_FLAGS(HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 0, 0, 0, 1, 0);
@ -116,7 +129,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, int brand, 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 */
@ -135,9 +148,9 @@ static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, int brand, const v
* of the allocated space to be an even number. * of the allocated space to be an even number.
* see HCL_OOP_IS_NUMERIC() and HCL_OOP_IS_POINTER() */ * see HCL_OOP_IS_NUMERIC() and HCL_OOP_IS_POINTER() */
if (HCL_UNLIKELY(ngc)) if (HCL_UNLIKELY(ngc))
hdr = hcl_callocmem (hcl, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned); hdr = hcl_callocmem(hcl, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned);
else else
hdr = hcl_allocbytes (hcl, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned); hdr = hcl_allocbytes(hcl, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned);
if (!hdr) return HCL_NULL; if (!hdr) return HCL_NULL;
hdr->_flags = HCL_OBJ_MAKE_FLAGS(type, unit, extra, 0, 0, ngc, 0, 0); hdr->_flags = HCL_OBJ_MAKE_FLAGS(type, unit, extra, 0, 0, ngc, 0, 0);
@ -163,25 +176,24 @@ static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, int brand, const v
hcl_oop_t hcl_alloccharobj (hcl_t* hcl, int brand, 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, brand, 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, int brand, 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, brand, 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, int brand, 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, brand, 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, int brand, 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, brand, 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);
} }
/* ------------------------------------------------------------------------ * /* ------------------------------------------------------------------------ *
* COMMON OBJECTS * COMMON OBJECTS
* ------------------------------------------------------------------------ */ * ------------------------------------------------------------------------ */
@ -189,17 +201,17 @@ hcl_oop_t hcl_allocwordobj (hcl_t* hcl, int brand, const hcl_oow_t* ptr, hcl_oow
hcl_oop_t hcl_makenil (hcl_t* hcl) hcl_oop_t hcl_makenil (hcl_t* hcl)
{ {
return hcl_allocoopobj (hcl, HCL_BRAND_NIL, 0); return hcl_allocoopobj(hcl, HCL_BRAND_NIL, 0);
} }
hcl_oop_t hcl_maketrue (hcl_t* hcl) hcl_oop_t hcl_maketrue (hcl_t* hcl)
{ {
return hcl_allocoopobj (hcl, HCL_BRAND_TRUE, 0); return hcl_allocoopobj(hcl, HCL_BRAND_TRUE, 0);
} }
hcl_oop_t hcl_makefalse (hcl_t* hcl) hcl_oop_t hcl_makefalse (hcl_t* hcl)
{ {
return hcl_allocoopobj (hcl, HCL_BRAND_FALSE, 0); return hcl_allocoopobj(hcl, HCL_BRAND_FALSE, 0);
} }
hcl_oop_t hcl_makebigint (hcl_t* hcl, int brand, const hcl_liw_t* ptr, hcl_oow_t len) hcl_oop_t hcl_makebigint (hcl_t* hcl, int brand, const hcl_liw_t* ptr, hcl_oow_t len)
@ -209,9 +221,9 @@ hcl_oop_t hcl_makebigint (hcl_t* hcl, int brand, const hcl_liw_t* ptr, hcl_oow_t
HCL_ASSERT (hcl, brand == HCL_BRAND_PBIGINT || brand == HCL_BRAND_NBIGINT); HCL_ASSERT (hcl, brand == HCL_BRAND_PBIGINT || brand == HCL_BRAND_NBIGINT);
#if (HCL_LIW_BITS == HCL_OOW_BITS) #if (HCL_LIW_BITS == HCL_OOW_BITS)
oop = hcl_allocwordobj (hcl, brand, ptr, len); oop = hcl_allocwordobj(hcl, brand, ptr, len);
#elif (HCL_LIW_BITS == HCL_OOHW_BITS) #elif (HCL_LIW_BITS == HCL_OOHW_BITS)
oop = hcl_allochalfwordobj (hcl, brand, ptr, len); oop = hcl_allochalfwordobj(hcl, brand, ptr, len);
#else #else
# error UNSUPPORTED LIW BIT SIZE # error UNSUPPORTED LIW BIT SIZE
#endif #endif
@ -228,7 +240,7 @@ 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, HCL_BRAND_CONS, 2); cons = (hcl_oop_cons_t)hcl_allocoopobj(hcl, HCL_BRAND_CONS, 2);
if (cons) if (cons)
{ {
cons->car = car; cons->car = car;
@ -240,23 +252,22 @@ hcl_oop_t hcl_makecons (hcl_t* hcl, hcl_oop_t car, hcl_oop_t cdr)
return (hcl_oop_t)cons; return (hcl_oop_t)cons;
} }
hcl_oop_t hcl_makearray (hcl_t* hcl, hcl_oow_t size) hcl_oop_t hcl_makearray (hcl_t* hcl, hcl_oow_t size, int ngc)
{ {
return hcl_allocoopobj (hcl, HCL_BRAND_ARRAY, size); 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 hcl_makebytearray (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t size)
{ {
return hcl_allocbyteobj (hcl, HCL_BRAND_BYTE_ARRAY, ptr, size); 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, int ngc) hcl_oop_t hcl_makestring (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len, int ngc)
{ {
/*return hcl_alloccharobj (hcl, HCL_BRAND_STRING, ptr, len);*/ /*return hcl_alloccharobj(hcl, HCL_BRAND_STRING, ptr, len);*/
return alloc_numeric_array (hcl, HCL_BRAND_STRING, ptr, len, HCL_OBJ_TYPE_CHAR, HCL_SIZEOF(hcl_ooch_t), 1, ngc); return alloc_numeric_array(hcl, HCL_BRAND_STRING, ptr, len, HCL_OBJ_TYPE_CHAR, HCL_SIZEOF(hcl_ooch_t), 1, ngc);
} }
/* ------------------------------------------------------------------------ * /* ------------------------------------------------------------------------ *
* NGC HANDLING * NGC HANDLING
* ------------------------------------------------------------------------ */ * ------------------------------------------------------------------------ */
@ -268,7 +279,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)
{ {
return alloc_numeric_array (hcl, HCL_BRAND_BYTE_ARRAY, ptr, len, HCL_OBJ_TYPE_BYTE, HCL_SIZEOF(hcl_oob_t), 0, 1); 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) hcl_oop_t hcl_remakengcbytearray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize)
@ -322,7 +333,6 @@ hcl_oop_t hcl_remakengcarray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize)
return tmp; return tmp;
} }
/* ------------------------------------------------------------------------ * /* ------------------------------------------------------------------------ *
* CONS * CONS
* ------------------------------------------------------------------------ */ * ------------------------------------------------------------------------ */
@ -389,6 +399,22 @@ int hcl_hashobj (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t* xhv)
{ {
hcl_oow_t hv; hcl_oow_t hv;
if (obj == hcl->_nil)
{
*xhv = 0;
return 0;
}
else if (obj == hcl->_true)
{
*xhv = 1;
return 0;
}
else if (obj == hcl->_false)
{
*xhv = 2;
return 0;
}
switch (HCL_OOP_GET_TAG(obj)) switch (HCL_OOP_GET_TAG(obj))
{ {
case HCL_OOP_TAG_SMOOI: case HCL_OOP_TAG_SMOOI:

6
lib/read.c
View File

@ -1427,7 +1427,7 @@ static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv)
} }
hcl_pushtmp (hcl, &head); hcl_pushtmp (hcl, &head);
arr = (hcl_oop_oop_t)hcl_makearray(hcl, count); arr = (hcl_oop_oop_t)hcl_makearray(hcl, count, 0);
hcl_poptmp (hcl); hcl_poptmp (hcl);
if (!arr) return HCL_NULL; if (!arr) return HCL_NULL;
@ -1468,7 +1468,7 @@ done:
switch (concode) switch (concode)
{ {
case HCL_CONCODE_ARRAY: case HCL_CONCODE_ARRAY:
return (hcl_oop_t)hcl_makearray(hcl, 0); return (hcl_oop_t)hcl_makearray(hcl, 0, 0);
case HCL_CONCODE_BYTEARRAY: case HCL_CONCODE_BYTEARRAY:
return (hcl_oop_t)hcl_makebytearray(hcl, HCL_NULL, 0); return (hcl_oop_t)hcl_makebytearray(hcl, HCL_NULL, 0);
case HCL_CONCODE_DIC: case HCL_CONCODE_DIC:
@ -1711,7 +1711,7 @@ static int get_symbol_array_literal (hcl_t* hcl, hcl_oop_t* xlit)
return -1; return -1;
} }
sa = hcl_makearray (hcl, hcl->c->r.salit.size); sa = hcl_makearray(hcl, hcl->c->r.salit.size, 0);
if (!sa) if (!sa)
{ {
hcl->c->r.salit.size = 0; /* reset literal count... */ hcl->c->r.salit.size = 0; /* reset literal count... */

2
lib/sym.c
View File

@ -61,7 +61,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
} }
hcl_pushtmp (hcl, (hcl_oop_t*)&oldbuc); hcl_pushtmp (hcl, (hcl_oop_t*)&oldbuc);
newbuc = (hcl_oop_oop_t)hcl_makearray (hcl, newsz); newbuc = (hcl_oop_oop_t)hcl_makearray(hcl, newsz, 0);
hcl_poptmp (hcl); hcl_poptmp (hcl);
if (!newbuc) return HCL_NULL; if (!newbuc) return HCL_NULL;