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

working on the block expression compilation
Some checks failed
continuous-integration/drone/push Build is failing
Details

Browse Source
This commit is contained in:
hyung-hwan 2023-11-10 00:03:03 +09:00
parent 9110a083eb
commit 5a28ab3749
36 changed files with 1108 additions and 1044 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
bin/main.c
View File

@ -97,6 +97,7 @@ struct xtn_t
const char* udo_path;
int vm_running;
int extra_cflags;
/*hcl_oop_t sym_errstr;*/
};
@ -447,11 +448,18 @@ static hcl_oop_t execute_in_batch_mode (hcl_t* hcl, int verbose)
static int on_fed_cnode_in_interactive_mode (hcl_t* hcl, hcl_cnode_t* obj)
{
if (hcl_compile(hcl, obj, HCL_COMPILE_CLEAR_CODE | HCL_COMPILE_CLEAR_FNBLK) <= -1) return -1;
xtn_t* xtn = (xtn_t*)hcl_getxtn(hcl);
if (hcl_compile(hcl, obj, HCL_COMPILE_CLEAR_CODE | HCL_COMPILE_CLEAR_FNBLK | xtn->extra_cflags) <= -1) return -1;
execute_in_interactive_mode (hcl);
return 0;
}
static int on_fed_cnode_in_batch_mode (hcl_t* hcl, hcl_cnode_t* obj)
{
xtn_t* xtn = (xtn_t*)hcl_getxtn(hcl);
return hcl_compile(hcl, obj, xtn->extra_cflags);
}
static int feed_loop (hcl_t* hcl, xtn_t* xtn, int verbose)
{
FILE* fp = HCL_NULL;
@ -468,7 +476,8 @@ static int feed_loop (hcl_t* hcl, xtn_t* xtn, int verbose)
/* override the default cnode handler. the default one simply
* compiles the expression node without execution */
if (hcl_beginfeed(hcl, is_tty? on_fed_cnode_in_interactive_mode: HCL_NULL) <= -1)
/*if (hcl_beginfeed(hcl, is_tty? on_fed_cnode_in_interactive_mode: HCL_NULL) <= -1)*/
if (hcl_beginfeed(hcl, is_tty? on_fed_cnode_in_interactive_mode: on_fed_cnode_in_batch_mode) <= -1)
{
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot begin feed - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl));
goto oops;
@ -477,37 +486,41 @@ static int feed_loop (hcl_t* hcl, xtn_t* xtn, int verbose)
/* [NOTE] it isn't a very nice idea to get this internal data and use it with read_input() */
while (1)
{
#if 0
hcl_bch_t buf[1024];
hcl_oow_t xlen;
xlen = fread(buf, HCL_SIZEOF(buf[0]), HCL_COUNTOF(buf), fp);
if (xlen > 0 && hcl_feedbchars(hcl, buf, xlen) <= -1) goto feed_error;
if (xlen < HCL_COUNTOF(buf))
if (is_tty)
{
if (ferror(fp))
hcl_bch_t bch;
int ch = fgetc(fp);
if (ch == EOF)
{
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: failed to read - %hs - %hs\n", xtn->cci_path, strerror(errno));
goto oops;
if (ferror(fp))
{
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: failed to read - %hs - %hs\n", xtn->cci_path, strerror(errno));
goto oops;
}
break;
}
break;
}
#else
hcl_bch_t bch;
int ch = fgetc(fp);
if (ch == EOF)
{
if (ferror(fp))
{
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: failed to read - %hs - %hs\n", xtn->cci_path, strerror(errno));
goto oops;
}
break;
}
bch = ch;
if (hcl_feedbchars(hcl, &bch, 1) <= -1) goto feed_error;
#endif
bch = ch;
if (hcl_feedbchars(hcl, &bch, 1) <= -1) goto feed_error;
}
else
{
hcl_bch_t buf[1024];
hcl_oow_t xlen;
xlen = fread(buf, HCL_SIZEOF(buf[0]), HCL_COUNTOF(buf), fp);
if (xlen > 0 && hcl_feedbchars(hcl, buf, xlen) <= -1) goto feed_error;
if (xlen < HCL_COUNTOF(buf))
{
if (ferror(fp))
{
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: failed to read - %hs - %hs\n", xtn->cci_path, strerror(errno));
goto oops;
}
break;
}
}
}
if (hcl_endfeed(hcl) <= -1)
@ -549,7 +562,7 @@ int main (int argc, char* argv[])
};
static hcl_bopt_t opt =
{
"l:v",
"l:xv",
lopt
};
@ -557,7 +570,7 @@ int main (int argc, char* argv[])
hcl_oow_t heapsize = DEFAULT_HEAPSIZE;
int verbose = 0;
int show_info = 0;
/*int experimental = 0;*/
int experimental = 0;
#if defined(HCL_BUILD_DEBUG)
const char* dbgopt = HCL_NULL;
@ -581,9 +594,9 @@ int main (int argc, char* argv[])
logopt = opt.arg;
break;
/*case 'x':
case 'x':
experimental = 1;
break;*/
break;
case 'v':
verbose = 1;
@ -695,6 +708,7 @@ int main (int argc, char* argv[])
goto oops;
}
if (experimental) xtn->extra_cflags |= HCL_COMPILE_ENABLE_BLOCK;
xtn->cci_path = argv[opt.ind++]; /* input source code file */
if (opt.ind < argc) xtn->udo_path = argv[opt.ind++];

4
lib/cnode.c
View File

@ -193,9 +193,7 @@ redo:
HCL_ASSERT (hcl, tmp1 != HCL_NULL);
hcl_freemem (hcl, c);
hcl_freecnode (hcl, tmp1); /* TODO: remove recursion? */
if (tmp2)
{
c = tmp2;
@ -210,9 +208,7 @@ redo:
hcl_cnode_t* tmp;
tmp = c->u.shell.obj;
hcl_freemem (hcl, c);
if (tmp)
{
c = tmp;

76
lib/comp.c
View File

@ -684,9 +684,9 @@ static int emit_double_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
/* MAKE_FUNCTION is a quad-parameter instruction.
* The caller must emit two more parameters after the call to this function.
* however the instruction format is the same up to the second
* parameters between MAKE_FUNCTION and MAKE_BLOCK.
* parameters between MAKE_FUNCTION and MAKE_LAMBDA.
*/
case HCL_CODE_MAKE_BLOCK:
case HCL_CODE_MAKE_LAMBDA:
case HCL_CODE_MAKE_FUNCTION:
case HCL_CODE_CALL_R:
case HCL_CODE_SEND_R:
@ -1129,8 +1129,8 @@ static void pop_fnblk (hcl_t* hcl)
{
hcl_oow_t attr_mask;
/* patch the temporaries mask parameter for the MAKE_BLOCK or MAKE_FUNCTION instruction */
HCL_ASSERT (hcl, hcl->code.bc.ptr[fbi->make_inst_pos] == HCL_CODE_MAKE_BLOCK ||
/* patch the temporaries mask parameter for the MAKE_LAMBDA or MAKE_FUNCTION instruction */
HCL_ASSERT (hcl, hcl->code.bc.ptr[fbi->make_inst_pos] == HCL_CODE_MAKE_LAMBDA ||
hcl->code.bc.ptr[fbi->make_inst_pos] == HCL_CODE_MAKE_FUNCTION);
/* the total number of temporaries in this function block must be the sum of
@ -1138,7 +1138,7 @@ static void pop_fnblk (hcl_t* hcl)
HCL_ASSERT (hcl, fbi->tmprcnt - hcl->c->tv.wcount == fbi->tmpr_nargs + fbi->tmpr_nrvars + fbi->tmpr_nlvars);
/* the temporaries mask is a bit-mask that encodes the counts of different temporary variables.
* and it's split to two intruction parameters when used with MAKE_BLOCK and MAKE_FUNCTION */
* and it's split to two intruction parameters when used with MAKE_LAMBDA and MAKE_FUNCTION */
attr_mask = ENCODE_BLK_MASK((fbi->fun_type == FUN_CIM), fbi->tmpr_va, fbi->tmpr_nargs, fbi->tmpr_nrvars, fbi->tmpr_nlvars);
patch_double_long_params_with_oow (hcl, fbi->make_inst_pos + 1, attr_mask);
}
@ -2702,13 +2702,43 @@ static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun)
HCL_ASSERT (hcl, nargs + nrvars == hcl->c->tv.wcount - saved_tv_wcount);
obj = HCL_CNODE_CONS_CDR(obj);
tv_dup_start = hcl->c->tv.s.len;
if (collect_vardcls(hcl, obj, &obj, tv_dup_start, &nlvars, "local") <= -1) return -1;
if (nlvars > MAX_CODE_NBLKLVARS)
if (hcl->c->flags & HCL_COMPILE_ENABLE_BLOCK)
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARFLOOD, HCL_CNODE_GET_LOC(args), HCL_NULL, "too many(%zu) variables in %.*js", nlvars, HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd));
return -1;
hcl_cnode_t* bdy;
if (!obj || !HCL_CNODE_IS_CONS(obj))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLOCK, HCL_CNODE_GET_LOC(args), HCL_NULL, "block expression expected as body in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd));
return -1;
}
bdy = HCL_CNODE_CONS_CAR(obj);
if (!bdy || !HCL_CNODE_IS_CONS_CONCODED(bdy, HCL_CONCODE_BLOCK))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLOCK, HCL_CNODE_GET_LOC(obj), HCL_NULL, "block expression expected as body in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd));
return -1;
}
if (HCL_CNODE_CONS_CDR(bdy))
{
/* TODO: change error code */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNED, HCL_CNODE_GET_LOC(obj), HCL_NULL, "redundant code prohibited after body in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd));
return -1;
}
nlvars = 0; /* no known local variables until the actual block is processed */
}
else
{
tv_dup_start = hcl->c->tv.s.len;
if (collect_vardcls(hcl, obj, &obj, tv_dup_start, &nlvars, "local") <= -1) return -1;
if (nlvars > MAX_CODE_NBLKLVARS)
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARFLOOD, HCL_CNODE_GET_LOC(args), HCL_NULL, "too many(%zu) variables in %.*js", nlvars, HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd));
return -1;
}
}
HCL_ASSERT (hcl, nargs + nrvars + nlvars == hcl->c->tv.wcount - saved_tv_wcount);
@ -2726,8 +2756,8 @@ static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun)
}
else
{
/* MAKE_BLOCK attr_mask_1 attr_mask_2 - will patch attr_mask in pop_fnblk() */
if (emit_double_param_instruction(hcl, HCL_CODE_MAKE_BLOCK, 0, 0, HCL_CNODE_GET_LOC(cmd)) <= -1) return -1;
/* MAKE_LAMBDA attr_mask_1 attr_mask_2 - will patch attr_mask in pop_fnblk() */
if (emit_double_param_instruction(hcl, HCL_CODE_MAKE_LAMBDA, 0, 0, HCL_CNODE_GET_LOC(cmd)) <= -1) return -1;
}
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); /* guaranteed in emit_byte_instruction() */
@ -3791,6 +3821,10 @@ static int compile_cons_mlist_expression (hcl_t* hcl, hcl_cnode_t* obj, int nret
return 0;
}
static int compile_cons_block_expression (hcl_t* hcl, hcl_cnode_t* obj, int nrets)
{
}
static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_cnode_t* obj)
{
hcl_var_info_t vi;
@ -4112,9 +4146,12 @@ redo:
break;
case HCL_CONCODE_BLOCK:
/* TODO: not implemented yet */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_INTERN, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "internal error - block not implemented");
return -1;
if (!(hcl->c->flags & HCL_COMPILE_ENABLE_BLOCK))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLOCKBANNED, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "block expression disallowed");
return -1;
}
if (compile_cons_block_expression(hcl, oprnd, 0) <= -1) return -1;
break;
case HCL_CONCODE_ARRAY:
@ -4158,6 +4195,11 @@ redo:
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNED, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "empty message send list");
return -1;
case HCL_CONCODE_BLOCK:
/* TODO: may have to allow it.. */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNED, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "empty block list");
return -1;
case HCL_CONCODE_ARRAY:
if (emit_single_param_instruction(hcl, HCL_CODE_MAKE_ARRAY, 0, HCL_CNODE_GET_LOC(oprnd)) <= -1) return -1;
goto done;
@ -5237,6 +5279,8 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
hcl_bitmask_t log_default_type_mask;
hcl_fnblk_info_t top_fnblk_saved;
hcl->c->flags = flags;
HCL_ASSERT (hcl, GET_TOP_CFRAME_INDEX(hcl) < 0);
if (flags & HCL_COMPILE_CLEAR_CODE)
{
@ -5292,7 +5336,7 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
/* keep a virtual function block for the top-level compilation.
* pass HCL_TYPE_MAX(hcl_oow_t) as make_inst_pos because there is
* no actual MAKE_BLOCK/MAKE_FUNCTION instruction which otherwise
* no actual MAKE_LAMBDA/MAKE_FUNCTION instruction which otherwise
* would be patched in pop_fnblk(). */
if (push_fnblk(hcl, HCL_NULL, 0, 0, 0, hcl->c->tv.wcount, hcl->c->tv.wcount, hcl->c->tv.s.len, HCL_TYPE_MAX(hcl_oow_t), 0, FUN_PLAIN) <= -1) return -1; /* must not goto oops */
}

4
lib/decode.c
View File

@ -712,14 +712,14 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
break;
}
case HCL_CODE_MAKE_BLOCK:
case HCL_CODE_MAKE_LAMBDA:
/* b1 - block mask
* b2 - block mask */
FETCH_PARAM_CODE_TO (hcl, b1);
FETCH_PARAM_CODE_TO (hcl, b2);
b1 = (b1 << (8 * HCL_CODE_LONG_PARAM_SIZE)) | b2;
LOG_INST_5 (hcl, "make_block %zu %zu %zu %zu %zu",
LOG_INST_5 (hcl, "make_lambda %zu %zu %zu %zu %zu",
GET_BLK_MASK_INSTA(b1),
GET_BLK_MASK_VA(b1),
GET_BLK_MASK_NARGS(b1),

4
lib/err.c
View File

@ -160,7 +160,9 @@ static char* synerrstr[] =
"unbalanced key/value pair",
"unbalanced parenthesis/brace/bracket",
"empty x-list",
"empty m-list"
"empty m-list",
"block expression expected"
"block expression disallowed"
};
/* --------------------------------------------------------------------------

48
lib/exec.c
View File

@ -427,13 +427,13 @@ static HCL_INLINE void fill_function_data (hcl_t* hcl, hcl_oop_function_t func,
func->attr_mask = HCL_SMOOI_TO_OOP(attr_mask);
}
static HCL_INLINE hcl_oop_block_t make_block (hcl_t* hcl)
static HCL_INLINE hcl_oop_lambda_t make_lambda (hcl_t* hcl)
{
/* create a base block used for creation of a block context */
return (hcl_oop_block_t)hcl_allocoopobj(hcl, HCL_BRAND_BLOCK, HCL_BLOCK_NAMED_INSTVARS);
return (hcl_oop_lambda_t)hcl_allocoopobj(hcl, HCL_BRAND_LAMBDA, HCL_BLOCK_NAMED_INSTVARS);
}
static HCL_INLINE void fill_block_data (hcl_t* hcl, hcl_oop_block_t blk, hcl_ooi_t attr_mask, hcl_ooi_t ip, hcl_oop_context_t homectx)
static HCL_INLINE void fill_block_data (hcl_t* hcl, hcl_oop_lambda_t blk, hcl_ooi_t attr_mask, hcl_ooi_t ip, hcl_oop_context_t homectx)
{
HCL_ASSERT (hcl, attr_mask >= 0 && attr_mask <= HCL_SMOOI_MAX);
HCL_ASSERT (hcl, ip >= 0 && ip <= HCL_SMOOI_MAX);
@ -1897,7 +1897,7 @@ void hcl_releaseiohandle (hcl_t* hcl, hcl_ooi_t io_handle)
/* ------------------------------------------------------------------------- */
static int prepare_new_context (hcl_t* hcl, hcl_oop_block_t op_blk, hcl_ooi_t nargs, int nargs_offset, hcl_ooi_t req_nrvars, int copy_args, int is_msgsend, hcl_ooi_t msg_ivaroff, hcl_oop_context_t* pnewctx)
static int prepare_new_context (hcl_t* hcl, hcl_oop_lambda_t op_blk, hcl_ooi_t nargs, int nargs_offset, hcl_ooi_t req_nrvars, int copy_args, int is_msgsend, hcl_ooi_t msg_ivaroff, hcl_oop_context_t* pnewctx)
{
/* prepare a new block context for activation.
* the passed block context becomes the base for a new block context. */
@ -1908,7 +1908,7 @@ static int prepare_new_context (hcl_t* hcl, hcl_oop_block_t op_blk, hcl_ooi_t na
hcl_ooi_t fixed_nargs, actual_nargs, excess_nargs;
/* the receiver must be a block context */
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk));
HCL_ASSERT (hcl, HCL_IS_LAMBDA(hcl, op_blk));
attr_mask = HCL_OOP_TO_SMOOI(op_blk->attr_mask);
@ -1992,11 +1992,11 @@ static int prepare_new_context (hcl_t* hcl, hcl_oop_block_t op_blk, hcl_ooi_t na
return 0;
}
static HCL_INLINE int __activate_block (hcl_t* hcl, hcl_oop_block_t op_blk, hcl_ooi_t nargs, hcl_ooi_t nrvars, int is_msgsend, hcl_ooi_t msg_ivaroff, hcl_oop_context_t* pnewctx)
static HCL_INLINE int __activate_block (hcl_t* hcl, hcl_oop_lambda_t op_blk, hcl_ooi_t nargs, hcl_ooi_t nrvars, int is_msgsend, hcl_ooi_t msg_ivaroff, hcl_oop_context_t* pnewctx)
{
int x;
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk));
HCL_ASSERT (hcl, HCL_IS_LAMBDA(hcl, op_blk));
x = prepare_new_context(
hcl,
@ -2018,12 +2018,12 @@ static HCL_INLINE int __activate_block (hcl_t* hcl, hcl_oop_block_t op_blk, hcl_
static HCL_INLINE int activate_block (hcl_t* hcl, hcl_ooi_t nargs, hcl_ooi_t nrvars)
{
hcl_oop_block_t op_blk;
hcl_oop_lambda_t op_blk;
hcl_oop_context_t newctx;
int x;
op_blk = (hcl_oop_block_t)HCL_STACK_GETOP(hcl, nargs);
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk));
op_blk = (hcl_oop_lambda_t)HCL_STACK_GETOP(hcl, nargs);
HCL_ASSERT (hcl, HCL_IS_LAMBDA(hcl, op_blk));
x = __activate_block(hcl, op_blk, nargs, nrvars, 0, 0, &newctx);
if (HCL_UNLIKELY(x <= -1)) return -1;
@ -2143,7 +2143,7 @@ static HCL_INLINE int call_primitive (hcl_t* hcl, hcl_ooi_t nargs)
/* ------------------------------------------------------------------------- */
static hcl_oop_block_t find_cmethod_noseterr (hcl_t* hcl, hcl_oop_class_t class_, hcl_oop_t op_name, int to_super, hcl_ooi_t* ivaroff, hcl_oop_class_t* owner)
static hcl_oop_lambda_t find_cmethod_noseterr (hcl_t* hcl, hcl_oop_class_t class_, hcl_oop_t op_name, int to_super, hcl_ooi_t* ivaroff, hcl_oop_class_t* owner)
{
hcl_oocs_t name;
@ -2184,7 +2184,7 @@ static hcl_oop_block_t find_cmethod_noseterr (hcl_t* hcl, hcl_oop_class_t class_
/* ivaroff isn't useful for a clas smethod but is useful for class instatiation method
* (INSTA bit on in the mask field) */
*ivaroff = HCL_OOP_TO_SMOOI(class_->nivars_super);
return (hcl_oop_block_t)HCL_CONS_CAR(val); /* car - class method, cdr - instance method */
return (hcl_oop_lambda_t)HCL_CONS_CAR(val); /* car - class method, cdr - instance method */
}
}
}
@ -2195,7 +2195,7 @@ static hcl_oop_block_t find_cmethod_noseterr (hcl_t* hcl, hcl_oop_class_t class_
return HCL_NULL;
}
static hcl_oop_block_t find_imethod_noseterr (hcl_t* hcl, hcl_oop_class_t class_, hcl_oop_t op_name, int to_super, hcl_ooi_t* ivaroff, hcl_oop_class_t* owner)
static hcl_oop_lambda_t find_imethod_noseterr (hcl_t* hcl, hcl_oop_class_t class_, hcl_oop_t op_name, int to_super, hcl_ooi_t* ivaroff, hcl_oop_class_t* owner)
{
hcl_oocs_t name;
@ -2232,7 +2232,7 @@ static hcl_oop_block_t find_imethod_noseterr (hcl_t* hcl, hcl_oop_class_t class_
/* TODO: futher check if it's a method block? */
*owner = class_;
*ivaroff = HCL_OOP_TO_SMOOI(class_->nivars_super);
return (hcl_oop_block_t)HCL_CONS_CDR(val); /* car - class method, cdr - instance method */
return (hcl_oop_lambda_t)HCL_CONS_CDR(val); /* car - class method, cdr - instance method */
}
}
}
@ -2245,7 +2245,7 @@ static hcl_oop_block_t find_imethod_noseterr (hcl_t* hcl, hcl_oop_class_t class_
static HCL_INLINE int send_message (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t msg, int to_super, hcl_ooi_t nargs, hcl_ooi_t nrvars)
{
hcl_oop_block_t mth_blk;
hcl_oop_lambda_t mth_blk;
hcl_oop_context_t newctx;
hcl_oop_class_t class_, owner;
hcl_ooi_t ivaroff;
@ -3688,7 +3688,7 @@ static int execute (hcl_t* hcl)
LOG_INST_2 (hcl, "call %zu %zu", b1, b2);
rcv = HCL_STACK_GETOP(hcl, b1);
if (HCL_IS_BLOCK(hcl, rcv))
if (HCL_IS_LAMBDA(hcl, rcv))
{
if (activate_block(hcl, b1, b2) <= -1) goto call2_failed;
break;
@ -3729,7 +3729,7 @@ static int execute (hcl_t* hcl)
if (activate_function(hcl, b1) <= -1) goto call_failed;
break;
case HCL_BRAND_BLOCK:
case HCL_BRAND_LAMBDA:
if (activate_block(hcl, b1, 0) <= -1) goto call_failed;
break;
@ -4611,16 +4611,16 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
break;
}
case HCL_CODE_MAKE_BLOCK:
case HCL_CODE_MAKE_LAMBDA:
{
hcl_oop_block_t blkobj;
hcl_oop_lambda_t blkobj;
/* b1 - block temporaries mask
* b2 - block temporaries mask */
FETCH_PARAM_CODE_TO (hcl, b1);
FETCH_PARAM_CODE_TO (hcl, b2);
b1 = (b1 << (8 * HCL_CODE_LONG_PARAM_SIZE)) | b2;
LOG_INST_5 (hcl, "make_block %zu %zu %zu %zu %zu",
LOG_INST_5 (hcl, "make_lambda %zu %zu %zu %zu %zu",
GET_BLK_MASK_INSTA(b1),
GET_BLK_MASK_VA(b1),
GET_BLK_MASK_NARGS(b1),
@ -4629,7 +4629,7 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
HCL_ASSERT (hcl, b1 >= 0);
blkobj = make_block(hcl);
blkobj = make_lambda(hcl);
if (HCL_UNLIKELY(!blkobj)) goto oops;
/* the long forward jump instruction has the format of
@ -4790,13 +4790,13 @@ hcl_pfrc_t hcl_pf_process_current (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
hcl_pfrc_t hcl_pf_process_fork (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
{
hcl_oop_block_t blk;
hcl_oop_lambda_t blk;
hcl_oop_context_t newctx;
hcl_oop_process_t newprc;
int x;
blk = (hcl_oop_block_t)HCL_STACK_GETARG(hcl, nargs, 0);
if (!HCL_IS_BLOCK(hcl, blk))
blk = (hcl_oop_lambda_t)HCL_STACK_GETARG(hcl, nargs, 0);
if (!HCL_IS_LAMBDA(hcl, blk))
{
hcl_seterrbfmt (hcl, HCL_EINVAL, "parameter not block - %O", blk);
return HCL_PF_FAILURE;

9
lib/hcl-prv.h
View File

@ -641,6 +641,9 @@ struct hcl_frd_t
struct hcl_compiler_t
{
/* flags passed in via hcl_compile() */
int flags;
/* callback pointer registerd upon compiler creation */
hcl_cb_t* cbp;
@ -758,13 +761,13 @@ struct hcl_compiler_t
/* hcl_context_t, hcl_block_t, hcl_function_t stores the local variable information
/* hcl_context_t, hcl_lambda_t, hcl_function_t stores the local variable information
*
* Use up to 29 bits in a 32-bit hcl_ooi_t. Exclude the tag bit and the sign bit.
* | SIGN | INSTA | VA | NARGS | NRVARS | NLVARS | TAG |
* 1 1 8 8 11 2 <= 32
* -----------------------------------------------------------
* Parameters to the MAKE_BLOCK or MAKE_FUNCTION instructions
* Parameters to the MAKE_LAMBDA or MAKE_FUNCTION instructions
* | INSTA | VA | NARGS | NRVARS | NLVARS
* 1 1 4 4 6 <= 16 (HCL_CODE_LONG_PARAM_SIZE 1, two params)
* 1 1 8 8 11 <= 32 (HCL_CODE_LONG_PARAM_SIZE 2, two params, use 29 bits to avoid collection when converted to a smooi)
@ -1158,7 +1161,7 @@ enum hcl_bcode_t
HCL_CODE_RETURN_FROM_BLOCK = 0xFC, /* 252, return the stack top from a block */
HCL_CODE_MAKE_FUNCTION = 0xFD, /* 253 */
HCL_CODE_MAKE_BLOCK = 0xFE, /* 254 */
HCL_CODE_MAKE_LAMBDA = 0xFE, /* 254 */
HCL_CODE_NOOP = 0xFF /* 255 */
};

26
lib/hcl.h
View File

@ -164,8 +164,11 @@ enum hcl_synerrnum_t
HCL_SYNERR_CALLABLE, /* invalid callable */
HCL_SYNERR_UNBALKV, /* unbalanced key/value pair */
HCL_SYNERR_UNBALPBB, /* unbalanced parenthesis/brace/bracket */
HCL_SYNERR_SEMICOLON, /* unexpected semicolon */
HCL_SYNERR_EMPTYXLIST, /* empty x-list */
HCL_SYNERR_EMPTYMLIST /* empty m-list */
HCL_SYNERR_EMPTYMLIST, /* empty m-list */
HCL_SYNERR_BLOCK, /* block expression expected */
HCL_SYNERR_BLOCKBANNED /* block expression disallowed */
};
typedef enum hcl_synerrnum_t hcl_synerrnum_t;
@ -575,8 +578,8 @@ typedef struct hcl_function_t hcl_function_t;
typedef struct hcl_function_t* hcl_oop_function_t;
#define HCL_BLOCK_NAMED_INSTVARS 3
typedef struct hcl_block_t hcl_block_t;
typedef struct hcl_block_t* hcl_oop_block_t;
typedef struct hcl_lambda_t hcl_lambda_t;
typedef struct hcl_lambda_t* hcl_oop_lambda_t;
#define HCL_CONTEXT_NAMED_INSTVARS 9
typedef struct hcl_context_t hcl_context_t;
@ -600,10 +603,10 @@ struct hcl_function_t
};
/* hcl_function_t copies the byte codes and literal frames into itself
* hlc_block_t contains minimal information(ip) for referening byte codes
* hlc_lambda_t contains minimal information(ip) for referening byte codes
* and literal frames available in home->origin.
*/
struct hcl_block_t
struct hcl_lambda_t
{
HCL_OBJ_HEADER;
@ -692,10 +695,10 @@ struct hcl_process_t
hcl_oop_t id; /* SmallInteger */
hcl_oop_t state; /* SmallInteger */
hcl_oop_t sp; /* stack pointer. SmallInteger */
hcl_oop_t sp; /* stack pointer. SmallInteger */
hcl_oop_t st; /* stack top */
hcl_oop_t exsp; /* exception stack pointer. SmallInteger */
hcl_oop_t exsp; /* exception stack pointer. SmallInteger */
hcl_oop_t exst; /* exception stack top */
hcl_oop_t clsp; /* class stack pointer */
@ -1491,7 +1494,10 @@ enum hcl_compile_flag_t
HCL_COMPILE_CLEAR_CODE = (1 << 0),
/* clear the top-level function block at the end of hcl_compile() */
HCL_COMPILE_CLEAR_FNBLK = (1 << 1)
HCL_COMPILE_CLEAR_FNBLK = (1 << 1),
/* enable the block {} mode */
HCL_COMPILE_ENABLE_BLOCK = (1 << 2)
};
typedef enum hcl_compile_flag_t hcl_compile_flag_t;
#endif
@ -1868,7 +1874,7 @@ enum hcl_brand_t
HCL_BRAND_PRIM,
HCL_BRAND_FUNCTION,
HCL_BRAND_BLOCK,
HCL_BRAND_LAMBDA,
HCL_BRAND_CONTEXT,
HCL_BRAND_PROCESS,
HCL_BRAND_PROCESS_SCHEDULER,
@ -1934,7 +1940,7 @@ typedef enum hcl_concode_t hcl_concode_t;
#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_FUNCTION(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FUNCTION)
#define HCL_IS_BLOCK(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_BLOCK)
#define HCL_IS_LAMBDA(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_LAMBDA)
#define HCL_IS_CLASS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CLASS)
#define HCL_IS_INSTANCE(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_INSTANCE)
#define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS)

8
lib/print.c
View File

@ -88,7 +88,7 @@ enum
WORD_PRIM,
WORD_FUNCTION,
WORD_BLOCK,
WORD_LAMBDA,
WORD_CONTEXT,
WORD_PROCESS,
WORD_PROCESS_SCHEDULER,
@ -113,7 +113,7 @@ static struct
{ 7, { '#','<','P','R','I','M','>' } },
{ 11, { '#','<','F','U','N','C','T','I','O','N','>' } },
{ 11, { '#','<','B','L','O','C','K','>' } },
{ 9, { '#','<','L','A','M','B','D','A','>' } },
{ 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','>' } },
@ -677,8 +677,8 @@ next:
word_index = WORD_FUNCTION;
goto print_word;
case HCL_BRAND_BLOCK:
word_index = WORD_BLOCK;
case HCL_BRAND_LAMBDA:
word_index = WORD_LAMBDA;
goto print_word;
case HCL_BRAND_CONTEXT:

15
lib/read.c
View File

@ -673,10 +673,7 @@ static HCL_INLINE hcl_cnode_t* leave_list (hcl_t* hcl, int* flagv, int* oldflagv
static HCL_INLINE int is_at_block_beginning (hcl_t* hcl)
{
hcl_rstl_t* rstl;
//HCL_ASSERT (hcl, hcl->c->r.st != HCL_NULL);
rstl = hcl->c->r.st;
return !rstl || LIST_FLAG_GET_CONCODE(rstl->flagv) == HCL_CONCODE_BLOCK && rstl->count <= 0;
}
@ -876,12 +873,10 @@ static int on_fed_cnode (hcl_t* hcl, hcl_cnode_t* obj)
static void init_feed (hcl_t* hcl)
{
HCL_MEMSET (&hcl->c->feed, 0, HCL_SIZEOF(hcl->c->feed));
hcl->c->feed.lx.state = HCL_FLX_START;
hcl->c->feed.lx.loc.line = 1;
hcl->c->feed.lx.loc.colm = 1;
hcl->c->feed.lx.loc.file = HCL_NULL;
hcl->c->feed.on_cnode = on_fed_cnode;
}
@ -1101,6 +1096,7 @@ static int feed_process_token (hcl_t* hcl)
case HCL_TOK_LBRACE: /* { */
frd->flagv = 0;
LIST_FLAG_SET_CONCODE (frd->flagv, HCL_CONCODE_BLOCK);
hcl_logbfmt (hcl, HCL_LOG_FATAL, "XXXX [%d,%d]\n", TOKEN_LOC(hcl)->line, TOKEN_LOC(hcl)->colm);
goto start_list;
case HCL_TOK_DLPAREN: /* #{ */
@ -1176,14 +1172,15 @@ static int feed_process_token (hcl_t* hcl)
if (frd->level <= 0)
{
/* redundant semicolons */
hcl_setsynerr (hcl, HCL_SYNERR_UNBALPBB, TOKEN_LOC(hcl), HCL_NULL);
/* TOD: change error info or code */
hcl_setsynerr (hcl, HCL_SYNERR_SEMICOLON, TOKEN_LOC(hcl), HCL_NULL);
goto oops;
}
if (!(frd->flagv & AUTO_FORGED))
{
/* TODO: change error info */
hcl_setsynerr (hcl, HCL_SYNERR_UNBALPBB, TOKEN_LOC(hcl), HCL_NULL);
/* TODO: change error info or code */
hcl_setsynerr (hcl, HCL_SYNERR_SEMICOLON, TOKEN_LOC(hcl), HCL_NULL);
goto oops;
}
@ -1194,6 +1191,7 @@ static int feed_process_token (hcl_t* hcl)
hcl_setsynerr (hcl, HCL_SYNERR_UNBALPBB, TOKEN_LOC(hcl), HCL_NULL);
goto oops;
}
hcl_logbfmt(hcl, HCL_LOG_FATAL, "forged xlist...exiting..OK\n");
frd->obj = leave_list(hcl, &frd->flagv, &oldflagv);
frd->level--;
@ -1388,6 +1386,7 @@ static int feed_process_token (hcl_t* hcl)
{
hcl_oop_t obj = frd->obj;
hcl_logbfmt(hcl, HCL_LOG_FATAL, "QQQQQQQQQQQQ forged xlist...\n");
frd->flagv = AUTO_FORGED;
LIST_FLAG_SET_CONCODE (frd->flagv, HCL_CONCODE_XLIST);