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

wrote more code to support classes

Browse Source
This commit is contained in:
hyung-hwan
2021-06-25 15:19:11 +00:00
parent 8a7ca4dcb1
commit 2033072791
6 changed files with 403 additions and 112 deletions
Download Patch File Download Diff File Expand all files Collapse all files

321
hcl/lib/comp.c
View File

@ -389,7 +389,6 @@ static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
case HCL_CODE_PUSH_NEGINTLIT:
case HCL_CODE_PUSH_CHARLIT:
case HCL_CODE_MAKE_DIC: /* TODO: don't these need write_long2? */
case HCL_CODE_MAKE_ARRAY:
case HCL_CODE_MAKE_BYTEARRAY:
@ -1057,11 +1056,20 @@ enum
COP_COMPILE_DIC_LIST,
COP_COMPILE_QLIST, /* compile data list */
COP_COMPILE_AND_EXPR,
COP_COMPILE_OR_EXPR,
COP_COMPILE_ELIF,
COP_COMPILE_ELSE,
COP_COMPILE_CATCH,
COP_COMPILE_AND_P1,
COP_COMPILE_AND_P2,
COP_COMPILE_BREAK_P1,
COP_COMPILE_OR_P1,
COP_COMPILE_OR_P2,
COP_COMPILE_CLASS_P1,
COP_COMPILE_CLASS_P2,
COP_EMIT_CALL,
@ -1094,11 +1102,7 @@ enum
COP_POST_CATCH,
COP_POST_LAMBDA,
COP_POST_CLASS,
COP_POST_AND_EXPR,
COP_POST_OR_EXPR,
COP_POST_BREAK
};
/* ========================================================================= */
@ -1129,20 +1133,20 @@ static int compile_and (hcl_t* hcl, hcl_cnode_t* src)
obj = HCL_CNODE_CONS_CDR(obj);
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */
if (obj) PUSH_SUBCFRAME (hcl, COP_COMPILE_AND_EXPR, obj); /* 2 */
if (obj) PUSH_SUBCFRAME (hcl, COP_COMPILE_AND_P1, obj); /* 2 */
return 0;
}
static HCL_INLINE int compile_and_expr (hcl_t* hcl)
static HCL_INLINE int compile_and_p1 (hcl_t* hcl)
{
hcl_cnode_t* obj, * expr;
hcl_cframe_t* cf;
hcl_ooi_t jump_inst_pos;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_AND_EXPR);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_AND_P1);
HCL_ASSERT (hcl, cf->operand != HCL_NULL);
/* TODO: optimization - eat away all true expressions */
@ -1156,37 +1160,38 @@ static HCL_INLINE int compile_and_expr (hcl_t* hcl)
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX);
jump_inst_pos = hcl->code.bc.len;
/* this conditional jump make evaluation short-circuited. the actual jump point is to be patched in compile_and_p2() */
if (emit_single_param_instruction(hcl, HCL_CODE_JUMP_FORWARD_IF_FALSE, MAX_CODE_JUMP, HCL_CNODE_GET_LOC(obj)) <= -1) return -1;
if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_CNODE_GET_LOC(obj)) <= -1) return -1;
expr = HCL_CNODE_CONS_CAR(obj);
obj = HCL_CNODE_CONS_CDR(obj);
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 - compile the current part */
PUSH_SUBCFRAME (hcl, COP_POST_AND_EXPR, expr); /* 3 */
PUSH_SUBCFRAME (hcl, COP_COMPILE_AND_P2, expr); /* 3 - patch the conditional jump instruction */
cf = GET_SUBCFRAME(hcl);
cf->u.post_and.jump_inst_pos = jump_inst_pos;
if (obj) PUSH_SUBCFRAME (hcl, COP_COMPILE_AND_EXPR, obj); /* 2 */
if (obj) PUSH_SUBCFRAME (hcl, COP_COMPILE_AND_P1, obj); /* 2 - recurse to compile remaining parts */
return 0;
}
static HCL_INLINE int post_and_expr (hcl_t* hcl)
static HCL_INLINE int compile_and_p2 (hcl_t* hcl)
{
hcl_cframe_t* cf;
hcl_ooi_t jip;
hcl_oow_t jump_offset;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_POST_AND_EXPR);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_AND_P2);
HCL_ASSERT (hcl, cf->operand != HCL_NULL);
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX);
jip = cf->u.post_and.jump_inst_pos;
/* patch the jump insruction emitted after each expression inside the 'and' expression */
/* patch the jump insruction emitted after each expression inside the 'and' expression
* the jump make evaluation short-circuited. */
jump_offset = hcl->code.bc.len - jip - (HCL_CODE_LONG_PARAM_SIZE + 1);
patch_long_jump (hcl, jip, jump_offset);
@ -1222,20 +1227,20 @@ static int compile_or (hcl_t* hcl, hcl_cnode_t* src)
obj = HCL_CNODE_CONS_CDR(obj);
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */
PUSH_SUBCFRAME (hcl, COP_COMPILE_OR_EXPR, obj); /* 2 */
PUSH_SUBCFRAME (hcl, COP_COMPILE_OR_P1, obj); /* 2 */
return 0;
}
static HCL_INLINE int compile_or_expr (hcl_t* hcl)
static HCL_INLINE int compile_or_p1 (hcl_t* hcl)
{
hcl_cnode_t* obj, * expr;
hcl_cframe_t* cf;
hcl_ooi_t jump_inst_pos;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_OR_EXPR);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_OR_P1);
HCL_ASSERT (hcl, cf->operand != HCL_NULL);
/* TODO: optimization - eat away all false expressions */
@ -1250,6 +1255,7 @@ static HCL_INLINE int compile_or_expr (hcl_t* hcl)
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX);
jump_inst_pos = hcl->code.bc.len;
/* this conditional jump makes evaluation short-circuited. the actual jump point is to be patched in compile_or_p2() */
if (emit_single_param_instruction(hcl, HCL_CODE_JUMP_FORWARD_IF_TRUE, MAX_CODE_JUMP, HCL_CNODE_GET_LOC(obj)) <= -1) return -1;
if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_CNODE_GET_LOC(obj)) <= -1) return -1;
@ -1258,23 +1264,23 @@ static HCL_INLINE int compile_or_expr (hcl_t* hcl)
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */
PUSH_SUBCFRAME (hcl, COP_POST_OR_EXPR, expr); /* 3 */
PUSH_SUBCFRAME (hcl, COP_COMPILE_OR_P2, expr); /* 3 */
cf = GET_SUBCFRAME(hcl);
cf->u.post_or.jump_inst_pos = jump_inst_pos;
if (obj) PUSH_SUBCFRAME (hcl, COP_COMPILE_OR_EXPR, obj); /* 2 */
if (obj) PUSH_SUBCFRAME (hcl, COP_COMPILE_OR_P1, obj); /* 2 */
return 0;
}
static HCL_INLINE int post_or_expr (hcl_t* hcl)
static HCL_INLINE int compile_or_p2 (hcl_t* hcl)
{
hcl_cframe_t* cf;
hcl_ooi_t jip;
hcl_oow_t jump_offset;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_POST_OR_EXPR);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_OR_P2);
HCL_ASSERT (hcl, cf->operand != HCL_NULL);
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX);
@ -1359,7 +1365,7 @@ inside_loop:
jump_inst_pos = hcl->code.bc.len;
if (emit_single_param_instruction(hcl, HCL_CODE_JUMP_FORWARD_0, MAX_CODE_JUMP, HCL_CNODE_GET_LOC(cmd)) <= -1) return -1;
INSERT_CFRAME (hcl, i, COP_POST_BREAK, cmd);
INSERT_CFRAME (hcl, i, COP_COMPILE_BREAK_P1, cmd);
cf = GET_CFRAME(hcl, i);
cf->u._break.jump_inst_pos = jump_inst_pos;
@ -1374,13 +1380,13 @@ inside_loop:
return -1;
}
static int post_break (hcl_t* hcl)
static int compile_break_p1 (hcl_t* hcl)
{
hcl_cframe_t* cf;
hcl_ooi_t jip, jump_offset;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_POST_BREAK);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_BREAK_P1);
HCL_ASSERT (hcl, cf->operand != HCL_NULL);
jip = cf->u._break.jump_inst_pos;;
@ -1702,6 +1708,7 @@ static int check_if_plain_cnode (hcl_t* hcl, hcl_cnode_t* obj, hcl_cnode_t* prev
return 0;
}
#if 0
static int compile_class (hcl_t* hcl, hcl_cnode_t* src)
{
/*
@ -1733,6 +1740,7 @@ static int compile_class (hcl_t* hcl, hcl_cnode_t* src)
*/
hcl_cnode_t* cmd, * obj, * tmp;
hcl_cnode_t* class_name, * superclass_name;
hcl_ooi_t nsuperclasses, nivars, ncvars;
cmd = HCL_CNODE_CONS_CAR(src);
obj = HCL_CNODE_CONS_CDR(src);
@ -1758,11 +1766,30 @@ static int compile_class (hcl_t* hcl, hcl_cnode_t* src)
if (obj)
{
/* superclass */
tmp = HCL_CNODE_CONS_CAR(obj);
if (HCL_CNODE_IS_TRPCOLONS(tmp))
{
obj = HCL_CNODE_CONS_CDR(obj);
/* TODO: this can actually be dynamic. so it doesn't have to be a symbol name,
* even an expression is possible ...
* (defclass A
* ...
* )
* (defun get-your-class() A)
* (defclass B ::: (get-your-class)
* ....
* )
*
* this code is wrong...
*/
#if 0
/* TODO: multiple subclasses? interfaces? */
if (check_if_plain_cnode(hcl, obj, tmp, cmd, HCL_SYNERR_VARNAME, "superclass name") <= -1) return -1;
superclass_name = HCL_CNODE_CONS_CAR(obj);
@ -1780,10 +1807,31 @@ static int compile_class (hcl_t* hcl, hcl_cnode_t* src)
hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_CNODE_GET_LOC(superclass_name), HCL_CNODE_GET_TOK(superclass_name), "non-symbol not to be used as a superclass name");
return -1;
}
#else
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */
PUSH_SUBCFRAME (hcl, COP_COMPILE_AND_P2, expr); /* 3 */
cf = GET_SUBCFRAME(hcl);
cf->u.post_and.jump_inst_pos = jump_inst_pos;
if (obj) PUSH_SUBCFRAME (hcl, COP_COMPILE_AND_P1, obj); /* 2 */
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, obj); /* 1 */
#endif
}
else
{
SWITCH_TO_CFRAME (hcl, COP_EMIT_PUSH_NIL, obj); /* 1*/
}
}
PUSH_SUBCFRAME (hcl, COP_CLASS_SUPERCLASS
#if 0
//HCL_DEBUG2 (hcl, ">>> [%js] [%js]\n", HCL_CNODE_GET_TOKPTR(class_name), HCL_CNODE_GET_TOKPTR(superclass_name));
nivars = ncvars = 0;
while (obj)
{
/* instance variables and/or class variables */
@ -1793,15 +1841,44 @@ printf ("VLIST....\n");
vars = HCL_CNODE_CONS_CAR(obj);
if (!HCL_CNODE_IS_CONS_CONCODED(vars, HCL_CONCODE_VLIST)) break;
// TODO increment nivars and ncvars
// also remember actual variable names...
printf ("22222222222\n");
obj = HCL_CNODE_CONS_CDR(obj);
}
#else
PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_VARS, obj);
#endif
// superclass name?
// nivars and ncvars.. must include inherited ones...
if (push_clsblk(hcl, HCL_CNODE_GET_LOC(cmd), nivars, ncvars) <= -1) return -1;
if (push_clsblk(hcl, HCL_CNODE_GET_LOC(cmd), 0, 0) <= -1) return -1;
/* TODO: emit make_class code...
*/
/* TODO: push the instance variables string and class variables string */
// superclass name is an variable...
//if (emit_push_literal(hcl, tmp, HCL_CNODE_GET_LOC(cmd))
if (nivars > 0)
{
tmp = hcl_makestring(hcl, varg, len, 0);
if (HCL_UNLIKELY(!tmp)) return -1;
if (emit_push_literal(hcl, tmp, HCL_CNODE_GET_LOC(cmd)) <= -1) return-1;
}
if (ncvars > 0)
{
}
/* make_class nsuperclasses, nivars, ncvars - this will use the pushed literal */
if (emit_byte_instruction(hcl, HCL_CODE_MAKE_CLASS, HCL_CNODE_GET_LOC(cmd)) <= -1) return -1;
if (emit_long_param(hcl, nivars) <= -1) return -1;
if (emit_long_param(hcl, ncvars) <= -1) return -1;
if (emit_byte_instruction(hcl, HCL_CODE_CLASS_ENTER, HCL_CNODE_GET_LOC(cmd)) <= -1) return -1;
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, obj); /* 1 */
@ -1809,14 +1886,146 @@ printf ("22222222222\n");
return 0;
}
#endif
static int compile_class (hcl_t* hcl, hcl_cnode_t* src)
{
hcl_cnode_t* cmd, * obj;
hcl_cnode_t* class_name;
hcl_cframe_t* cf;
cmd = HCL_CNODE_CONS_CAR(src);
obj = HCL_CNODE_CONS_CDR(src);
HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_DEFCLASS));
class_name = HCL_NULL;
if (check_if_plain_cnode(hcl, obj, src, cmd, HCL_SYNERR_VARNAME, "class name") <= -1) return -1;
class_name = HCL_CNODE_CONS_CAR(obj);
if (HCL_CNODE_IS_SYMBOL(class_name))
{
/* TODO: make the classname optional? */
/* defclass followed by a class name */
if (HCL_CNODE_SYMBOL_SYNCODE(class_name)) /*|| HCL_OBJ_GET_FLAGS_KERNEL(class_name) >= 1) */
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_CNODE_GET_LOC(class_name), HCL_CNODE_GET_TOK(class_name), "special symbol not to be used as a class name");
return -1;
}
obj = HCL_CNODE_CONS_CDR(obj);
}
if (obj)
{
hcl_cnode_t* tmp;
tmp = HCL_CNODE_CONS_CAR(obj);
if (!HCL_CNODE_IS_TRPCOLONS(tmp)) goto no_superclass;
{
obj = HCL_CNODE_CONS_CDR(obj);
/* superclass part */
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, obj); /* 1 */
PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_P2, class_name); /* 3 */
cf = GET_SUBCFRAME(hcl);
cf->u._class.nsuperclasses = 0; /* unsed for CLASS_P2 */
cf->u._class.start_loc = *HCL_CNODE_GET_LOC(src); /* TODO: use *HCL_CNODE_GET_LOC(cmd) instead? */
obj = HCL_CNODE_CONS_CDR(obj);
PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_P1, obj); /* 2 */
cf = GET_SUBCFRAME(hcl);
cf->u._class.nsuperclasses = 1; /* this one needs to change if we support multiple superclasses... */
}
}
else
{
no_superclass:
SWITCH_TOP_CFRAME(hcl, COP_COMPILE_CLASS_P1, obj); /* 1 */
cf = GET_TOP_CFRAME(hcl);
cf->u._class.nsuperclasses = 0; /* this one needs to change if we support multiple superclasses... */
cf->u._class.start_loc = *HCL_CNODE_GET_LOC(src); /* TODO: use *HCL_CNODE_GET_LOC(cmd) instead? */
PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_P2, class_name); /* 2 */
cf = GET_SUBCFRAME(hcl);
cf->u._class.nsuperclasses = 0; /* unsed for CLASS_P2 */
cf->u._class.start_loc = *HCL_CNODE_GET_LOC(src); /* TODO: use *HCL_CNODE_GET_LOC(cmd) instead? */
}
return 0;
}
static HCL_INLINE int compile_class_p1 (hcl_t* hcl)
{
/* collect information about declared variables */
hcl_cframe_t* cf;
hcl_ooi_t nivars, ncvars;
hcl_cnode_t* obj;
hcl_oop_t tmp;
cf = GET_TOP_CFRAME(hcl);
obj = cf->operand;
nivars = ncvars = 0;
while (obj)
{
/* instance variables and/or class variables */
hcl_cnode_t* vars;
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(obj)); /* must not get CDR. the reader must ensure this */
printf ("VLIST....\n");
vars = HCL_CNODE_CONS_CAR(obj);
if (!HCL_CNODE_IS_CONS_CONCODED(vars, HCL_CONCODE_VLIST)) break;
// TODO increment nivars and ncvars
// also remember actual variable names...
printf ("22222222222\n");
obj = HCL_CNODE_CONS_CDR(obj);
}
/* TODO: push the instance variables string and class variables string */
// superclass name is an variable...
//if (emit_push_literal(hcl, tmp, HCL_CNODE_GET_LOC(cmd))
if (nivars > 0)
{
//tmp = hcl_makestring(hcl, varg, len, 0);
tmp = hcl_makestring(hcl, HCL_NULL, 0, 0);
if (HCL_UNLIKELY(!tmp)) return -1;
if (emit_push_literal(hcl, tmp, &cf->u._class.start_loc) <= -1) return-1;
}
if (ncvars > 0)
{
tmp = hcl_makestring(hcl, HCL_NULL, 0, 0);
if (HCL_UNLIKELY(!tmp)) return -1;
if (emit_push_literal(hcl, tmp, &cf->u._class.start_loc) <= -1) return-1;
}
if (push_clsblk(hcl, &cf->u._class.start_loc, nivars, ncvars) <= -1) return -1;
/* make_class nsuperclasses, nivars, ncvars - this will use the pushed literal */
if (emit_byte_instruction(hcl, HCL_CODE_MAKE_CLASS, &cf->u._class.start_loc) <= -1) return -1;
if (emit_long_param(hcl, cf->u._class.nsuperclasses) <= -1) return -1;
if (emit_long_param(hcl, nivars) <= -1) return -1;
if (emit_long_param(hcl, ncvars) <= -1) return -1;
if (emit_byte_instruction(hcl, HCL_CODE_CLASS_ENTER, &cf->u._class.start_loc) <= -1) return -1; // TODO: do i need this separater instruction?
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, obj); /* 1 */
return 0;
}
static HCL_INLINE int post_class (hcl_t* hcl)
static HCL_INLINE int compile_class_p2 (hcl_t* hcl)
{
hcl_cframe_t* cf;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_POST_CLASS);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_CLASS_P2);
pop_clsblk (hcl);
@ -1858,6 +2067,7 @@ static HCL_INLINE int post_class (hcl_t* hcl)
}
#else
/* should i make the assignment in POST? or after variable declarations immediately? */
/* TODO: emit instruction to store into the class name...? */
if (emit_byte_instruction(hcl, HCL_CODE_CLASS_EXIT, HCL_CNODE_GET_LOC(cf->operand)) <= -1) return -1;
printf ("end of CLASS DEFINITION\n");
POP_CFRAME (hcl);
@ -4409,14 +4619,37 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
if (compile_catch(hcl) <= -1) goto oops;
break;
case COP_COMPILE_AND_EXPR:
if (compile_and_expr(hcl) <= -1) goto oops;
case COP_COMPILE_AND_P1:
if (compile_and_p1(hcl) <= -1) goto oops;
break;
case COP_COMPILE_OR_EXPR:
if (compile_or_expr(hcl) <= -1) goto oops;
case COP_COMPILE_AND_P2:
if (compile_and_p2(hcl) <= -1) goto oops;
break;
case COP_COMPILE_BREAK_P1:
if (compile_break_p1(hcl) <= -1) goto oops;
break;
case COP_COMPILE_CLASS_P1:
if (compile_class_p1(hcl) <= -1) goto oops;
break;
case COP_COMPILE_CLASS_P2:
if (compile_class_p2(hcl) <= -1) goto oops;
break;
case COP_COMPILE_OR_P1:
if (compile_or_p1(hcl) <= -1) goto oops;
break;
case COP_COMPILE_OR_P2:
if (compile_or_p2(hcl) <= -1) goto oops;
break;
case COP_EMIT_CALL:
if (emit_call(hcl) <= -1) goto oops;
break;
@ -4510,22 +4743,6 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
if (post_lambda(hcl) <= -1) goto oops;
break;
case COP_POST_CLASS:
if (post_class(hcl) <= -1) goto oops;
break;
case COP_POST_AND_EXPR:
if (post_and_expr(hcl) <= -1) goto oops;
break;
case COP_POST_OR_EXPR:
if (post_or_expr(hcl) <= -1) goto oops;
break;
case COP_POST_BREAK:
if (post_break(hcl) <= -1) goto oops;
break;
default:
HCL_DEBUG1 (hcl, "Internal error - invalid compiler opcode %d\n", cf->opcode);
hcl_seterrbfmt (hcl, HCL_EINTERN, "invalid compiler opcode %d", cf->opcode);

10
hcl/lib/decode.c
View File

@ -603,8 +603,16 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
/* -------------------------------------------------------- */
case HCL_CODE_MAKE_CLASS:
LOG_INST_0 (hcl, "make_class");
{
hcl_oow_t b3;
FETCH_PARAM_CODE_TO (hcl, b1);
FETCH_PARAM_CODE_TO (hcl, b2);
FETCH_PARAM_CODE_TO (hcl, b3);
LOG_INST_3 (hcl, "make_class %zu %zu %zu", b1, b2, b3);
break;
}
/* -------------------------------------------------------- */
case HCL_CODE_DUP_STACKTOP:

129
hcl/lib/exec.c
View File

@ -144,14 +144,13 @@ static void terminate_all_processes (hcl_t* hcl);
do { \
hcl_oop_process_t ap = (hcl)->processor->active; \
hcl_ooi_t exsp = HCL_OOP_TO_SMOOI(ap->exsp); \
hcl_ooi_t ss = HCL_OOP_TO_SMOOI(ap->ss); \
if (exsp >= HCL_OOP_TO_SMOOI(ap->exss) - 2) \
if (exsp >= HCL_OOP_TO_SMOOI(ap->exst) - 1) \
{ \
hcl_seterrbfmt (hcl, HCL_EOOMEM, "process exception stack overflow"); \
(hcl)->abort_req = -1; \
} \
exsp++; ap->slot[ss + exsp] = (ctx); \
exsp++; ap->slot[ss + exsp] = HCL_SMOOI_TO_OOP(ip); \
exsp++; ap->slot[exsp] = (ctx); \
exsp++; ap->slot[exsp] = HCL_SMOOI_TO_OOP(ip); \
ap->exsp = HCL_SMOOI_TO_OOP(exsp); \
} while (0)
@ -167,13 +166,46 @@ static void terminate_all_processes (hcl_t* hcl);
do { \
hcl_oop_process_t ap = (hcl)->processor->active; \
hcl_ooi_t exsp = HCL_OOP_TO_SMOOI(ap->exsp); \
hcl_ooi_t ss = HCL_OOP_TO_SMOOI(ap->ss); \
ip = HCL_OOP_TO_SMOOI(ap->slot[ss + exsp]); exsp--; \
ctx = ap->slot[ss + exsp]; exsp--; \
ip = HCL_OOP_TO_SMOOI(ap->slot[exsp]); exsp--; \
ctx = ap->slot[exsp]; exsp--; \
ap->exsp = HCL_SMOOI_TO_OOP(exsp); \
} while (0)
#define HCL_EXSTACK_ISEMPTY(hcl) (HCL_OOP_TO_SMOOI(((hcl)->processor->active)->exsp) <= -1)
#define HCL_EXSTACK_ISEMPTY(hcl) (HCL_OOP_TO_SMOOI(((hcl)->processor->active)->exsp) <= HCL_OOP_TO_SMOOI(((hcl)->processor->active)->st))
/* ------------------------------------------------------------------------- */
#define HCL_CLSTACK_PUSH(hcl, v) \
do { \
hcl_oop_process_t ap = (hcl)->processor->active; \
hcl_ooi_t clsp = HCL_OOP_TO_SMOOI(ap->clsp); \
if (clsp >= HCL_OOP_TO_SMOOI(ap->clst)) \
{ \
hcl_seterrbfmt (hcl, HCL_EOOMEM, "process class stack overflow"); \
(hcl)->abort_req = -1; \
} \
clsp++; ap->slot[clsp] = (v); \
ap->clsp = HCL_SMOOI_TO_OOP(clsp); \
} while (0)
#define HCL_CLSTACK_POP(hcl) \
do { \
hcl_oop_process_t ap = (hcl)->processor->active; \
hcl_ooi_t clsp = HCL_OOP_TO_SMOOI(ap->clsp); \
clsp--; \
ap->clsp = HCL_SMOOI_TO_OOP(clsp); \
} while (0)
#define HCL_CLSTACK_POP_TO(hcl, v) \
do { \
hcl_oop_process_t ap = (hcl)->processor->active; \
hcl_ooi_t clsp = HCL_OOP_TO_SMOOI(ap->clsp); \
v = ap->slot[clsp]; clsp--; \
ap->clsp = HCL_SMOOI_TO_OOP(clsp); \
} while (0)
#define HCL_CLSTACK_ISEMPTY(hcl) (HCL_OOP_TO_SMOOI(((hcl)->processor->active)->clsp) <= HCL_OOP_TO_SMOOI(((hcl)->processor->active)->exst))
/* ------------------------------------------------------------------------- */
@ -462,7 +494,7 @@ static HCL_INLINE void free_pid (hcl_t* hcl, hcl_oop_process_t proc)
static hcl_oop_process_t make_process (hcl_t* hcl, hcl_oop_context_t c)
{
hcl_oop_process_t proc;
hcl_oow_t stksize, exstksize;
hcl_oow_t stksize, exstksize, clstksize, maxsize;
hcl_ooi_t total_count;
hcl_ooi_t suspended_count;
@ -478,24 +510,23 @@ static hcl_oop_process_t make_process (hcl_t* hcl, hcl_oop_context_t c)
if (hcl->proc_map_free_first <= -1 && prepare_to_alloc_pid(hcl) <= -1) return HCL_NULL;
stksize = hcl->option.dfl_procstk_size;
stksize = hcl->option.dfl_procstk_size; /* stack */
exstksize = 128; /* exception stack size */ /* TODO: make it configurable */
clstksize = 64; /* class stack size */ /* TODO: make it configurable too */
maxsize = (HCL_TYPE_MAX(hcl_ooi_t) - HCL_PROCESS_NAMED_INSTVARS) / 3;
#if 0
if (stksize > HCL_TYPE_MAX(hcl_ooi_t) - HCL_PROCESS_NAMED_INSTVARS)
stksize = HCL_TYPE_MAX(hcl_ooi_t) - HCL_PROCESS_NAMED_INSTVARS;
else if (stksize < 128) stksize = 128;
#else
if (stksize > (HCL_TYPE_MAX(hcl_ooi_t) - HCL_PROCESS_NAMED_INSTVARS) / 2)
stksize = (HCL_TYPE_MAX(hcl_ooi_t) - HCL_PROCESS_NAMED_INSTVARS) / 2;
else if (stksize < 128) stksize = 128;
if (exstksize > (HCL_TYPE_MAX(hcl_ooi_t) - HCL_PROCESS_NAMED_INSTVARS) / 2)
exstksize = (HCL_TYPE_MAX(hcl_ooi_t) - HCL_PROCESS_NAMED_INSTVARS) / 2;
if (stksize > maxsize) stksize = maxsize;
else if (stksize < 192) stksize = 192;
if (exstksize > maxsize) exstksize = maxsize;
else if (exstksize < 128) exstksize = 128;
#endif
if (clstksize > maxsize) clstksize = maxsize;
else if (clstksize < 32) clstksize = 32;
hcl_pushvolat (hcl, (hcl_oop_t*)&c);
proc = (hcl_oop_process_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS + stksize + exstksize);
proc = (hcl_oop_process_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS + stksize + exstksize + clstksize);
hcl_popvolat (hcl);
if (HCL_UNLIKELY(!proc)) return HCL_NULL;
@ -512,10 +543,18 @@ static hcl_oop_process_t make_process (hcl_t* hcl, hcl_oop_context_t c)
proc->initial_context = c;
proc->current_context = c;
proc->sp = HCL_SMOOI_TO_OOP(-1);
proc->ss = HCL_SMOOI_TO_OOP(stksize);
proc->exsp = HCL_SMOOI_TO_OOP(-1);
proc->exss = HCL_SMOOI_TO_OOP(exstksize);
/* stack */
proc->sp = HCL_SMOOI_TO_OOP(-1); /* no item */
proc->st = HCL_SMOOI_TO_OOP(stksize);
/* exception stack */
proc->exsp = proc->st; /* no item pushed yet*/
proc->exst = HCL_SMOOI_TO_OOP(stksize + exstksize - 1);
/* class stack */
proc->clsp = proc->exst; /* no item pushed yet */
proc->clst = HCL_SMOOI_TO_OOP(stksize + exstksize + clstksize - 1);
HCL_ASSERT (hcl, (hcl_oop_t)c->sender == hcl->_nil);
@ -3264,7 +3303,6 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
LOG_INST_0 (hcl, "throw");
return_value = HCL_STACK_GETTOP(hcl);
HCL_STACK_POP (hcl);
if (do_throw(hcl, return_value, fetched_instruction_pointer) <= -1) goto oops;
break;
/* -------------------------------------------------------- */
@ -3274,15 +3312,15 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
/* the class_enter instruct must follow the class_make instruction... */
LOG_INST_0 (hcl, "class_enter");
c = HCL_STACK_GETTOP(hcl); /* the class object */
//HCL_CLSTACK_PUSH (hcl, c);
c = HCL_STACK_GETTOP(hcl); /* the class object created with make_class */
HCL_CLSTACK_PUSH (hcl, c);
break;
}
case HCL_CODE_CLASS_EXIT:
LOG_INST_0 (hcl, "class_exit");
/* TODO: stack underflow check? */
//HCL_CLSTACK_POP (hcl);
HCL_CLSTACK_POP (hcl);
break;
/* -------------------------------------------------------- */
@ -3753,23 +3791,26 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
case HCL_CODE_MAKE_CLASS:
{
/* push nivars
push ncvars
push superclass
//push ivarnames
//push cvarnames
/* push superclass
push ivars
push cvars
make_classs
*/
hcl_oop_t t, sc, nivars, ncvars;
hcl_oow_t b3;
FETCH_PARAM_CODE_TO (hcl, b1); /* nsuperclasses */
FETCH_PARAM_CODE_TO (hcl, b2); /* nivars */
FETCH_PARAM_CODE_TO (hcl, b3); /* ncvars */
LOG_INST_3 (hcl, "make_class %zu %zu %zu", b1, b2, b3);
LOG_INST_0 (hcl, "make_class");
sc = HCL_STACK_GETTOP(hcl); HCL_STACK_POP(hcl);
ncvars = HCL_STACK_GETTOP(hcl); HCL_STACK_POP(hcl);
nivars = HCL_STACK_GETTOP(hcl); HCL_STACK_POP(hcl);
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(ncvars));
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(nivars));
t = hcl_makeclass(hcl, sc, HCL_OOP_TO_SMOOI(nivars), HCL_OOP_TO_SMOOI(ncvars));
/* TODO: get extra information from the stack according to b1, b2, b3*/
/* critical error if the superclass is not a class ...
* critical error if ivars is not a string...
* critical errro if cvars is not a string ....
*/
t = hcl_makeclass(hcl, hcl->_nil, b2, b3); // TOOD: pass variable information...
if (HCL_UNLIKELY(!t))
{
@ -3980,7 +4021,7 @@ hcl_oop_t hcl_execute (hcl_t* hcl)
#endif
}
/* create a virtual function object that hold the bytes codes generated */
/* create a virtual function object that hold the bytes codes generated plus the literal frame */
func = make_function(hcl, hcl->code.lit.len, hcl->code.bc.ptr, hcl->code.bc.len, hcl->code.dbgi);
if (HCL_UNLIKELY(!func)) return HCL_NULL;

34
hcl/lib/gc.c
View File

@ -233,31 +233,45 @@ static HCL_INLINE void gc_ms_scan_stack (hcl_t* hcl)
{
oop = hcl->gci.stack.ptr[--hcl->gci.stack.len];
/*gc_ms_mark_object (hcl, (hcl_oop_t)HCL_OBJ_GET_CLASS(oop));*/
gc_ms_mark_object (hcl, (hcl_oop_t)HCL_OBJ_GET_CLASS(oop));
if (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_OOP)
{
hcl_oow_t size, i;
hcl_ooi_t i, ll;
/* is it really better to use a flag bit in the header to
* determine that it is an instance of process? */
/* if (HCL_UNLIKELY(HCL_OBJ_GET_FLAGS_PROC(oop))) */
if (HCL_OBJ_GET_FLAGS_BRAND(oop) == HCL_BRAND_PROCESS)
{
hcl_oop_process_t proc;
/* the stack in a process object doesn't need to be
* scanned in full. the slots above the stack pointer
* are garbages. */
size = HCL_PROCESS_NAMED_INSTVARS + HCL_OOP_TO_SMOOI(((hcl_oop_process_t)oop)->sp) + 1;
HCL_ASSERT (hcl, size <= HCL_OBJ_GET_SIZE(oop));
proc = (hcl_oop_process_t)oop;
/* the fixed part */
ll = HCL_PROCESS_NAMED_INSTVARS;
for (i = 0; i < ll; i++) gc_ms_mark_object (hcl, HCL_OBJ_GET_OOP_VAL(oop, i));
/* stack */
ll = HCL_OOP_TO_SMOOI(proc->sp);
HCL_ASSERT (hcl, ll < (hcl_ooi_t)(HCL_OBJ_GET_SIZE(oop) - HCL_PROCESS_NAMED_INSTVARS));
for (i = 0; i <= ll; i++) gc_ms_mark_object (hcl, proc->slot[i]);
/* exception stack */
ll = HCL_OOP_TO_SMOOI(proc->exsp);
HCL_ASSERT (hcl, ll < (hcl_ooi_t)(HCL_OBJ_GET_SIZE(oop) - HCL_PROCESS_NAMED_INSTVARS));
for (i = HCL_OOP_TO_SMOOI(proc->st) + 1; i <= ll; i++) gc_ms_mark_object (hcl, proc->slot[i]);
/* class stack */
ll = HCL_OOP_TO_SMOOI(proc->clsp);
HCL_ASSERT (hcl, ll < (hcl_ooi_t)(HCL_OBJ_GET_SIZE(oop) - HCL_PROCESS_NAMED_INSTVARS));
for (i = HCL_OOP_TO_SMOOI(proc->exst) + 1; i <= ll; i++) gc_ms_mark_object (hcl, proc->slot[i]);
}
else
{
size = HCL_OBJ_GET_SIZE(oop);
}
for (i = 0; i < size; i++)
{
gc_ms_mark_object (hcl, HCL_OBJ_GET_OOP_VAL(oop, i));
ll = HCL_OBJ_GET_SIZE(oop);
for (i = 0; i < ll; i++) gc_ms_mark_object (hcl, HCL_OBJ_GET_OOP_VAL(oop, i));
}
}
}

8
hcl/lib/hcl-prv.h
View File

@ -380,6 +380,13 @@ struct hcl_cframe_t
{
hcl_ooi_t jump_inst_pos;
} _break;
/* COP_COMPILE_CLASS_P1, COP_COMPILE_CLASS_P2 */
struct
{
hcl_ooi_t nsuperclasses;
hcl_ioloc_t start_loc;
} _class;
} u;
};
typedef struct hcl_cframe_t hcl_cframe_t;
@ -448,7 +455,6 @@ struct hcl_rstl_t
hcl_rstl_t* prev;
};
struct hcl_compiler_t
{
/* output handler */

13
hcl/lib/hcl.h
View File

@ -646,7 +646,7 @@ struct hcl_context_t
hcl_oop_t slot[1]; /* arguments, return variables, local variables, other arguments, etc */
};
#define HCL_PROCESS_NAMED_INSTVARS 13
#define HCL_PROCESS_NAMED_INSTVARS 15
typedef struct hcl_process_t hcl_process_t;
typedef struct hcl_process_t* hcl_oop_process_t;
@ -666,10 +666,15 @@ struct hcl_process_t
hcl_oop_t id; /* SmallInteger */
hcl_oop_t state; /* SmallInteger */
hcl_oop_t sp; /* stack pointer. SmallInteger */
hcl_oop_t ss; /* process stack size. SmallInteger */
hcl_oop_t st; /* stack top */
hcl_oop_t exsp; /* exception stack pointer. SmallInteger */
hcl_oop_t exss; /* exception stack size. SmallInteger */
hcl_oop_t exst; /* exception stack top */
hcl_oop_t clsp; /* class stack pointer */
hcl_oop_t clst; /* class stack top */
struct
{
@ -1690,7 +1695,7 @@ struct hcl_t
/* TODO: stack bound check when pushing */
#define HCL_STACK_PUSH(hcl,v) \
do { \
if ((hcl)->sp >= HCL_OOP_TO_SMOOI((hcl)->processor->active->ss) - 1) \
if ((hcl)->sp >= HCL_OOP_TO_SMOOI((hcl)->processor->active->st)) \
{ \
hcl_seterrbfmt (hcl, HCL_EOOMEM, "process stack overflow"); \
(hcl)->abort_req = -1; \