diff --git a/lib/comp.c b/lib/comp.c index fa3bb70..566776e 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -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) diff --git a/lib/exec.c b/lib/exec.c index bca50d8..2a9eae2 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -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; diff --git a/lib/hcl.h b/lib/hcl.h index ea8a23a..fd213ac 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -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) diff --git a/lib/main.c b/lib/main.c index d869bb3..097190b 100644 --- a/lib/main.c +++ b/lib/main.c @@ -46,6 +46,7 @@ # include #elif defined(__MSDOS__) # include +# include #elif defined(macintosh) # include #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)); } diff --git a/lib/prim.c b/lib/prim.c index 24fd604..6f1b979 100644 --- a/lib/prim.c +++ b/lib/prim.c @@ -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, { '-' } } };