From 58165aad494b732490e9d974ea9b7a693055e2e7 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Thu, 21 Jan 2021 14:59:01 +0000 Subject: [PATCH] updated lambda/return/return-from-home compiling code in the new compiler --- bin/main.c | 2 +- lib/comp.c | 1 - lib/comp2.c | 329 +++++++++++++++++++++++--------------------------- lib/hcl-prv.h | 16 ++- lib/read.c | 11 ++ lib/read2.c | 9 ++ 6 files changed, 180 insertions(+), 188 deletions(-) diff --git a/bin/main.c b/bin/main.c index 4841cf3..df59fa2 100644 --- a/bin/main.c +++ b/bin/main.c @@ -1175,7 +1175,7 @@ hcl_logufmt (hcl, HCL_LOG_WARN, fmt, ustr, 0x6789); -#if 0 +#if 1 //////////////////////////// { hcl_cnode_t* xx; diff --git a/lib/comp.c b/lib/comp.c index c13596d..30685ee 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -2735,7 +2735,6 @@ static HCL_INLINE int emit_set (hcl_t* hcl) cf = GET_TOP_CFRAME(hcl); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_SET); - if (cf->u.set.var_type == VAR_NAMED) { hcl_oow_t index; diff --git a/lib/comp2.c b/lib/comp2.c index 02f4445..1280d2b 100644 --- a/lib/comp2.c +++ b/lib/comp2.c @@ -67,14 +67,14 @@ literals --> ------------------------------ */ -static int copy_string_to (hcl_t* hcl, const hcl_oocs_t* src, hcl_oocx_t* dst, int append, hcl_ooch_t delim_char) +static int copy_string_to (hcl_t* hcl, const hcl_oocs_t* src, hcl_oocs_t* dst, hcl_oow_t* dstcapa, int append, hcl_ooch_t delim_char) { hcl_oow_t len, pos; if (append) { - pos = dst->s.len; - len = dst->s.len + src->len; + pos = dst->len; + len = dst->len + src->len; if (delim_char != '\0') len++; } else @@ -83,28 +83,28 @@ static int copy_string_to (hcl_t* hcl, const hcl_oocs_t* src, hcl_oocx_t* dst, i len = src->len; } - if (len >= dst->capa) + if (len >= *dstcapa) { hcl_ooch_t* tmp; hcl_oow_t capa; capa = HCL_ALIGN(len + 1, TV_BUFFER_ALIGN); - tmp = (hcl_ooch_t*)hcl_reallocmem(hcl, dst->s.ptr, HCL_SIZEOF(*tmp) * capa); + tmp = (hcl_ooch_t*)hcl_reallocmem(hcl, dst->ptr, HCL_SIZEOF(*tmp) * capa); if (HCL_UNLIKELY(!tmp)) return -1; - dst->s.ptr = tmp; - dst->capa = capa - 1; + dst->ptr = tmp; + *dstcapa = capa - 1; } - if (append && delim_char != '\0') dst->s.ptr[pos++] = delim_char; - hcl_copy_oochars (&dst->s.ptr[pos], src->ptr, src->len); - dst->s.ptr[len] = '\0'; - dst->s.len = len; + if (append && delim_char != '\0') dst->ptr[pos++] = delim_char; + hcl_copy_oochars (&dst->ptr[pos], src->ptr, src->len); + dst->ptr[len] = '\0'; + dst->len = len; return 0; } -static int find_word_in_string (const hcl_oocs_t* haystack, const hcl_oocs_t* name, int last, hcl_oow_t* xindex) +static int __find_word_in_string (const hcl_oocs_t* haystack, const hcl_oocs_t* name, int last, hcl_oow_t* xindex) { /* this function is inefficient. but considering the typical number * of arguments and temporary variables, the inefficiency can be @@ -138,7 +138,7 @@ static int find_word_in_string (const hcl_oocs_t* haystack, const hcl_oocs_t* na else { if (xindex) *xindex = index; - return 0; + return 0; /* found */ } } @@ -159,77 +159,37 @@ static int find_word_in_string (const hcl_oocs_t* haystack, const hcl_oocs_t* na if (found != HCL_TYPE_MAX(hcl_oow_t)) { if (xindex) *xindex = found; - return 0; + return 0; /* foudn */ } - return -1; + return -1; /* not found */ } static int add_temporary_variable (hcl_t* hcl, const hcl_oocs_t* name, hcl_oow_t dup_check_start) { -#if 0 - hcl_oow_t i; + hcl_oocs_t s; + int x; - HCL_ASSERT (hcl, HCL_IS_SYMBOL (hcl, name)); - - for (i = dup_check_start; i < hcl->c->tv.size; i++) + s.ptr = hcl->c->tv2.s.ptr + dup_check_start; + s.len = hcl->c->tv2.s.len - dup_check_start; + if (__find_word_in_string(&s, name, 0, HCL_NULL) >= 0) { - HCL_ASSERT (hcl, HCL_IS_SYMBOL (hcl, hcl->c->tv.ptr[i])); - if (hcl->c->tv.ptr[i] == name) - { - hcl_seterrnum (hcl, HCL_EEXIST); - return -1; - } + hcl_seterrnum (hcl, HCL_EEXIST); + return -1; } - - if (hcl->c->tv.size >= hcl->c->tv.capa) - { - hcl_oop_t* tmp; - hcl_oow_t newcapa; - - newcapa = HCL_ALIGN (hcl->c->tv.capa + 1, TV_BUFFER_ALIGN); /* TODO: set a better resizing policy */ - tmp = (hcl_oop_t*)hcl_reallocmem(hcl, hcl->c->tv.ptr, newcapa); - if (HCL_UNLIKELY(!tmp)) return -1; - - hcl->c->tv.capa = newcapa; - hcl->c->tv.ptr = tmp; - } - - hcl->c->tv.ptr[hcl->c->tv.size++] = name; - return 0; -#else - /* TODO: dupcheck??? */ - return copy_string_to(hcl, name, &hcl->c->tv2, 1, ' '); -#endif + x = copy_string_to(hcl, name, &hcl->c->tv2.s, &hcl->c->tv2.capa, 1, ' '); + if (HCL_LIKELY(x >= 0)) hcl->c->tv2.wcount++; + return x; } static int find_temporary_variable_backward (hcl_t* hcl, const hcl_oocs_t* name, hcl_oow_t* index) { -#if 0 - hcl_oow_t i; - - HCL_ASSERT (hcl, HCL_IS_SYMBOL (hcl, name)); - for (i = hcl->c->tv.size; i > 0; ) - { - --i; - HCL_ASSERT (hcl, HCL_IS_SYMBOL (hcl, hcl->c->tv.ptr[i])); - if (hcl->c->tv.ptr[i] == name) - { - *index = i; - return 0; - } - } - - hcl_seterrnum (hcl, HCL_ENOENT); - return -1; -#else /* find the last element */ - return find_word_in_string(&hcl->c->tv2.s, name, 1, index); -#endif + return __find_word_in_string(&hcl->c->tv2.s, name, 1, index); } -static int store_temporary_variable_count_for_block (hcl_t* hcl, hcl_oow_t tmpr_count, hcl_oow_t lfbase) +static int store_temporary_variable_count_for_block (hcl_t* hcl, hcl_oow_t tmpr_count, hcl_oow_t tmpr_len, hcl_oow_t lfbase) { HCL_ASSERT (hcl, hcl->c->blk.depth >= 0); @@ -238,7 +198,7 @@ static int store_temporary_variable_count_for_block (hcl_t* hcl, hcl_oow_t tmpr_ hcl_blk_info_t* tmp; hcl_oow_t newcapa; - newcapa = HCL_ALIGN (hcl->c->blk.depth + 1, BLK_INFO_BUFFER_ALIGN); + newcapa = HCL_ALIGN(hcl->c->blk.depth + 1, BLK_INFO_BUFFER_ALIGN); tmp = (hcl_blk_info_t*)hcl_reallocmem(hcl, hcl->c->blk.info, newcapa * HCL_SIZEOF(*tmp)); if (!tmp) return -1; @@ -246,6 +206,7 @@ static int store_temporary_variable_count_for_block (hcl_t* hcl, hcl_oow_t tmpr_ hcl->c->blk.info = tmp; } + hcl->c->blk.info[hcl->c->blk.depth].tmprlen = tmpr_len; hcl->c->blk.info[hcl->c->blk.depth].tmprcnt = tmpr_count; hcl->c->blk.info[hcl->c->blk.depth].lfbase = lfbase; return 0; @@ -1025,191 +986,194 @@ static int compile_if (hcl_t* hcl, hcl_oop_t src) */ return 0; } +#endif -static int compile_lambda (hcl_t* hcl, hcl_oop_t src, int defun) +static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun) { - hcl_oop_t obj, args; + hcl_cnode_t* obj, * args; hcl_oow_t nargs, ntmprs; hcl_ooi_t jump_inst_pos, lfbase_pos, lfsize_pos; - hcl_oow_t saved_tv_count, tv_dup_start; - hcl_oop_t defun_name; + hcl_oow_t saved_tv_wcount, tv_dup_start; + hcl_cnode_t* defun_name; - HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); + HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); - saved_tv_count = hcl->c->tv.size; - obj = HCL_CONS_CDR(src); + saved_tv_wcount = hcl->c->tv2.wcount; + obj = HCL_CNODE_CONS_CDR(src); if (defun) { - HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_defun); + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_DEFUN)); - if (HCL_IS_NIL(hcl, obj)) + if (!obj) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_NULL, HCL_NULL, - "no defun name - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(src), HCL_NULL, "no defun name"); return -1; } - else if (!HCL_IS_CONS(hcl, obj)) + else if (!HCL_CNODE_IS_CONS(obj)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, - "redundant cdr in defun - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in defun"); return -1; } - defun_name = HCL_CONS_CAR(obj); - if (!HCL_IS_SYMBOL(hcl, defun_name)) + defun_name = HCL_CNODE_CONS_CAR(obj); + if (!HCL_CNODE_IS_SYMBOL(defun_name)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_NULL, HCL_NULL, - "defun name not a symbol - %O", defun_name); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_CNODE_GET_LOC(defun_name), HCL_CNODE_GET_TOK(defun_name), "defun name not a symbol"); return -1; } - if (HCL_OBJ_GET_FLAGS_SYNCODE(defun_name) || HCL_OBJ_GET_FLAGS_KERNEL(defun_name) >= 1) + if (HCL_CNODE_SYMBOL_SYNCODE(defun_name)) /*|| HCL_OBJ_GET_FLAGS_KERNEL(defun_name) >= 1) */ { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL, - "special symbol not to be used as a defun name - %O", defun_name); /* TOOD: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_CNODE_GET_LOC(defun_name), HCL_CNODE_GET_TOK(defun_name), "special symbol not to be used as a variable name"); return -1; } - obj = HCL_CONS_CDR(obj); + obj = HCL_CNODE_CONS_CDR(obj); } else { HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_lambda); } - if (HCL_IS_NIL(hcl, obj)) + if (!obj) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_NULL, HCL_NULL, - "no argument list in lambda - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(src), HCL_NULL, "no argument list in lambda"); return -1; } - else if (!HCL_IS_CONS(hcl, obj)) + else if (!HCL_CNODE_IS_CONS(obj)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, - "redundant cdr in lambda - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in lambda"); return -1; } - args = HCL_CONS_CAR(obj); - if (HCL_IS_NIL(hcl, args)) + args = HCL_CNODE_CONS_CAR(obj); + if (!args) { /* no argument - (lambda () (+ 10 20)) */ nargs = 0; } else { - hcl_oop_t arg, ptr; + hcl_cnode_t* arg, * dcl; - if (!HCL_IS_CONS(hcl, args)) + if (!HCL_CNODE_IS_CONS(args)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_NULL, HCL_NULL, - "not a lambda argument list - %O", args); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(args), HCL_CNODE_GET_TOK(args), "not a lambda argument list"); return -1; } - tv_dup_start = hcl->c->tv.size; + tv_dup_start = hcl->c->tv2.s.len; nargs = 0; - ptr = args; + dcl = args; do { - arg = HCL_CONS_CAR(ptr); - if (!HCL_IS_SYMBOL(hcl, arg)) + arg = HCL_CNODE_CONS_CAR(dcl); + if (!HCL_CNODE_IS_SYMBOL(arg)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAME, HCL_NULL, HCL_NULL, - "lambda argument not a symbol - %O", arg); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAME, HCL_CNODE_GET_LOC(arg), HCL_CNODE_GET_TOK(arg), "lambda argument not a symbol"); return -1; } - if (HCL_OBJ_GET_FLAGS_SYNCODE(arg) || HCL_OBJ_GET_FLAGS_KERNEL(arg) >= 2) + if (HCL_CNODE_IS_SYMBOL(arg) && HCL_CNODE_SYMBOL_SYNCODE(arg) /* || HCL_OBJ_GET_FLAGS_KERNEL(arg) >= 2 */) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDARGNAME, HCL_NULL, HCL_NULL, - "special symbol not to be declared as an argument - %O", arg); /* TOOD: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDARGNAME, HCL_CNODE_GET_LOC(arg), HCL_CNODE_GET_TOK(arg), "special symbol not to be declared as an argument"); return -1; } - if (add_temporary_variable(hcl, arg, tv_dup_start) <= -1) + if (add_temporary_variable(hcl, HCL_CNODE_GET_TOK(arg), tv_dup_start) <= -1) { if (hcl->errnum == HCL_EEXIST) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMEDUP, HCL_NULL, HCL_NULL, - "lambda argument duplicate - %O", arg); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMEDUP, HCL_CNODE_GET_LOC(arg), HCL_CNODE_GET_TOK(arg), "lambda argument duplicate"); } return -1; } nargs++; - ptr = HCL_CONS_CDR(ptr); - if (!HCL_IS_CONS(hcl, ptr)) + dcl = HCL_CNODE_CONS_CDR(dcl); + if (!dcl) break; + + if (!HCL_CNODE_IS_CONS(dcl)) { - if (!HCL_IS_NIL(hcl, ptr)) - { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, - "redundant cdr in lambda argument list - %O", args); /* TODO: error location */ - return -1; - } - break; + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(dcl), HCL_CNODE_GET_TOK(dcl), "redundant cdr in lambda argument list"); + return -1; } } while (1); } - HCL_ASSERT (hcl, nargs == hcl->c->tv.size - saved_tv_count); + HCL_ASSERT (hcl, nargs == hcl->c->tv2.wcount - saved_tv_wcount); if (nargs > MAX_CODE_NBLKARGS) /*TODO: change this limit to max call argument count */ { /* while an integer object is pused to indicate the number of * block arguments, evaluation which is done by message passing * limits the number of arguments that can be passed. so the * check is implemented */ - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_NULL, HCL_NULL, "too many(%zu) arguments - %O", nargs, args); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(args), HCL_NULL, "too many(%zu) arguments", nargs); return -1; } ntmprs = nargs; - obj = HCL_CONS_CDR(obj); + obj = HCL_CNODE_CONS_CDR(obj); - tv_dup_start = hcl->c->tv.size; - while (HCL_IS_CONS(hcl, obj)) + tv_dup_start = hcl->c->tv2.s.len; + while (obj && HCL_CNODE_IS_CONS(obj)) { - hcl_oop_t dcl; + hcl_cnode_t* dcl; - dcl = HCL_CONS_CAR(obj); - if (HCL_IS_SYMBOL_ARRAY(hcl, dcl)) + dcl = HCL_CNODE_CONS_CAR(obj); + if (HCL_CNODE_IS_CONS_CONCODED(dcl, HCL_CONCODE_VLIST)) { - hcl_oow_t i, sz; - - sz = HCL_OBJ_GET_SIZE(dcl); - for (i = 0; i < sz; i++) + hcl_cnode_t* var; + do { - if (HCL_OBJ_GET_FLAGS_SYNCODE(((hcl_oop_oop_t)dcl)->slot[i]) || - HCL_OBJ_GET_FLAGS_KERNEL(((hcl_oop_oop_t)dcl)->slot[i]) >= 2) + var = HCL_CNODE_CONS_CAR(dcl); + #if 0 + if (!HCL_CNODE_IS_SYMBOL(var)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL, - "special symbol not to be declared as a variable - %O", obj); /* TOOD: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAME, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "local variable not a symbol"); return -1; } - if (add_temporary_variable(hcl, ((hcl_oop_oop_t)dcl)->slot[i], tv_dup_start) <= -1) + if (HCL_CNODE_IS_SYMBOL(var) && HCL_CNODE_SYMBOL_SYNCODE(var) /* || HCL_OBJ_GET_FLAGS_KERNEL(var) >= 2 */) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDARGNAME, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "special symbol not to be declared as a local variable"); + return -1; + } + #else + /* the above checks are not needed as the reader guarantees the followings */ + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL(var) && !HCL_CNODE_SYMBOL_SYNCODE(var)); + #endif + + if (add_temporary_variable(hcl, HCL_CNODE_GET_TOK(var), tv_dup_start) <= -1) { if (hcl->errnum == HCL_EEXIST) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAMEDUP, HCL_NULL, HCL_NULL, - "local variable duplicate - %O", ((hcl_oop_oop_t)dcl)->slot[i]); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMEDUP, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "duplicate local variable"); } - return -1; } - ntmprs++; - } - obj = HCL_CONS_CDR(obj); + dcl = HCL_CNODE_CONS_CDR(dcl); + if (!dcl) break; + + if (!HCL_CNODE_IS_CONS(dcl)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(dcl), HCL_CNODE_GET_TOK(dcl), "redundant cdr in local variable list"); + return -1; + } + } + while (1); + + obj = HCL_CNODE_CONS_CDR(obj); } else break; } /* ntmprs: number of temporary variables including arguments */ - HCL_ASSERT (hcl, ntmprs == hcl->c->tv.size - saved_tv_count); + HCL_ASSERT (hcl, ntmprs == hcl->c->tv2.wcount - saved_tv_wcount); if (ntmprs > MAX_CODE_NBLKTMPRS) { hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARFLOOD, HCL_NULL, HCL_NULL, "too many(%zu) variables - %O", ntmprs, args); @@ -1222,7 +1186,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src, int defun) return -1; } hcl->c->blk.depth++; - if (store_temporary_variable_count_for_block(hcl, hcl->c->tv.size, hcl->code.lit.len) <= -1) return -1; + if (store_temporary_variable_count_for_block(hcl, hcl->c->tv2.wcount, hcl->c->tv2.s.len, hcl->code.lit.len) <= -1) return -1; if (hcl->option.trait & HCL_TRAIT_INTERACTIVE) @@ -1252,7 +1216,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src, int defun) hcl_oow_t index; hcl_cframe2_t* cf; - if (find_temporary_variable_backward(hcl, defun_name, &index) <= -1) + if (find_temporary_variable_backward(hcl, HCL_CNODE_GET_TOK(defun_name), &index) <= -1) { PUSH_SUBCFRAME (hcl, COP_EMIT_SET, defun_name); /* set doesn't evaluate the variable name */ cf = GET_SUBCFRAME(hcl); @@ -1282,35 +1246,37 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src, int defun) return 0; } -static int compile_return (hcl_t* hcl, hcl_oop_t src, int mode) +static int compile_return (hcl_t* hcl, hcl_cnode_t* src, int mode) { - hcl_oop_t obj, val; + hcl_cnode_t* obj, * val; - HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); - HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_return || HCL_CONS_CAR(src) == hcl->_return_from_home); + HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_RETURN) || HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_RETURN_FROM_HOME)); - obj = HCL_CONS_CDR(src); + obj = HCL_CNODE_CONS_CDR(src); -/* TODO: error message - cater for return-from home */ - if (HCL_IS_NIL(hcl, obj)) + if (!obj) { /* TODO: should i allow (return)? does it return the last value on the stack? */ /* no value */ - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, "no value specified in return - %O", src); /* TODO: error location */ + hcl_cnode_t* tmp = HCL_CNODE_CONS_CAR(src); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(src), HCL_NULL, "no value specified in %.*js", HCL_CNODE_GET_TOKLEN(tmp), HCL_CNODE_GET_TOKPTR(tmp)); return -1; } - else if (!HCL_IS_CONS(hcl, obj)) + else if (!HCL_CNODE_IS_CONS(obj)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, "redundant cdr in return - %O", src); /* TODO: error location */ + hcl_cnode_t* tmp = HCL_CNODE_CONS_CAR(src); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in %.*js", HCL_CNODE_GET_TOKLEN(tmp), HCL_CNODE_GET_TOKPTR(tmp)); return -1; } - val = HCL_CONS_CAR(obj); + val = HCL_CNODE_CONS_CAR(obj); - obj = HCL_CONS_CDR(obj); - if (!HCL_IS_NIL(hcl, obj)) + obj = HCL_CNODE_CONS_CDR(obj); + if (obj) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, "more than 1 argument to return - %O", src); /* TODO: error location */ + hcl_cnode_t* tmp = HCL_CNODE_CONS_CAR(src); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "more than 1 argument to %.*js", HCL_CNODE_GET_TOKLEN(tmp), HCL_CNODE_GET_TOKPTR(tmp)); return -1; } @@ -1321,6 +1287,7 @@ static int compile_return (hcl_t* hcl, hcl_oop_t src, int mode) return 0; } +#if 0 static int compile_set (hcl_t* hcl, hcl_oop_t src) { hcl_cframe2_t* cf; @@ -1632,11 +1599,11 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) if (compile_break(hcl, obj) <= -1) return -1; break; -#if 0 case HCL_SYNCODE_DEFUN: if (compile_lambda(hcl, obj, 1) <= -1) return -1; break; +#if 0 case HCL_SYNCODE_DO: if (compile_do(hcl, obj) <= -1) return -1; break; @@ -1668,6 +1635,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) * (set x (lambda (x y) (+ x y)) */ if (compile_set(hcl, obj) <= -1) return -1; break; +#endif case HCL_SYNCODE_RETURN: /* (return 10) @@ -1675,10 +1643,12 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) if (compile_return(hcl, obj, 0) <= -1) return -1; break; + case HCL_SYNCODE_RETURN_FROM_HOME: if (compile_return(hcl, obj, 1) <= -1) return -1; break; +#if 0 case HCL_SYNCODE_UNTIL: if (compile_while(hcl, obj, COP_POST_UNTIL_COND) <= -1) return -1; break; @@ -1786,10 +1756,9 @@ static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_cnode_t* obj) HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL(obj)); - if (hcl_getsyncodebyoocs_noseterr(hcl, HCL_CNODE_GET_TOK(obj)) > 0) + if (HCL_CNODE_SYMBOL_SYNCODE(obj)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_CNODE_GET_LOC(obj), HCL_NULL, - "special symbol not to be used as a variable name - %.*js", HCL_CNODE_GET_TOKLEN(obj), HCL_CNODE_GET_TOKPTR(obj)); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "special symbol not to be used as a variable name - %.*js"); return -1; } @@ -2950,7 +2919,8 @@ static HCL_INLINE int emit_lambda (hcl_t* hcl) lfsize = hcl->code.lit.len - hcl->c->blk.info[hcl->c->blk.depth].lfbase; hcl->c->blk.depth--; - hcl->c->tv.size = hcl->c->blk.info[hcl->c->blk.depth].tmprcnt; + hcl->c->tv2.s.len = hcl->c->blk.info[hcl->c->blk.depth].tmprlen; + hcl->c->tv2.wcount = hcl->c->blk.info[hcl->c->blk.depth].tmprcnt; /* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD instruction */ block_code_size = hcl->code.bc.len - jip - (HCL_HCL_CODE_LONG_PARAM_SIZE + 1); @@ -2988,7 +2958,7 @@ static HCL_INLINE int emit_pop_stacktop (hcl_t* hcl) cf = GET_TOP_CFRAME(hcl); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_STACKTOP); - HCL_ASSERT (hcl, HCL_IS_NIL(hcl, cf->operand)); + HCL_ASSERT (hcl, cf->operand == HCL_NULL); n = emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_NULL); @@ -3021,15 +2991,17 @@ static HCL_INLINE int emit_set (hcl_t* hcl) if (cf->u.set.var_type == VAR_NAMED) { hcl_oow_t index; - hcl_oop_t cons; + hcl_oop_t cons, sym; HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL(cf->operand)); -/* TODO: make a symbol now */ - cons = (hcl_oop_t)hcl_getatsysdic(hcl, cf->operand); + sym = hcl_makesymbol(hcl, HCL_CNODE_GET_TOKPTR(cf->operand), HCL_CNODE_GET_TOKLEN(cf->operand)); + if (HCL_UNLIKELY(!sym)) return -1; + + cons = (hcl_oop_t)hcl_getatsysdic(hcl, sym); if (!cons) { - cons = (hcl_oop_t)hcl_putatsysdic(hcl, cf->operand, hcl->_nil); + cons = (hcl_oop_t)hcl_putatsysdic(hcl, sym, hcl->_nil); if (!cons) return -1; } @@ -3065,7 +3037,8 @@ int hcl_compile2 (hcl_t* hcl, hcl_cnode_t* obj) log_default_type_mask = hcl->log.default_type_mask; hcl->log.default_type_mask |= HCL_LOG_COMPILER; - HCL_ASSERT (hcl, hcl->c->tv.size == 0); + HCL_ASSERT (hcl, hcl->c->tv2.s.len == 0); + HCL_ASSERT (hcl, hcl->c->tv2.wcount == 0); HCL_ASSERT (hcl, hcl->c->blk.depth == -1); /* TODO: in case i implement all global variables as block arguments at the top level...what should i do? */ @@ -3102,7 +3075,7 @@ int hcl_compile2 (hcl_t* hcl, hcl_cnode_t* obj) * @0 (a) * @1 (set-a) */ - if (store_temporary_variable_count_for_block(hcl, hcl->c->tv.size, 0) <= -1) return -1; + if (store_temporary_variable_count_for_block(hcl, hcl->c->tv2.wcount, hcl->c->tv2.s.len, 0) <= -1) return -1; PUSH_CFRAME (hcl, COP_COMPILE_OBJECT, obj); @@ -3253,7 +3226,8 @@ int hcl_compile2 (hcl_t* hcl, hcl_cnode_t* obj) if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) goto oops; HCL_ASSERT (hcl, GET_TOP_CFRAME_INDEX(hcl) < 0); - HCL_ASSERT (hcl, hcl->c->tv.size == 0); + HCL_ASSERT (hcl, hcl->c->tv2.s.len == 0); + HCL_ASSERT (hcl, hcl->c->tv2.wcount == 0); HCL_ASSERT (hcl, hcl->c->blk.depth == 0); hcl->c->blk.depth--; @@ -3269,7 +3243,8 @@ oops: hcl->code.bc.len = saved_bc_len; hcl->code.lit.len = saved_lit_len; - hcl->c->tv.size = 0; + hcl->c->tv2.s.len = 0; + hcl->c->tv2.wcount = 0; hcl->c->blk.depth = -1; return -1; } diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 12a7107..b1fe224 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -349,6 +349,7 @@ typedef struct hcl_cframe2_t hcl_cframe2_t; struct hcl_blk_info_t { + hcl_oow_t tmprlen; hcl_oow_t tmprcnt; hcl_oow_t lfbase; }; @@ -365,14 +366,6 @@ struct hcl_rstl_t /* reader stack for list reading */ hcl_rstl_t* prev; }; - -typedef struct hcl_oocx_t hcl_oocx_t; -struct hcl_oocx_t -{ - hcl_oocs_t s; - hcl_oow_t capa; -}; - struct hcl_compiler_t { /* output handler */ @@ -455,7 +448,12 @@ struct hcl_compiler_t hcl_oow_t capa; } tv; /* temporary variables including arguments */ - hcl_oocx_t tv2; + struct + { + hcl_oocs_t s; /* buffer */ + hcl_oow_t capa; /* bufer capacity */ + hcl_oow_t wcount; /* word count */ + } tv2; struct { diff --git a/lib/read.c b/lib/read.c index bfb396d..24c65a8 100644 --- a/lib/read.c +++ b/lib/read.c @@ -2272,6 +2272,17 @@ static void fini_compiler (hcl_t* hcl) hcl->c->tv.capa = 0; } + if (hcl->c->tv2.s.ptr) + { + hcl_freemem (hcl, hcl->c->tv2.s.ptr); + hcl->c->tv2.s.ptr = HCL_NULL; + hcl->c->tv2.s.len = 0; + hcl->c->tv2.capa = 0; + hcl->c->tv2.wcount = 0; + } + HCL_ASSERT (hcl, hcl->c->tv2.capa == 0); + HCL_ASSERT (hcl, hcl->c->tv2.wcount == 0); + if (hcl->c->blk.info) { hcl_freemem (hcl, hcl->c->blk.info); diff --git a/lib/read2.c b/lib/read2.c index adf9d53..dc63f39 100644 --- a/lib/read2.c +++ b/lib/read2.c @@ -2127,6 +2127,15 @@ static void fini_compiler (hcl_t* hcl) hcl->c->tv.capa = 0; } + if (hcl->c->tv2.ptr) + { + hcl_freemem (hcl, hcl->c->tv2.ptr); + hcl->c->tv2.ptr = HCL_NULL; + hcl->c->tv2.len = 0; + hcl->c->tv2.capa = 0; + hcl->c->tv2.wcount = 0; + } + if (hcl->c->blk.info) { hcl_freemem (hcl, hcl->c->blk.info);