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

fixed the tv.wcount and tv.s.len restoration logic upon compiliation failure
All checks were successful
continuous-integration/drone/push Build is passing
Details

Browse Source
This commit is contained in:
hyung-hwan 2024-04-21 02:24:27 +09:00
parent 759c7a029b
commit 803f9b2817
7 changed files with 166 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
lib/comp.c
View File

@ -27,7 +27,6 @@
/* limit the `do` expression to have not more than 1 expression and /* limit the `do` expression to have not more than 1 expression and
* no variable declaration if not enclosed in parentheses */ * no variable declaration if not enclosed in parentheses */
#define LANG_LIMIT_DO #define LANG_LIMIT_DO
#define CLEAR_FNBLK_ALWAYS
#define FOR_NONE (0) #define FOR_NONE (0)
#define FOR_IF (1) #define FOR_IF (1)
@ -5856,23 +5855,46 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
{ {
hcl_oow_t saved_bc_len, saved_lit_len; hcl_oow_t saved_bc_len, saved_lit_len;
hcl_bitmask_t log_default_type_mask; hcl_bitmask_t log_default_type_mask;
#if !defined(CLEAR_FNBLK_ALWAYS)
hcl_fnblk_info_t top_fnblk_saved; hcl_fnblk_info_t top_fnblk_saved;
int fnblk_pushed_here = 0; int top_fnblk_pushed_here = 0;
#endif
hcl->c->flags = flags; hcl->c->flags = flags;
HCL_ASSERT (hcl, hcl->c->fnblk.depth <= 0); /* 0 or 1 fnblk must exist at this phase */ HCL_ASSERT (hcl, hcl->c->fnblk.depth <= 0); /* 0 or 1 fnblk must exist at this phase */
HCL_ASSERT (hcl, GET_TOP_CFRAME_INDEX(hcl) < 0); HCL_ASSERT (hcl, GET_TOP_CFRAME_INDEX(hcl) < 0);
#if !defined(CLEAR_FNBLK_ALWAYS)
if (flags & HCL_COMPILE_CLEAR_FNBLK) if (flags & HCL_COMPILE_CLEAR_FNBLK)
{ {
/* if the program is executed in the interactive mode,
* each compiled expression is executed immediately.
* that is, hcl_compile() is followed by hcl_execute()
* immediately.
*
* (1) a := 20
* (2) { | b c | b := 20; c := 30 }
* (3) printf "%d\n" a
*
* in the interactive mode,
* (1) is compiled and executed
* (2) is compiled and executed
* (3) is compiled and executed
*
* in the non-interactive mode,
* (1) is compiled, (2) is compiled, (3) is compiled
* (1), (2), (3) are executed
* fnblk holds information about temporaries seen so far.
* (2) has defined two temporary variables. this count
* must get carried until (3) has been compiled in the
* non-interactive mode. the accumulated count is used
* in creating an initial context for execution.
*
* in the interactive mode, the information doesn't have
* to get carried over.
*/
while (hcl->c->fnblk.depth >= 0) pop_fnblk (hcl); while (hcl->c->fnblk.depth >= 0) pop_fnblk (hcl);
HCL_ASSERT (hcl, hcl->c->fnblk.depth == -1); HCL_ASSERT (hcl, hcl->c->fnblk.depth == -1);
/* it will be recreated below */ /* it will be recreated below */
} }
#endif
if (flags & HCL_COMPILE_CLEAR_CODE) hcl_clearcode (hcl); if (flags & HCL_COMPILE_CLEAR_CODE) hcl_clearcode (hcl);
saved_bc_len = hcl->code.bc.len; saved_bc_len = hcl->code.bc.len;
@ -5915,10 +5937,8 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
/* TODO: in case i implement all global variables as block arguments at the top level...what should i do? */ /* TODO: in case i implement all global variables as block arguments at the top level...what should i do? */
HCL_ASSERT (hcl, hcl->c->cblk.depth == -1); HCL_ASSERT (hcl, hcl->c->cblk.depth == -1);
#if !defined(CLEAR_FNBLK_ALWAYS)
if (hcl->c->fnblk.depth <= -1) if (hcl->c->fnblk.depth <= -1)
{ {
#endif
HCL_ASSERT (hcl, hcl->c->fnblk.depth == -1); HCL_ASSERT (hcl, hcl->c->fnblk.depth == -1);
HCL_ASSERT (hcl, hcl->c->tv.s.len == 0); HCL_ASSERT (hcl, hcl->c->tv.s.len == 0);
HCL_ASSERT (hcl, hcl->c->tv.wcount == 0); HCL_ASSERT (hcl, hcl->c->tv.wcount == 0);
@ -5941,11 +5961,9 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
FUN_PLAIN /* fun_type */ FUN_PLAIN /* fun_type */
) <= -1) return -1; /* must not goto oops */ ) <= -1) return -1; /* must not goto oops */
#if !defined(CLEAR_FNBLK_ALWAYS) top_fnblk_pushed_here = 1;
fnblk_pushed_here = 1;
} }
top_fnblk_saved = hcl->c->fnblk.info[0]; top_fnblk_saved = hcl->c->fnblk.info[0];
#endif
HCL_ASSERT (hcl, hcl->c->fnblk.depth == 0); /* ensure the virtual function block is added */ HCL_ASSERT (hcl, hcl->c->fnblk.depth == 0); /* ensure the virtual function block is added */
PUSH_CFRAME (hcl, COP_COMPILE_OBJECT, obj); PUSH_CFRAME (hcl, COP_COMPILE_OBJECT, obj);
@ -6204,27 +6222,31 @@ oops:
while (hcl->c->fnblk.depth > 0) pop_fnblk (hcl); while (hcl->c->fnblk.depth > 0) pop_fnblk (hcl);
HCL_ASSERT (hcl, hcl->c->fnblk.depth == 0); HCL_ASSERT (hcl, hcl->c->fnblk.depth == 0);
#if !defined(CLEAR_FNBLK_ALWAYS) if (top_fnblk_pushed_here)
if (fnblk_pushed_here)
{ {
#endif
pop_fnblk (hcl); pop_fnblk (hcl);
HCL_ASSERT (hcl, hcl->c->fnblk.depth == -1); HCL_ASSERT (hcl, hcl->c->fnblk.depth == -1);
HCL_ASSERT (hcl, hcl->c->tv.s.len == 0); HCL_ASSERT (hcl, hcl->c->tv.s.len == 0);
HCL_ASSERT (hcl, hcl->c->tv.wcount == 0); HCL_ASSERT (hcl, hcl->c->tv.wcount == 0);
#if !defined(CLEAR_FNBLK_ALWAYS)
} }
else else
{ {
hcl->c->tv.s.len = 0; /*
hcl->c->tv.wcount = 0; { |a b c| } ## tv.s.len 6, tv.wcount 3
{ |k a| (set x y z) }
*
* at this point when (set a b c) triggers a syntax error
* tv.s.len is 10 and tv.wcount is 5.
* it must be restored to 6 and 3 each.
*/
/* restore the top level function block as it's first captured in this function */ /* restore the top level function block as it's first captured in this function */
clear_fnblk_inners (hcl); clear_fnblk_inners (hcl);
HCL_ASSERT (hcl, hcl->c->fnblk.depth == 0); HCL_ASSERT (hcl, hcl->c->fnblk.depth == 0);
hcl->c->fnblk.info[0] = top_fnblk_saved; hcl->c->fnblk.info[0] = top_fnblk_saved;
hcl->c->tv.s.len = top_fnblk_saved.tmprlen;
hcl->c->tv.wcount = top_fnblk_saved.tmprcnt;
} }
#endif
return -1; return -1;
} }

5
lib/hcl.h
View File

@ -2840,11 +2840,6 @@ HCL_EXPORT hcl_oop_t hcl_makedic (
hcl_oow_t inisize /* initial bucket size */ hcl_oow_t inisize /* initial bucket size */
); );
HCL_EXPORT hcl_oop_t hcl_makecontext (
hcl_t* hcl,
hcl_ooi_t ntmprs
);
HCL_EXPORT hcl_oop_t hcl_makeclass ( HCL_EXPORT hcl_oop_t hcl_makeclass (
hcl_t* hcl, hcl_t* hcl,
hcl_oop_t superclass, hcl_oop_t superclass,

2
lib/read.c
View File

@ -1089,7 +1089,9 @@ static int feed_begin_include (hcl_t* hcl)
hcl_io_cciarg_t* arg; hcl_io_cciarg_t* arg;
const hcl_ooch_t* io_name; const hcl_ooch_t* io_name;
/*hcl_logbfmt(hcl, HCL_LOG_STDERR, "adding... %js\n", TOKEN_NAME_PTR(hcl));*/
io_name = add_sr_name(hcl, TOKEN_NAME(hcl)); io_name = add_sr_name(hcl, TOKEN_NAME(hcl));
/*hcl_logbfmt(hcl, HCL_LOG_STDERR, "added... %js\n", io_name);*/
if (HCL_UNLIKELY(!io_name)) if (HCL_UNLIKELY(!io_name))
{ {
const hcl_ooch_t* orgmsg = hcl_backuperrmsg(hcl); const hcl_ooch_t* orgmsg = hcl_backuperrmsg(hcl);

4
t/Makefile.am
View File

@ -8,7 +8,9 @@ check_SCRIPTS = \
ret-01.hcl \ ret-01.hcl \
retvar-01.hcl \ retvar-01.hcl \
va-01.hcl \ va-01.hcl \
var-02.hcl var-01.hcl \
var-02.hcl \
var-03.hcl
check_ERRORS = \ check_ERRORS = \
call-5001.err \ call-5001.err \

4
t/Makefile.in
View File

@ -480,7 +480,9 @@ check_SCRIPTS = \
ret-01.hcl \ ret-01.hcl \
retvar-01.hcl \ retvar-01.hcl \
va-01.hcl \ va-01.hcl \
var-02.hcl var-01.hcl \
var-02.hcl \
var-03.hcl
check_ERRORS = \ check_ERRORS = \
call-5001.err \ call-5001.err \

150
t/var-01.hcl
View File

@ -1,111 +1,97 @@
(defun x (a b :: r) defun x (a b :: r) {
| x y | | x y |
(set x a) set x a
(set y b) set y b
(if (> a b) if (> a b) {
(do
| a b | | a b |
(set a (mod x y)) set a (mod x y)
(set b (+ x y)) set b (+ x y)
(set r (* a b)) set r (* a b)
) } else {
else
(do
| a b | | a b |
(set a (* x y)) set a (* x y)
(set b (- x y)) set b (- x y)
(set r (* a b)) set r (* a b)
) }
)
(if (/= x a) (printf "ERROR: x is not equal to a\n"))
(if (/= y b) (printf "ERROR: y is not equal to b\n"))
)
(set t (x 10 20))
(if (/= t -2000) (printf "ERROR: t is not equal to -2000\n")
else (printf "OK: %d\n" t))
(set t (x 30 20))
(if (/= t 500) (printf "ERROR: t is not equal to 500\n")
else (printf "OK: %d\n" t))
(defun x () if (/= x a) (printf "ERROR: x is not equal to a\n")
if (/= y b) (printf "ERROR: y is not equal to b\n")
}
t := (x 10 20)
if (/= t -2000) (printf "ERROR: t is not equal to -2000\n") \
else (printf "OK: %d\n" t)
set t (x 30 20)
if (/= t 500) (printf "ERROR: t is not equal to 500\n") \
else (printf "OK: %d\n" t)
defun x () {
(do
| x y | | x y |
(set x 99) set x 99
(try try {
(do
| x | | x |
(set x 88) set x 88
(if (/= x 88) (printf "ERROR: x is not 88\n") if (/= x 88) (printf "ERROR: x is not 88\n") \
else (printf "OK: %d\n" x)) else (printf "OK: %d\n" x)
(throw 1000) throw 1000
) } catch (x) {
catch (x) if (/= x 1000) (printf "ERROR: x is not 1000\n") \
(if (/= x 1000) (printf "ERROR: x is not 1000\n") else (printf "OK: %d\n" x)
else (printf "OK: %d\n" x)) set y x
(set y x) }
)
(if (/= x 99) (printf "ERROR: x is not 99\n") if (/= x 99) (printf "ERROR: x is not 99\n") \
else (printf "OK: %d\n" x)) else (printf "OK: %d\n" x)
(if (/= y 1000) (print "ERROR: y is not 1000\n") if (/= y 1000) (print "ERROR: y is not 1000\n") \
else (printf "OK: %d\n" y)) else (printf "OK: %d\n" y)
) }
)
(x) x
(defclass T class T | j | {
| j |
(defun :* new() defun :* new() {
(set j 99) set j 99
(return self) return self
) }
(defun x() defun x() {
(set R set R {
(do
| x | | x |
(set x 1) set x 1
(while (< x j) while (< x j) {
(defun Q() x) defun Q() x
(set x (+ x 1)) set x (+ x 1)
) }
) }
) }
) }
)
(set t (:T new)) set t (T:new)
(:t x) t:x
(set t (Q)) set t (Q)
(if (/= t 99) (print "ERROR: t is not 99\n") if (/= t 99) (print "ERROR: t is not 99\n") \
else (printf "OK: %d\n" t)) else (printf "OK: %d\n" t)
(if (nqv? R false) (print "ERROR: R is not false\n") if (nqv? R false) (print "ERROR: R is not false\n") \
else (printf "OK: %O\n" R)) else (printf "OK: %O\n" R)
(set v set v #(
#(
(do |a b| (set a 10) (set b 20) (+ a b) ) (do |a b| (set a 10) (set b 20) (+ a b) )
(do |a b| (set a 11) (set b 21) (+ a b) ) (do |a b| (set a 11) (set b 21) (+ a b) )
999 999
)
) )
(set v2 #(30 32 999)) set v2 #(30 32 999)
(if (nql? v v2) (print "ERROR: v1 and v2 are not equal\n") if (nql? v v2) (print "ERROR: v1 and v2 are not equal\n")\
else (printf "OK: v and v2 equal\n")) else (printf "OK: v and v2 equal\n")

31
t/var-03.hcl Normal file
View File

@ -0,0 +1,31 @@
## there are 8 local temporaries variables in the top-level context
## the 8 temporaries defined inside the block expression are parked
## at the top-level context. 'a' assigned before the block expression
## is a global variable.
a := 1234
{
| a b c d |
| e f g h |
a := 10
b := 20
c := 30
d := 40
e := 50
f := 60
g := 70
h := 80
if (/= a 10) { print "ERROR: a inside the block expression is not 10\n" } \
else { printf "OK: %d\n" a };
}
a := (a + 1)
c := (sprintf "%d" a)
if (/= a 1235) { printf "ERROR: a is not 1235\n" } \
else { printf "OK: %d\n" a };
if (nql? c "1235") { printf "ERROR: c is not \"1235\"\n" } \
else { printf "OK: %s\n" c };