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

added some primitive functions

Browse Source
This commit is contained in:
hyung-hwan 2016-10-25 13:44:38 +00:00
parent 15b995801d
commit ccca08c725
5 changed files with 129 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
lib/comp.c
View File

@ -629,7 +629,7 @@ enum
COP_POST_WHILE_BODY,
COP_POST_WHILE_COND,
COP_UPDATE_BREAK,
COP_UPDATE_BREAK
};
/* ========================================================================= */
@ -1365,7 +1365,6 @@ static int compile_object_list (hcl_t* hcl)
}
else
{
hcl_oop_t car, cdr;
if (cop != COP_COMPILE_ARGUMENT_LIST)

30
lib/exec.c
View File

@ -889,7 +889,6 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
*/
/* the receiver must be a block context */
//HCL_ASSERT (HCL_CLASSOF(hcl, rcv_blkctx) == hcl->_block_context);
HCL_ASSERT (HCL_IS_CONTEXT (hcl, rcv_blkctx));
if (rcv_blkctx->receiver_or_source != hcl->_nil)
{
@ -1042,7 +1041,7 @@ static int start_initial_process_and_context (hcl_t* hcl)
ctx->method_or_nargs = HCL_SMOOI_TO_OOP(0);
/* TODO: XXXXX */
ctx->ntmprs = HCL_SMOOI_TO_OOP(0);
ctx->home = ctx; // is this correct???
ctx->home = ctx; /* // is this correct??? */
/* END XXXXX */
/* [NOTE]
@ -1867,9 +1866,10 @@ static int execute (hcl_t* hcl)
* }
*/
/*
// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context) == hcl->_block_context);
// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->processor->active->initial_context) == hcl->_block_context);
*/
/* decrement the instruction pointer back to the return instruction.
* even if the context is reentered, it will just return.
*hcl->ip--;*/
@ -1886,7 +1886,9 @@ static int execute (hcl_t* hcl)
if (hcl->active_context->origin == hcl->active_context)
{
/* returning from a method */
/*
// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context) == hcl->_method_context);
*/
hcl->ip = -1;
}
else
@ -1894,13 +1896,14 @@ static int execute (hcl_t* hcl)
hcl_oop_context_t ctx;
/* method return from within a block(including a non-local return) */
/*
// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context) == hcl->_block_context);
*/
ctx = hcl->active_context;
while ((hcl_oop_t)ctx != hcl->_nil)
{
#if 0
// /* TODO: XXXXXXXXXXXXXX for STACK UNWINDING... */
/* TODO: XXXXXXXXXXXXXX for STACK UNWINDING... */
if (HCL_CLASSOF(hcl, ctx) == hcl->_method_context)
{
hcl_ooi_t preamble;
@ -1921,7 +1924,9 @@ static int execute (hcl_t* hcl)
}
/* cannot return from a method that has returned already */
/*
// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context->origin) == hcl->_method_context);
*/
HCL_ASSERT (hcl->active_context->origin->ip == HCL_SMOOI_TO_OOP(-1));
HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, "Error - cannot return from dead context\n");
@ -1933,11 +1938,15 @@ static int execute (hcl_t* hcl)
hcl->active_context->origin->ip = HCL_SMOOI_TO_OOP(-1);
}
/*
// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context->origin) == hcl->_method_context);
*/
/* restore the stack pointer */
hcl->sp = HCL_OOP_TO_SMOOI(hcl->active_context->origin->sp);
SWITCH_ACTIVE_CONTEXT (hcl, hcl->active_context->origin->sender);
#if 0
XXXXX
if (unwind_protect)
{
static hcl_ooch_t fbm[] = {
@ -1953,6 +1962,7 @@ static int execute (hcl_t* hcl)
}
else
{
#endif
/* push the return value to the stack of the new active context */
HCL_STACK_PUSH (hcl, return_value);
@ -1961,7 +1971,9 @@ static int execute (hcl_t* hcl)
/* the new active context is the fake initial context.
* this context can't get executed further. */
HCL_ASSERT ((hcl_oop_t)hcl->active_context->sender == hcl->_nil);
/*
// HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context) == hcl->_method_context);
*/
HCL_ASSERT (hcl->active_context->receiver_or_source == hcl->_nil);
HCL_ASSERT (hcl->active_context == hcl->processor->active->initial_context);
HCL_ASSERT (hcl->active_context->origin == hcl->processor->active->initial_context->origin);
@ -1984,15 +1996,18 @@ static int execute (hcl_t* hcl)
* the caller to hcl_execute() can fetch it to return it to the system */
}
}
#if 0
}
#endif
break;
case HCL_CODE_RETURN_FROM_BLOCK:
LOG_INST_0 (hcl, "return_from_block");
/*
// HCL_ASSERT(HCL_CLASSOF(hcl, hcl->active_context) == hcl->_block_context);
*/
if (hcl->active_context == hcl->processor->active->initial_context)
{
/* the active context to return from is an initial context of
@ -2010,7 +2025,9 @@ static int execute (hcl_t* hcl)
/* the process stack is shared. the return value
* doesn't need to get moved. */
/*
//XXX SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)hcl->active_context->sender);
*/
if (hcl->active_context->sender == hcl->processor->active->initial_context)
{
terminate_process (hcl, hcl->processor->active);
@ -2099,7 +2116,6 @@ static int execute (hcl_t* hcl)
* context and activates the cloned context.
* this base block context is created with no
* stack for this reason. */
//blkctx = (hcl_oop_context_t)hcl_instantiate (hcl, hcl->_block_context, HCL_NULL, 0);
blkctx = (hcl_oop_context_t)make_context (hcl, 0);
if (!blkctx) return -1;

1
lib/hcl.h
View File

@ -1055,6 +1055,7 @@ typedef struct hcl_cons_t hcl_cons_t;
typedef struct hcl_cons_t* hcl_oop_cons_t;
#define HCL_IS_NIL(hcl,v) (v == (hcl)->_nil)
#define HCL_IS_INTEGER(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_INTEGER)
#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)

20
lib/main.c
View File

@ -46,6 +46,7 @@
# include <os2.h>
#elif defined(__MSDOS__)
# include <dos.h>
# include <time.h>
#elif defined(macintosh)
# include <Timer.h>
#else
@ -353,10 +354,15 @@ static int write_all (int fd, const char* ptr, hcl_oow_t len)
if (wr <= -1)
{
if (errno == EAGAIN || errno == EWOULDBLOCK)
{
continue;
}
#if defined(EAGAIN) && defined(EWOULDBLOCK) && (EAGAIN == EWOULDBLOCK)
if (errno == EAGAIN) continue;
#else
# if defined(EAGAIN)
if (errno == EAGAIN) continue;
#elif defined(EWOULDBLOCK)
if (errno == EWOULDBLOCK) continue;
#endif
#endif
return -1;
}
@ -401,8 +407,12 @@ if (mask & HCL_LOG_GC) return; /* don't show gc logs */
}
if (write_all (1, ts, tslen) <= -1)
{
char ttt[10];
char ttt[20];
#if defined(__MSDOS__) && defined(_INTELC32_)
sprintf (ttt, "ERR: %d\n", errno);
#else
snprintf (ttt, sizeof(ttt), "ERR: %d\n", errno);
#endif
write (1, ttt, strlen(ttt));
}

90
lib/prim.c
View File

@ -163,9 +163,97 @@ static int prim_log (hcl_t* hcl, hcl_ooi_t nargs)
/* ------------------------------------------------------------------------- */
static int oop_to_ooi (hcl_t* hcl, hcl_oop_t iv, hcl_ooi_t* ov)
{
if (HCL_OOP_IS_SMOOI(iv))
{
*ov = HCL_OOP_TO_SMOOI(iv);
return 0;
}
else if (HCL_IS_INTEGER(hcl, iv))
{
*ov = (hcl_ooi_t)((hcl_oop_word_t)iv)->slot[0];
return 0;
}
else
{
/* TODO: set error number or something...to indicate primitive failure... */
return -1;
}
}
static int prim_plus (hcl_t* hcl, hcl_ooi_t nargs)
{
hcl_ooi_t x = 0;
hcl_oow_t i;
hcl_oop_t arg, ret;
for (i = 0; i < nargs; i++)
{
hcl_ooi_t v;
arg = HCL_STACK_GETARG(hcl, nargs, i);
if (oop_to_ooi(hcl, arg, &v) <= -1) return -1;
x += v;
}
ret = hcl_makeinteger (hcl, x);
if (!ret) return -1;
HCL_STACK_SETRET (hcl, nargs, ret);
return 0;
}
static int prim_minus (hcl_t* hcl, hcl_ooi_t nargs)
{
hcl_ooi_t x = 0;
hcl_oow_t i;
hcl_oop_t arg, ret;
if (nargs > 0)
{
arg = HCL_STACK_GETARG(hcl, nargs, 0);
if (oop_to_ooi(hcl, arg, &x) <= -1) return -1;
for (i = 1; i < nargs; i++)
{
hcl_ooi_t v;
arg = HCL_STACK_GETARG(hcl, nargs, i);
if (oop_to_ooi(hcl, arg, &v) <= -1) return -1;
x -= v;
}
}
ret = hcl_makeinteger (hcl, x);
if (!ret) return -1;
HCL_STACK_SETRET (hcl, nargs, ret);
return 0;
}
/* ------------------------------------------------------------------------- */
static prim_t builtin_prims[] =
{
{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_log, 3, { 'l','o','g' } }
{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_log, 3, { 'l','o','g' } },
/*
{ 2, 2, prim_gt, 1, { '>' } },
{ 2, 2, prim_ge, 2, { '>','=' } },
{ 2, 2, prim_lt, 1, { '<' } },
{ 2, 2, prim_le, 2, { '<','=' } },
{ 2, 2, prim_eq, 1, { '=' } },
{ 2, 2, prim_ne, 2, { '/','=' } },
{ 2, 2, prim_eql, 3, { 'e','q','l' } },
{ 2, 2, prim_max, 3, { 'm','a','x' } },
{ 2, 2, prim_min, 3, { 'm','i','n' } },
{ 2, 2, prim_and, 3, { 'a','n','d' } },
{ 2, 2, prim_or, 2, { 'o','r' } },
{ 1, 1, prim_not, 3, { 'n','o','t' } }, */
{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_plus, 1, { '+' } },
{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_minus, 1, { '-' } }
};