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
* no variable declaration if not enclosed in parentheses */
#define LANG_LIMIT_DO
#define CLEAR_FNBLK_ALWAYS
#define FOR_NONE (0)
#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_bitmask_t log_default_type_mask;
#if !defined(CLEAR_FNBLK_ALWAYS)
hcl_fnblk_info_t top_fnblk_saved;
int fnblk_pushed_here = 0;
#endif
int top_fnblk_pushed_here = 0;
hcl->c->flags = flags;
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);
#if !defined(CLEAR_FNBLK_ALWAYS)
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);
HCL_ASSERT (hcl, hcl->c->fnblk.depth == -1);
/* it will be recreated below */
}
#endif
if (flags & HCL_COMPILE_CLEAR_CODE) hcl_clearcode (hcl);
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? */
HCL_ASSERT (hcl, hcl->c->cblk.depth == -1);
#if !defined(CLEAR_FNBLK_ALWAYS)
if (hcl->c->fnblk.depth <= -1)
{
#endif
HCL_ASSERT (hcl, hcl->c->fnblk.depth == -1);
HCL_ASSERT (hcl, hcl->c->tv.s.len == 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 */
) <= -1) return -1; /* must not goto oops */
#if !defined(CLEAR_FNBLK_ALWAYS)
fnblk_pushed_here = 1;
top_fnblk_pushed_here = 1;
}
top_fnblk_saved = hcl->c->fnblk.info[0];
#endif
HCL_ASSERT (hcl, hcl->c->fnblk.depth == 0); /* ensure the virtual function block is added */
PUSH_CFRAME (hcl, COP_COMPILE_OBJECT, obj);
@ -6204,27 +6222,31 @@ oops:
while (hcl->c->fnblk.depth > 0) pop_fnblk (hcl);
HCL_ASSERT (hcl, hcl->c->fnblk.depth == 0);
#if !defined(CLEAR_FNBLK_ALWAYS)
if (fnblk_pushed_here)
if (top_fnblk_pushed_here)
{
#endif
pop_fnblk (hcl);
HCL_ASSERT (hcl, hcl->c->fnblk.depth == -1);
HCL_ASSERT (hcl, hcl->c->tv.s.len == 0);
HCL_ASSERT (hcl, hcl->c->tv.wcount == 0);
#if !defined(CLEAR_FNBLK_ALWAYS)
}
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 */
clear_fnblk_inners (hcl);
HCL_ASSERT (hcl, hcl->c->fnblk.depth == 0);
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;
}

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_EXPORT hcl_oop_t hcl_makecontext (
hcl_t* hcl,
hcl_ooi_t ntmprs
);
HCL_EXPORT hcl_oop_t hcl_makeclass (
hcl_t* hcl,
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;
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));
/*hcl_logbfmt(hcl, HCL_LOG_STDERR, "added... %js\n", io_name);*/
if (HCL_UNLIKELY(!io_name))
{
const hcl_ooch_t* orgmsg = hcl_backuperrmsg(hcl);

4
t/Makefile.am
View File

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

4
t/Makefile.in
View File

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

188
t/var-01.hcl
View File

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