fixing bugs related to stack, class stack, exceptio stack handling
This commit is contained in:
parent
3f03140dcc
commit
f4661d018a
98
lang.txt
98
lang.txt
@ -33,64 +33,82 @@
|
||||
|
||||
## class declaration with methods.
|
||||
|
||||
(defclass X
|
||||
(defclass X
|
||||
|
||||
| x y | ; instance variables
|
||||
::: | bob jim | ; class variables
|
||||
| x y | ; instance variables
|
||||
::: | bob jim | ; class variables
|
||||
|
||||
; instance variables and class variables must not collide with those of parent classes.
|
||||
; they must not collide with method names of parent classes
|
||||
; instance variables and class variables must not collide with those of parent classes.
|
||||
; they must not collide with method names of parent classes
|
||||
|
||||
(set bob "Bob") ; can access class variables. disallowed to access instance variables
|
||||
|
||||
(set bob "Bob") ; can access class variables. disallowed to access instance variables
|
||||
(defun setX (a)
|
||||
(set x a)
|
||||
)
|
||||
|
||||
(defun setX (a)
|
||||
(set self.x a)
|
||||
;(super.setX a)
|
||||
; instance method. a method name must not collide with instance variable names and class variable names.
|
||||
; the name can be the same as method names of parent classes.
|
||||
(defun K (a b)
|
||||
(:self Y a)
|
||||
(return (+ a b x y))
|
||||
)
|
||||
|
||||
(defun Y (a)
|
||||
(printf "Y=>%d [%s]\n" a bob)
|
||||
)
|
||||
|
||||
(defun ::: KK (a b)
|
||||
(printf "K=>%s\n" bob) ; a class method can access class variables but not instance variables
|
||||
(return (+ a b))
|
||||
)
|
||||
|
||||
(set jim (lambda (a b) (+ a b))) ; an anonymous function created
|
||||
)
|
||||
|
||||
; instance method. a method name must not collide with instance variable names and class variable names.
|
||||
; the name can be the same as method names of parent classes.
|
||||
(defun K (a b)
|
||||
(self.Y a)
|
||||
(return (+ a b x y))
|
||||
)
|
||||
|
||||
(defun Y (a)
|
||||
(printf ("Y=>%d [%s]\n", a, bob)
|
||||
)
|
||||
|
||||
(defun ::: KK (a b)
|
||||
(printf "K=>%s\n", bob) ; a class method can access class variables but not instance variables
|
||||
(return (+ a b))
|
||||
)
|
||||
|
||||
(set jim (lambda (a b) (+ a b))) ; the anonymous function created is
|
||||
)
|
||||
(set r (object-new X))
|
||||
(:r Y 10)
|
||||
(printf ">>%d\n" (:X KK 77 99))
|
||||
|
||||
|
||||
## method invocation
|
||||
|
||||
a period isn't a good token to use for chaining method invocation.
|
||||
super.a().b().c()
|
||||
push super
|
||||
send_to_super a
|
||||
send_to_self b
|
||||
send_to_self c
|
||||
(send_to_xxx is lookup + call)
|
||||
send the message aaa to the receiver
|
||||
(:self aaa)
|
||||
|
||||
send the message aaa to the receiver but let it resolve the method in the superclass side.
|
||||
(:super aaa)
|
||||
|
||||
we need a way to swap the first parameter and the called function
|
||||
(: a b 2 3 4)
|
||||
send the message dump to the object pointed to by x with arguments 1, 2, 3.
|
||||
(:x dump 1 2 3)
|
||||
|
||||
(a b 2 3 4)
|
||||
(a.b.c 20 30 40)
|
||||
((a:b 20 30):c 30)
|
||||
|
||||
## method types
|
||||
|
||||
- class method
|
||||
- class instantiation method
|
||||
- instance method
|
||||
|
||||
## dynamic dispatching by method name
|
||||
(defclass X
|
||||
(defun t1 (x) (printf "t1 = %d\n" (+ x x x)))
|
||||
(defun t2 (x) (printf "t2 = %d\n" (* x x x)))
|
||||
)
|
||||
|
||||
(defun get-name-1() "t1")
|
||||
(defun get-name-2() "t2")
|
||||
|
||||
(set x (object-new X))
|
||||
|
||||
(:x (get-name-1) 100) ; must be same as (:x t1 100)
|
||||
(:x (get-name-2) 100) ; must be same as (:x t2 100)
|
||||
|
||||
## Something to look into..
|
||||
|
||||
normal function call
|
||||
(f arg1 arg2 arg3)
|
||||
(rcv f arg1 arg2)
|
||||
|
||||
## dynamic method invocation???
|
||||
(:X (f) arg1 arg2)
|
||||
as long as f returns a symbol, it can also invoke a method??
|
||||
|
||||
|
||||
@ -299,6 +299,7 @@ static int find_variable_backward (hcl_t* hcl, const hcl_cnode_t* token, hcl_var
|
||||
|
||||
for (fi = hcl->c->fnblk.depth + 1; fi > i; ) /* TOOD: review this loop for correctness */
|
||||
{
|
||||
/* 'i' is the function level that hold the class defintion block. the check must not go past it */
|
||||
if (hcl->c->fnblk.info[--fi].fun_type == FUN_CM)
|
||||
{
|
||||
/* the function where this variable is defined is a class method or an plain function block within a class method*/
|
||||
@ -1550,11 +1551,12 @@ static int compile_break (hcl_t* hcl, hcl_cnode_t* src)
|
||||
goto inside_loop;
|
||||
|
||||
case HCL_CBLK_TYPE_TRY:
|
||||
/*must emit an instruction to exit from the try loop.*/
|
||||
/* emit an instruction to exit from the try loop. */
|
||||
if (emit_byte_instruction(hcl, HCL_CODE_TRY_EXIT, HCL_CNODE_GET_LOC(src)) <= -1) return -1;
|
||||
break;
|
||||
|
||||
case HCL_CBLK_TYPE_CLASS:
|
||||
/* emit an instruction to exit from the class definition scope being defined */
|
||||
if (emit_byte_instruction(hcl, HCL_CODE_CLASS_EXIT, HCL_CNODE_GET_LOC(src)) <= -1) return -1;
|
||||
break;
|
||||
}
|
||||
@ -2243,6 +2245,7 @@ static HCL_INLINE int compile_class_p1 (hcl_t* hcl)
|
||||
}
|
||||
|
||||
if (push_clsblk(hcl, &cf->u._class.start_loc, nivars, ncvars, &hcl->c->tv.s.ptr[ivar_start], ivar_len, &hcl->c->tv.s.ptr[cvar_start], cvar_len) <= -1) goto oops;
|
||||
if (push_cblk(hcl, &cf->u._class.start_loc, HCL_CBLK_TYPE_CLASS) <= -1) goto oops; /* the class block shall be treated as a control block, too */
|
||||
|
||||
/* discard the instance variables and class variables in the temporary variable collection buffer
|
||||
* because they have been pushed to the class block structure */
|
||||
@ -2299,6 +2302,7 @@ static HCL_INLINE int compile_class_p2 (hcl_t* hcl)
|
||||
if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_CNODE_GET_LOC(cf->operand)) <= -1) return -1;
|
||||
}
|
||||
|
||||
pop_cblk (hcl);
|
||||
pop_clsblk (hcl); /* end of the class block */
|
||||
|
||||
if (emit_byte_instruction(hcl, HCL_CODE_CLASS_PEXIT, HCL_CNODE_GET_LOC(cf->operand)) <= -1) return -1;
|
||||
|
||||
166
lib/exec.c
166
lib/exec.c
@ -140,7 +140,7 @@ static void terminate_all_processes (hcl_t* hcl);
|
||||
|
||||
/* ------------------------------------------------------------------------- */
|
||||
|
||||
#define HCL_EXSTACK_PUSH(hcl, ctx_, ip_, clsp_) \
|
||||
#define HCL_EXSTACK_PUSH(hcl, ctx_, ip_, clsp_, sp_) \
|
||||
do { \
|
||||
hcl_oop_process_t ap = (hcl)->processor->active; \
|
||||
hcl_ooi_t exsp = HCL_OOP_TO_SMOOI(ap->exsp); \
|
||||
@ -152,6 +152,7 @@ static void terminate_all_processes (hcl_t* hcl);
|
||||
exsp++; ap->slot[exsp] = (ctx_); \
|
||||
exsp++; ap->slot[exsp] = HCL_SMOOI_TO_OOP(ip_); \
|
||||
exsp++; ap->slot[exsp] = HCL_SMOOI_TO_OOP(clsp_); \
|
||||
exsp++; ap->slot[exsp] = HCL_SMOOI_TO_OOP(sp_); \
|
||||
ap->exsp = HCL_SMOOI_TO_OOP(exsp); \
|
||||
} while (0)
|
||||
|
||||
@ -159,14 +160,15 @@ 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); \
|
||||
exsp -= 3; \
|
||||
exsp -= 4; \
|
||||
ap->exsp = HCL_SMOOI_TO_OOP(exsp); \
|
||||
} while (0)
|
||||
|
||||
#define HCL_EXSTACK_POP_TO(hcl, ctx_, ip_, clsp_) \
|
||||
#define HCL_EXSTACK_POP_TO(hcl, ctx_, ip_, clsp_, sp_) \
|
||||
do { \
|
||||
hcl_oop_process_t ap = (hcl)->processor->active; \
|
||||
hcl_ooi_t exsp = HCL_OOP_TO_SMOOI(ap->exsp); \
|
||||
sp_ = HCL_OOP_TO_SMOOI(ap->slot[exsp]); exsp--; \
|
||||
clsp_ = HCL_OOP_TO_SMOOI(ap->slot[exsp]); exsp--; \
|
||||
ip_ = HCL_OOP_TO_SMOOI(ap->slot[exsp]); exsp--; \
|
||||
ctx_ = ap->slot[exsp]; exsp--; \
|
||||
@ -602,7 +604,7 @@ static hcl_oop_process_t make_process (hcl_t* hcl, hcl_oop_context_t c)
|
||||
|
||||
static HCL_INLINE void sleep_active_process (hcl_t* hcl, int state)
|
||||
{
|
||||
STORE_ACTIVE_SP(hcl);
|
||||
STORE_ACTIVE_SP (hcl);
|
||||
|
||||
/* store the current active context to the current process.
|
||||
* it is the suspended context of the process to be suspended */
|
||||
@ -644,7 +646,7 @@ static void switch_to_process (hcl_t* hcl, hcl_oop_process_t proc, int new_state
|
||||
|
||||
/* the new process must be in the runnable state */
|
||||
HCL_ASSERT (hcl, proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNABLE) ||
|
||||
proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_WAITING));
|
||||
proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_WAITING));
|
||||
|
||||
sleep_active_process (hcl, new_state_for_old_active);
|
||||
wake_process (hcl, proc);
|
||||
@ -903,10 +905,12 @@ static void dump_process_info (hcl_t* hcl, hcl_bitmask_t log_mask)
|
||||
static HCL_INLINE void reset_process_stack_pointers (hcl_t* hcl, hcl_oop_process_t proc)
|
||||
{
|
||||
#if defined(HCL_DEBUG_VM_PROCESSOR)
|
||||
HCL_LOG9 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG,
|
||||
"Processor - process[%zd] SP: %zd ST: %zd EXSP: %zd(%zd) EXST: %zd CLSP: %zd(%zd) CLST: %zd\n",
|
||||
HCL_LOG4 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG,
|
||||
"Processor - process[%zd] SP: %zd(%zd) ST: %zd",
|
||||
HCL_OOP_TO_SMOOI(proc->id),
|
||||
HCL_OOP_TO_SMOOI(proc->sp), HCL_OOP_TO_SMOOI(proc->st),
|
||||
HCL_OOP_TO_SMOOI(proc->sp), HCL_OOP_TO_SMOOI(proc->sp) - (-1), HCL_OOP_TO_SMOOI(proc->st));
|
||||
HCL_LOG6 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG,
|
||||
" EXSP: %zd(%zd) EXST: %zd CLSP: %zd(%zd) CLST: %zd\n",
|
||||
HCL_OOP_TO_SMOOI(proc->exsp), HCL_OOP_TO_SMOOI(proc->exsp) - HCL_OOP_TO_SMOOI(proc->st), HCL_OOP_TO_SMOOI(proc->exst),
|
||||
HCL_OOP_TO_SMOOI(proc->clsp), HCL_OOP_TO_SMOOI(proc->clsp) - HCL_OOP_TO_SMOOI(proc->exst), HCL_OOP_TO_SMOOI(proc->clst));
|
||||
#endif
|
||||
@ -930,12 +934,16 @@ static void terminate_process (hcl_t* hcl, hcl_oop_process_t proc)
|
||||
{
|
||||
hcl_oop_process_t nrp;
|
||||
|
||||
/* terminating the active process */
|
||||
HCL_ASSERT (hcl, proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNING));
|
||||
|
||||
nrp = find_next_runnable_process(hcl);
|
||||
|
||||
STORE_ACTIVE_SP (hcl); /* commit the stack pointer before termination */
|
||||
|
||||
unchain_from_processor (hcl, proc, PROC_STATE_TERMINATED);
|
||||
reset_process_stack_pointers (hcl, proc); /* invalidate the process stack */
|
||||
proc->current_context = proc->initial_context; /* not needed but just in case */
|
||||
|
||||
/* a runnable or running process must not be chanined to the
|
||||
* process list of a semaphore */
|
||||
HCL_ASSERT (hcl, (hcl_oop_t)proc->sem == hcl->_nil);
|
||||
@ -960,11 +968,14 @@ static void terminate_process (hcl_t* hcl, hcl_oop_process_t proc)
|
||||
}
|
||||
else
|
||||
{
|
||||
/* there are other processes to schedule */
|
||||
switch_to_process (hcl, nrp, PROC_STATE_TERMINATED);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
/* termiante a runnable process which is not an actively running process */
|
||||
HCL_ASSERT (hcl, proc->state == HCL_SMOOI_TO_OOP(PROC_STATE_RUNNABLE));
|
||||
unchain_from_processor (hcl, proc, PROC_STATE_TERMINATED);
|
||||
reset_process_stack_pointers (hcl, proc); /* invalidate the process stack */
|
||||
}
|
||||
@ -2137,7 +2148,8 @@ static hcl_oop_block_t find_cmethod_noseterr (hcl_t* hcl, hcl_oop_class_t class_
|
||||
|
||||
/* TODO: implement method cache */
|
||||
HCL_ASSERT (hcl, HCL_IS_CLASS(hcl, class_));
|
||||
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, op_name));
|
||||
/*HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, op_name));*/
|
||||
HCL_ASSERT (hcl, HCL_OBJ_IS_CHAR_POINTER(op_name));
|
||||
|
||||
name.ptr = HCL_OBJ_GET_CHAR_SLOT(op_name);
|
||||
name.len = HCL_OBJ_GET_SIZE(op_name);
|
||||
@ -2179,15 +2191,16 @@ 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, int to_super, hcl_ooi_t* ivaroff, hcl_oop_class_t* owner)
|
||||
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)
|
||||
{
|
||||
hcl_oocs_t name;
|
||||
|
||||
HCL_ASSERT (hcl, HCL_IS_CLASS(hcl, class_));
|
||||
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, op));
|
||||
/*HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, op_name));*/
|
||||
HCL_ASSERT (hcl, HCL_OBJ_IS_CHAR_POINTER(op_name));
|
||||
|
||||
name.ptr = HCL_OBJ_GET_CHAR_SLOT(op);
|
||||
name.len = HCL_OBJ_GET_SIZE(op);
|
||||
name.ptr = HCL_OBJ_GET_CHAR_SLOT(op_name);
|
||||
name.len = HCL_OBJ_GET_SIZE(op_name);
|
||||
|
||||
if (to_super)
|
||||
{
|
||||
@ -2234,7 +2247,8 @@ static HCL_INLINE int send_message (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t msg, in
|
||||
hcl_ooi_t ivaroff;
|
||||
int x;
|
||||
|
||||
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, msg));
|
||||
HCL_ASSERT (hcl, HCL_OBJ_IS_CHAR_POINTER(msg));
|
||||
/*HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, msg));*/
|
||||
|
||||
/* ============================= */
|
||||
/* TODO: implement methods cache */
|
||||
@ -2272,7 +2286,7 @@ static HCL_INLINE int send_message (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t msg, in
|
||||
static HCL_INLINE int do_throw (hcl_t* hcl, hcl_oop_t val, hcl_ooi_t ip)
|
||||
{
|
||||
hcl_oop_context_t catch_ctx;
|
||||
hcl_ooi_t catch_ip, clsp;
|
||||
hcl_ooi_t catch_ip, clsp, sp;
|
||||
|
||||
if (HCL_EXSTACK_IS_EMPTY(hcl))
|
||||
{
|
||||
@ -2300,7 +2314,7 @@ static HCL_INLINE int do_throw (hcl_t* hcl, hcl_oop_t val, hcl_ooi_t ip)
|
||||
}
|
||||
|
||||
/* pop the exception stack to get information to rewind context */
|
||||
HCL_EXSTACK_POP_TO (hcl, catch_ctx, catch_ip, clsp);
|
||||
HCL_EXSTACK_POP_TO (hcl, catch_ctx, catch_ip, clsp, sp);
|
||||
|
||||
/* discard unfinished class definitions for the exception thrown.
|
||||
*
|
||||
@ -2319,6 +2333,8 @@ static HCL_INLINE int do_throw (hcl_t* hcl, hcl_oop_t val, hcl_ooi_t ip)
|
||||
SWITCH_ACTIVE_CONTEXT (hcl, catch_ctx);
|
||||
hcl->ip = catch_ip; /* override the instruction pointer */
|
||||
|
||||
hcl->sp = sp; /* restore the stack pointer of the active process context */
|
||||
|
||||
/* push the exception value to the stack */
|
||||
HCL_STACK_PUSH (hcl, val);
|
||||
return 0;
|
||||
@ -2893,7 +2909,7 @@ switch_to_next:
|
||||
|
||||
/* ------------------------------------------------------------------------- */
|
||||
|
||||
static HCL_INLINE int do_return (hcl_t* hcl, hcl_oop_t return_value)
|
||||
static HCL_INLINE int do_return_from_home (hcl_t* hcl, hcl_oop_t return_value)
|
||||
{
|
||||
/* if (hcl->active_context == hcl->processor->active->initial_context) // read the interactive mode note below... */
|
||||
if ((hcl_oop_t)hcl->active_context->home == hcl->_nil)
|
||||
@ -2967,13 +2983,13 @@ static HCL_INLINE int do_return (hcl_t* hcl, hcl_oop_t return_value)
|
||||
}
|
||||
|
||||
hcl->active_context->home->ip = HCL_SMOOI_TO_OOP(-1); /* mark that this context has returned */
|
||||
hcl->ip = -1; /* mark that the active context has returned. saved into hcl->active_context->ip in SWITCH_ACTIVE_CONTEXT() */
|
||||
|
||||
hcl->ip = -1; /* mark that the active context has returned. committed to hcl->active_context->ip in SWITCH_ACTIVE_CONTEXT() */
|
||||
SWITCH_ACTIVE_CONTEXT (hcl, hcl->active_context->home->sender);
|
||||
|
||||
/* push the return value to the stack of the new active context */
|
||||
HCL_STACK_PUSH (hcl, return_value);
|
||||
|
||||
|
||||
#if 0
|
||||
/* stack dump */
|
||||
HCL_DEBUG1 (hcl, "****** non local returning %O\n", return_value);
|
||||
@ -3005,18 +3021,69 @@ static HCL_INLINE void do_return_from_block (hcl_t* hcl)
|
||||
}
|
||||
else
|
||||
{
|
||||
/* The compiler produces the class_exit instruction and the try_exit instruction
|
||||
* for return, break, continue in a class defintion scope and in a try-catch scope
|
||||
* respectively.
|
||||
|
||||
/*
|
||||
TODO: should i restore the class stack pointer too???
|
||||
let context remeber the it and use it to restore
|
||||
|
||||
[CASE 1]
|
||||
(defclass X
|
||||
; ....
|
||||
(return 20) ; the class defintion isn't over, but return is executed?? or simply disallow return in the class context outside a method?
|
||||
(return 20) ; the class defintion isn't over, but return is executed,
|
||||
; ....
|
||||
)
|
||||
*/
|
||||
|
||||
[CASE 2]
|
||||
(try
|
||||
(defclass C
|
||||
(return 200)
|
||||
(printf "============================\n"))
|
||||
catch (e)
|
||||
(printf "EXCEPTION => %O\n" e)
|
||||
)
|
||||
|
||||
[CASE 3]
|
||||
(defclass C
|
||||
(try
|
||||
(return 99)
|
||||
catch (e)
|
||||
(printf "EXCEPTOIN => %O\n" e)
|
||||
)
|
||||
(printf "============================\n")
|
||||
)
|
||||
|
||||
[CASE 4]
|
||||
(try
|
||||
(defclass C
|
||||
(try
|
||||
(return 99)
|
||||
catch (e)
|
||||
(printf "EXCEPTOIN => %O\n" e)
|
||||
)
|
||||
(printf "============================\n")
|
||||
)
|
||||
catch (e)
|
||||
(printf "EXCEPTOIN => %O\n" e)
|
||||
)
|
||||
|
||||
[CASE 5]
|
||||
(try
|
||||
(defclass D
|
||||
(defclass C
|
||||
(try
|
||||
(return 99)
|
||||
catch (e)
|
||||
(printf "EXCEPTOIN => %O\n" e)
|
||||
)
|
||||
(printf "============================\n")
|
||||
)
|
||||
}
|
||||
catch (e)
|
||||
(printf "EXCEPTOIN => %O\n" e)
|
||||
)
|
||||
|
||||
* the actual return instruction handler doesn't need to care about the
|
||||
* class stack and exception stack.
|
||||
*/
|
||||
|
||||
/* it is a normal block return as the active block context
|
||||
* is not the initial context of a process */
|
||||
@ -3063,9 +3130,34 @@ static int execute (hcl_t* hcl)
|
||||
if (hcl->abort_req < 0) goto oops;
|
||||
if (hcl->abort_req > 0 || (!hcl->no_proc_switch && switch_process_if_needed(hcl) == 0)) break;
|
||||
|
||||
if (HCL_UNLIKELY(hcl->ip >= HCL_FUNCTION_GET_CODE_SIZE(hcl->active_function)))
|
||||
if (HCL_UNLIKELY(hcl->ip < 0 || hcl->ip >= HCL_FUNCTION_GET_CODE_SIZE(hcl->active_function)))
|
||||
{
|
||||
HCL_DEBUG2 (hcl, "Stopping execution as IP reached the end of bytecode(%zu) - SP %zd\n", hcl->code.bc.len, hcl->sp);
|
||||
if (hcl->ip < 0)
|
||||
{
|
||||
/* do_return_from_home() implements a simple check against a dead context.
|
||||
* but the check is far from perfect. there are many ways to return from an
|
||||
* active context and enter a dead context thereafter.
|
||||
(defun t(f)
|
||||
(set q (lambda()
|
||||
(printf "hello word\n")
|
||||
(return-from-home 200)
|
||||
))
|
||||
(f)
|
||||
)
|
||||
(defun x()
|
||||
(t (lambda() (return-from-home 100)))
|
||||
(printf ">>>>>>>>>>>>>>>>>>>>>>>>\n");
|
||||
)
|
||||
(x) ; x is exited by (return-from-home 100) triggered by (f)
|
||||
(printf "------------------------\n")
|
||||
(q) ; (return-from-home 200) exits t and since t is called from x, it flows back to the dead x.
|
||||
*/
|
||||
HCL_DEBUG1 (hcl, "Stopping execution as a dead context gets active - IP %zd\n", hcl->ip);
|
||||
}
|
||||
else
|
||||
{
|
||||
HCL_DEBUG2 (hcl, "Stopping execution as IP reached the end of bytecode(%zu) - IP %zd\n", hcl->code.bc.len, hcl->ip);
|
||||
}
|
||||
return_value = hcl->_nil;
|
||||
goto handle_return;
|
||||
}
|
||||
@ -3531,20 +3623,23 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
|
||||
catch_ip = hcl->ip + b1;
|
||||
/* TODO: ip overflow check? */
|
||||
clsp = HCL_CLSTACK_GET_SP(hcl);
|
||||
HCL_EXSTACK_PUSH (hcl, hcl->active_context, catch_ip, clsp);
|
||||
|
||||
HCL_EXSTACK_PUSH (hcl, hcl->active_context, catch_ip, clsp, hcl->sp);
|
||||
break;
|
||||
}
|
||||
|
||||
|
||||
case HCL_CODE_TRY_ENTER2:
|
||||
{
|
||||
hcl_ooi_t catch_ip, clsp;
|
||||
|
||||
FETCH_PARAM_CODE_TO (hcl, b1);
|
||||
LOG_INST_1 (hcl, "try_enter2 %zu", b1);
|
||||
|
||||
catch_ip = hcl->ip + MAX_CODE_JUMP + b1;
|
||||
/* TODO: ip overflow check? */
|
||||
clsp = HCL_CLSTACK_GET_SP(hcl);
|
||||
HCL_EXSTACK_PUSH (hcl, hcl->active_context, catch_ip, clsp);
|
||||
|
||||
HCL_EXSTACK_PUSH (hcl, hcl->active_context, catch_ip, clsp, hcl->sp);
|
||||
break;
|
||||
}
|
||||
|
||||
@ -3860,7 +3955,8 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
|
||||
handle_send_2:
|
||||
rcv = HCL_STACK_GETRCV(hcl, b1);
|
||||
op = HCL_STACK_GETOP(hcl, b1);
|
||||
if (!HCL_IS_SYMBOL(hcl, op))
|
||||
/*if (!HCL_IS_SYMBOL(hcl, op))*/
|
||||
if (!HCL_OBJ_IS_CHAR_POINTER(op))
|
||||
{
|
||||
hcl_seterrbfmt (hcl, HCL_ECALL, "unable to send %O to %O - invalid message", op, rcv); /* TODO: change to HCL_ESEND?? */
|
||||
goto cannot_send;
|
||||
@ -3879,6 +3975,7 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
|
||||
{
|
||||
hcl_seterrbfmt (hcl, HCL_ECALL, "unable to send %O to %O - invalid receiver", op, rcv); /* TODO: change to HCL_ESEND?? */
|
||||
cannot_send:
|
||||
//HCL_STACK_POPS (hcl, b1 + 2); /* pop the receiver, message, and arguments as the call fails. TODO: check if this clearing is correct */
|
||||
if (do_throw_with_internal_errmsg(hcl, fetched_instruction_pointer) >= 0) break;
|
||||
goto oops_with_errmsg_supplement;
|
||||
}
|
||||
@ -4315,7 +4412,8 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
|
||||
break;
|
||||
|
||||
case HCL_CODE_RETURN_STACKTOP:
|
||||
/* this implements the non-local return. the non-local return is not compatible with stack based try-catch implementation. */
|
||||
/* [NOTE] this implements the non-local return. the non-local return is not compatible with stack based try-catch implementation.
|
||||
* [TODO] can make it compatiable? */
|
||||
LOG_INST_0 (hcl, "return_stacktop");
|
||||
return_value = HCL_STACK_GETTOP(hcl);
|
||||
HCL_STACK_POP (hcl);
|
||||
@ -4327,7 +4425,7 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
|
||||
|
||||
handle_return:
|
||||
hcl->last_retv = return_value;
|
||||
if (do_return(hcl, return_value) <= -1) goto oops;
|
||||
if (do_return_from_home(hcl, return_value) <= -1) goto oops;
|
||||
break;
|
||||
|
||||
case HCL_CODE_RETURN_FROM_BLOCK:
|
||||
|
||||
6
lib/gc.c
6
lib/gc.c
@ -566,10 +566,10 @@ void hcl_gc (hcl_t* hcl)
|
||||
{
|
||||
HCL_ASSERT (hcl, (hcl_oop_t)hcl->processor != hcl->_nil);
|
||||
HCL_ASSERT (hcl, (hcl_oop_t)hcl->processor->active != hcl->_nil);
|
||||
/* store the stack pointer to the active process */
|
||||
HCL_ASSERT (hcl, HCL_IS_PROCESS(hcl, hcl->processor->active));
|
||||
/* commit the stack pointer to the active process */
|
||||
hcl->processor->active->sp = HCL_SMOOI_TO_OOP(hcl->sp);
|
||||
|
||||
/* store the instruction pointer to the active context */
|
||||
/* commit the instruction pointer to the active context */
|
||||
hcl->active_context->ip = HCL_SMOOI_TO_OOP(hcl->ip);
|
||||
}
|
||||
|
||||
|
||||
14
lib/hcl.h
14
lib/hcl.h
@ -608,7 +608,7 @@ struct hcl_block_t
|
||||
|
||||
hcl_oop_t tmpr_mask; /* smooi */
|
||||
hcl_oop_context_t home; /* home context */
|
||||
hcl_oop_t ip; /* smooi. instruction pointer where the byte code begins in home->origin */
|
||||
hcl_oop_t ip; /* smooi. instruction pointer where the byte code begins in home->base */
|
||||
};
|
||||
|
||||
struct hcl_context_t
|
||||
@ -1730,12 +1730,16 @@ struct hcl_t
|
||||
(hcl)->processor->active->slot[(hcl)->sp] = v; \
|
||||
} while (0)
|
||||
|
||||
#define HCL_STACK_GET(hcl,v_sp) ((hcl)->processor->active->slot[v_sp])
|
||||
#define HCL_STACK_SET(hcl,v_sp,v_obj) ((hcl)->processor->active->slot[v_sp] = v_obj)
|
||||
#define HCL_STACK_GET(hcl,sp_) ((hcl)->processor->active->slot[sp_])
|
||||
#define HCL_STACK_SET(hcl,sp_,obj_) ((hcl)->processor->active->slot[sp_] = obj_)
|
||||
|
||||
#define HCL_STACK_GETTOP(hcl) HCL_STACK_GET(hcl, (hcl)->sp)
|
||||
#define HCL_STACK_SETTOP(hcl,v_obj) HCL_STACK_SET(hcl, (hcl)->sp, v_obj)
|
||||
#define HCL_STACK_SETTOP(hcl,obj_) HCL_STACK_SET(hcl, (hcl)->sp, obj_)
|
||||
|
||||
/* [NOTE]
|
||||
* the following macros don't commit the active stack pointer(hcl->sp)
|
||||
* to hcl->processor->active->sp immediately.
|
||||
*/
|
||||
#define HCL_STACK_POP(hcl) ((hcl)->sp = (hcl)->sp - 1)
|
||||
#define HCL_STACK_POPS(hcl,count) ((hcl)->sp = (hcl)->sp - (count))
|
||||
#define HCL_STACK_POP_TO(hcl,v) \
|
||||
@ -1743,7 +1747,7 @@ struct hcl_t
|
||||
v = HCL_STACK_GETTOP(hcl); \
|
||||
HCL_STACK_POP (hcl); \
|
||||
} while(0)
|
||||
|
||||
|
||||
#define HCL_STACK_GET_ST(hcl) HCL_OOP_TO_SMOOI((hcl)->processor->active->st)
|
||||
#define HCL_STACK_GET_SP(hcl) ((hcl)->sp)
|
||||
#define HCL_STACK_IS_EMPTY(hcl) ((hcl)->sp <= -1)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user