From 51e347889d998ebf87c606a3d23a69040632aa9b Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Fri, 22 Jan 2021 14:43:47 +0000 Subject: [PATCH] the new compiler is becoming usable. but not complete yet. added more string copy functions --- bin/main.c | 126 ++++++++++++++-------- lib/comp2.c | 285 +++++++++++++++++++++++++------------------------- lib/dic.c | 58 +++++++++- lib/err.c | 24 ++++- lib/hcl-prv.h | 3 + lib/hcl-s.c | 2 +- lib/hcl-utl.h | 66 ++++++++++++ lib/hcl.h | 16 ++- lib/obj.c | 2 +- lib/prim.c | 2 +- lib/print.c | 1 - lib/utl.c | 61 ++++++++++- 12 files changed, 447 insertions(+), 199 deletions(-) diff --git a/bin/main.c b/bin/main.c index df59fa2..687760c 100644 --- a/bin/main.c +++ b/bin/main.c @@ -945,7 +945,7 @@ static void print_synerr (hcl_t* hcl) if (synerr.tgt.len > 0) { - hcl_logbfmt (hcl, HCL_LOG_STDERR, " - %.*js", synerr.tgt.len, synerr.tgt.ptr); + hcl_logbfmt (hcl, HCL_LOG_STDERR, " - %.*js", synerr.tgt.len, synerr.tgt.val); } hcl_logbfmt (hcl, HCL_LOG_STDERR, "\n"); @@ -1173,44 +1173,51 @@ hcl_logufmt (hcl, HCL_LOG_WARN, fmt, ustr, 0x6789); } #endif - - #if 1 -//////////////////////////// -{ -hcl_cnode_t* xx; -while (1) -{ - xx = hcl_read2(hcl); - if (!xx) + while (1) { - if (hcl->errnum == HCL_EFINIS) - { - /* end of input */ - break; - } - else if (hcl->errnum == HCL_ESYNERR) - { - print_synerr (hcl); - if (xtn->reader_istty && hcl_getsynerrnum(hcl) != HCL_SYNERR_EOF) - { - /* TODO: drain remaining data in the reader including the actual inputstream and buffered data in hcl */ - } - continue; - } - else - { - hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot read object - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); - } - goto oops; - } - else - { - hcl_logbfmt (hcl, HCL_LOG_STDERR, "OK: got cnode - %p\n", xx); + hcl_cnode_t* obj; + int n; - if (hcl_compile2(hcl, xx) <= -1) + obj = hcl_read2(hcl); + if (!obj) + { + if (hcl->errnum == HCL_EFINIS) + { + /* end of input */ + break; + } + else if (hcl->errnum == HCL_ESYNERR) + { + print_synerr (hcl); + if (xtn->reader_istty && hcl_getsynerrnum(hcl) != HCL_SYNERR_EOF) + { + /* TODO: drain remaining data in the reader including the actual inputstream and buffered data in hcl */ + continue; + } + } + else + { + hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot read object - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); + } + goto oops; + } + + if (xtn->reader_istty) + { + /* clear the byte code buffer */ + /* TODO: create a proper function for this and call it */ + hcl->code.bc.len = 0; + hcl->code.lit.len = 0; + } + + if (verbose) hcl_prbfmt (hcl, "\n"); /* flush the output buffer by hcl_print above */ + + n = hcl_compile2(hcl, obj); + hcl_freecnode (hcl, obj); /* not needed any more */ + + if (n <= -1) { - hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERR: unable to compile - %p\n", xx); if (hcl->errnum == HCL_ESYNERR) { print_synerr (hcl); @@ -1219,19 +1226,50 @@ while (1) { hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot compile object - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); } + /* carry on? */ + + if (!xtn->reader_istty) goto oops; } - else + else if (xtn->reader_istty) { + /* interactive mode */ + hcl_oop_t retv; + hcl_decode (hcl, 0, hcl_getbclen(hcl)); + HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n"); + g_hcl = hcl; + //setup_tick (); + + retv = hcl_execute(hcl); + + /* flush pending output data in the interactive mode(e.g. printf without a newline) */ + hcl_flushio (hcl); + + if (!retv) + { + hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot execute - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); + } + else + { + /* print the result in the interactive mode regardless 'verbose' */ + hcl_logbfmt (hcl, HCL_LOG_STDOUT, "%O\n", retv); + + /* + * print the value of ERRSTR. + hcl_oop_cons_t cons = hcl_getatsysdic(hcl, xtn->sym_errstr); + if (cons) + { + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, cons)); + HCL_ASSERT (hcl, HCL_CONS_CAR(cons) == xtn->sym_errstr); + hcl_print (hcl, HCL_CONS_CDR(cons)); + } + */ + } + //cancel_tick(); + g_hcl = HCL_NULL; } - - hcl_freecnode (hcl, xx); } -} - -} -//////////////////////////// -#endif +#else while (1) { @@ -1273,6 +1311,7 @@ count++; { if (xtn->reader_istty) { + /* clear the byte code buffer */ /* TODO: create a proper function for this and call it */ hcl->code.bc.len = 0; hcl->code.lit.len = 0; @@ -1334,6 +1373,7 @@ count++; } } } +#endif if (!xtn->reader_istty && hcl_getbclen(hcl) > 0) { diff --git a/lib/comp2.c b/lib/comp2.c index 1280d2b..61b6ba5 100644 --- a/lib/comp2.c +++ b/lib/comp2.c @@ -937,47 +937,46 @@ static int compile_break (hcl_t* hcl, hcl_cnode_t* src) return -1; } -#if 0 -static int compile_if (hcl_t* hcl, hcl_oop_t src) +static int compile_if (hcl_t* hcl, hcl_cnode_t* src) { - hcl_oop_t obj, cond; + hcl_cnode_t* cmd, * obj, * cond; hcl_cframe2_t* cf; - HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); - HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_if); + HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_IF)); /* (if (< 20 30) - * (do this) - * (do that) + * (perform this) + * (perform that) * elif (< 20 30) - * (do it) + * (perform it) * else - * (do this finally) + * (perform this finally) * ) */ - obj = HCL_CONS_CDR(src); + cmd = HCL_CNODE_CONS_CAR(src); + obj = HCL_CNODE_CONS_CDR(src); - if (HCL_IS_NIL(hcl, obj)) + if (!obj) { /* no value */ - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, - "no condition specified in if - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(src), HCL_NULL, "no condition specified in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); 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 if - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } - cond = HCL_CONS_CAR(obj); - obj = HCL_CONS_CDR(obj); + cond = HCL_CNODE_CONS_CAR(obj); + obj = HCL_CNODE_CONS_CDR(obj); SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, cond); /* 1 */ PUSH_SUBCFRAME (hcl, COP_POST_IF_COND, obj); /* 2 */ cf = GET_SUBCFRAME (hcl); cf->u.post_if.body_pos = -1; /* unknown yet */ + cf->u.post_if.start_loc = *HCL_CNODE_GET_LOC(src); /* TODO: OPTIMIZATION: * pass information on the conditional if it's an absoluate true or absolute false to * eliminate some code .. i can't eliminate code because there can be else or elif... @@ -986,46 +985,47 @@ static int compile_if (hcl_t* hcl, hcl_oop_t src) */ return 0; } -#endif static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun) { - hcl_cnode_t* obj, * args; + hcl_cnode_t* cmd, * obj, * args; hcl_oow_t nargs, ntmprs; hcl_ooi_t jump_inst_pos, lfbase_pos, lfsize_pos; hcl_oow_t saved_tv_wcount, tv_dup_start; hcl_cnode_t* defun_name; + hcl_cframe2_t* cf; HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); saved_tv_wcount = hcl->c->tv2.wcount; + cmd = HCL_CNODE_CONS_CAR(src); obj = HCL_CNODE_CONS_CDR(src); if (defun) { - HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_DEFUN)); + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_DEFUN)); if (!obj) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(src), HCL_NULL, "no defun name"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(src), HCL_NULL, "no name in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } else if (!HCL_CNODE_IS_CONS(obj)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in defun"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } defun_name = HCL_CNODE_CONS_CAR(obj); if (!HCL_CNODE_IS_SYMBOL(defun_name)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_CNODE_GET_LOC(defun_name), HCL_CNODE_GET_TOK(defun_name), "defun name not a symbol"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_CNODE_GET_LOC(defun_name), HCL_CNODE_GET_TOK(defun_name), "name not a symbol in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } if (HCL_CNODE_SYMBOL_SYNCODE(defun_name)) /*|| HCL_OBJ_GET_FLAGS_KERNEL(defun_name) >= 1) */ { - 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"); + 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 defun name"); return -1; } @@ -1033,17 +1033,17 @@ static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun) } else { - HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_lambda); + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_LAMBDA)); } if (!obj) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(src), HCL_NULL, "no argument list in lambda"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(src), HCL_NULL, "no argument list in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } else if (!HCL_CNODE_IS_CONS(obj)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in lambda"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in argument list in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } @@ -1059,7 +1059,7 @@ static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun) if (!HCL_CNODE_IS_CONS(args)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(args), HCL_CNODE_GET_TOK(args), "not a lambda argument list"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(args), HCL_CNODE_GET_TOK(args), "not an argument list in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } @@ -1071,13 +1071,13 @@ static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun) arg = HCL_CNODE_CONS_CAR(dcl); if (!HCL_CNODE_IS_SYMBOL(arg)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAME, HCL_CNODE_GET_LOC(arg), HCL_CNODE_GET_TOK(arg), "lambda argument not a symbol"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAME, HCL_CNODE_GET_LOC(arg), HCL_CNODE_GET_TOK(arg), "argument not a symbol in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } 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_CNODE_GET_LOC(arg), HCL_CNODE_GET_TOK(arg), "special symbol not to be declared as an argument"); + 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 in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } @@ -1085,7 +1085,7 @@ static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun) { if (hcl->errnum == HCL_EEXIST) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMEDUP, HCL_CNODE_GET_LOC(arg), HCL_CNODE_GET_TOK(arg), "lambda argument duplicate"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMEDUP, HCL_CNODE_GET_LOC(arg), HCL_CNODE_GET_TOK(arg), "argument duplicate in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); } return -1; } @@ -1096,7 +1096,7 @@ static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun) 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 lambda argument list"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(dcl), HCL_CNODE_GET_TOK(dcl), "redundant cdr in argument list in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } } @@ -1110,7 +1110,7 @@ static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun) * 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_CNODE_GET_LOC(args), HCL_NULL, "too many(%zu) arguments", nargs); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(args), HCL_NULL, "too many(%zu) arguments in %.*js", nargs, HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } @@ -1176,13 +1176,13 @@ static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun) 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); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARFLOOD, HCL_CNODE_GET_LOC(args), HCL_NULL, "too many(%zu) variables in %.*js", ntmprs, HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } if (hcl->c->blk.depth == HCL_TYPE_MAX(hcl_ooi_t)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLKDEPTH, HCL_NULL, HCL_NULL, "lambda block depth too deep - %O", src); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLKDEPTH, HCL_CNODE_GET_LOC(src), HCL_NULL, "lambda block depth too deep in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } hcl->c->blk.depth++; @@ -1235,10 +1235,11 @@ static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun) PUSH_SUBCFRAME (hcl, COP_EMIT_LAMBDA, HCL_SMOOI_TO_OOP(jump_inst_pos)); + cf = GET_SUBCFRAME (hcl); + cf->u.lambda.start_loc = *HCL_CNODE_GET_LOC(src); + if (hcl->option.trait & HCL_TRAIT_INTERACTIVE) { - hcl_cframe2_t* cf; - cf = GET_SUBCFRAME (hcl); cf->u.lambda.lfbase_pos = lfbase_pos; cf->u.lambda.lfsize_pos = lfsize_pos; } @@ -1276,7 +1277,7 @@ static int compile_return (hcl_t* hcl, hcl_cnode_t* src, int mode) if (obj) { 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)); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "more than 1 argument in %.*js", HCL_CNODE_GET_TOKLEN(tmp), HCL_CNODE_GET_TOKPTR(tmp)); return -1; } @@ -1287,66 +1288,66 @@ static int compile_return (hcl_t* hcl, hcl_cnode_t* src, int mode) return 0; } -#if 0 -static int compile_set (hcl_t* hcl, hcl_oop_t src) +static int compile_set (hcl_t* hcl, hcl_cnode_t* src) { hcl_cframe2_t* cf; - hcl_oop_t obj, var, val; + hcl_cnode_t* cmd, * obj, * var, * val; hcl_oow_t index; - HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); - HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_set); + HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_SET)); - obj = HCL_CONS_CDR(src); + cmd = HCL_CNODE_CONS_CAR(src); + obj = HCL_CNODE_CONS_CDR(src); - if (HCL_IS_NIL(hcl, obj)) + if (!obj) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_NULL, HCL_NULL, "no variable name in set - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_CNODE_GET_LOC(src), HCL_NULL, "no variable name in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); 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 set - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } - var = HCL_CONS_CAR(obj); - if (!HCL_IS_SYMBOL(hcl, var)) + var = HCL_CNODE_CONS_CAR(obj); + if (!HCL_CNODE_IS_SYMBOL(var)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_NULL, HCL_NULL, "variable name not a symbol - %O", var); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "variable name not a symbol in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } - if (HCL_OBJ_GET_FLAGS_SYNCODE(var) || HCL_OBJ_GET_FLAGS_KERNEL(var) >= 2) + if (HCL_CNODE_SYMBOL_SYNCODE(var)/* || HCL_OBJ_GET_FLAGS_KERNEL(var) >= 2*/) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL, "special symbol not to be used as a variable name - %O", var); /* TOOD: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "special symbol not to be used as a variable name in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } - 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, "no value specified in set - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(src), HCL_NULL, "no value specified in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); 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 set - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); 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, "too many arguments to set - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "too many arguments to %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, val); - if (find_temporary_variable_backward(hcl, var, &index) <= -1) + if (find_temporary_variable_backward(hcl, HCL_CNODE_GET_TOK(var), &index) <= -1) { PUSH_SUBCFRAME (hcl, COP_EMIT_SET, var); /* set doesn't evaluate the variable name */ cf = GET_SUBCFRAME(hcl); @@ -1365,9 +1366,10 @@ static int compile_set (hcl_t* hcl, hcl_oop_t src) return 0; } -static int compile_do (hcl_t* hcl, hcl_oop_t src) + +static int compile_do (hcl_t* hcl, hcl_cnode_t* src) { - hcl_oop_t obj; + hcl_cnode_t* cmd, * obj; /* (do * (+ 10 20) @@ -1377,21 +1379,21 @@ static int compile_do (hcl_t* hcl, hcl_oop_t src) * you can use this to combine multiple expressions to a single expression */ - HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_do); + HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_DO)); - obj = HCL_CONS_CDR(src); + cmd = HCL_CNODE_CONS_CDR(src); + obj = HCL_CNODE_CONS_CDR(src); - if (HCL_IS_NIL(hcl, obj)) + if (!obj) { /* no value */ - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, - "no expression specified in do - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(src), HCL_NULL, "no expression specified in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); 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 do - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } @@ -1399,50 +1401,49 @@ static int compile_do (hcl_t* hcl, hcl_oop_t src) return 0; } - -static int compile_while (hcl_t* hcl, hcl_oop_t src, int next_cop) +static int compile_while (hcl_t* hcl, hcl_cnode_t* src, int next_cop) { /* (while (xxxx) ... ) * (until (xxxx) ... ) */ - hcl_oop_t obj, cond; + hcl_cnode_t* cmd, * obj, * cond; hcl_oow_t cond_pos; hcl_cframe2_t* cf; - HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); - HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_until || HCL_CONS_CAR(src) == hcl->_while); + HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_UNTIL) || + HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_WHILE)); HCL_ASSERT (hcl, next_cop == COP_POST_UNTIL_COND || next_cop == COP_POST_WHILE_COND); - obj = HCL_CONS_CDR(src); + cmd = HCL_CNODE_CONS_CAR(src); + obj = HCL_CNODE_CONS_CDR(src); - if (HCL_IS_NIL(hcl, obj)) + if (!obj) { /* no value */ - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, - "no loop condition specified - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(src), HCL_NULL, "no loop condition specified in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); 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 loop - %O", src); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in %*.js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); cond_pos = hcl->code.bc.len; /* position where the bytecode for the conditional is emitted */ - cond = HCL_CONS_CAR(obj); - obj = HCL_CONS_CDR(obj); + cond = HCL_CNODE_CONS_CAR(obj); + obj = HCL_CNODE_CONS_CDR(obj); SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, cond); /* 1 */ PUSH_SUBCFRAME (hcl, next_cop, obj); /* 2 */ cf = GET_SUBCFRAME (hcl); cf->u.post_while.cond_pos = cond_pos; cf->u.post_while.body_pos = -1; /* unknown yet*/ + cf->u.post_while.start_loc = *HCL_CNODE_GET_LOC(src); return 0; } -#endif /* ========================================================================= */ static int compile_cons_array_expression (hcl_t* hcl, hcl_cnode_t* obj) @@ -1458,8 +1459,7 @@ static int compile_cons_array_expression (hcl_t* hcl, hcl_cnode_t* obj) nargs = hcl_countcnodecons(hcl, obj); if (nargs > MAX_CODE_PARAM) { - /* TODO: change to syntax error */ - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(obj), HCL_NULL, "too many(%zd) elements into array", nargs); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(obj), HCL_NULL, "too many(%zd) elements in array", nargs); return -1; } @@ -1489,8 +1489,7 @@ static int compile_cons_bytearray_expression (hcl_t* hcl, hcl_cnode_t* obj) nargs = hcl_countcnodecons(hcl, obj); if (nargs > MAX_CODE_PARAM) { - /* TODO: change to syntax error */ - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(obj), HCL_NULL, "too many(%zd) elements into byte-array", nargs); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(obj), HCL_NULL, "too many(%zd) elements in byte-array", nargs); return -1; } @@ -1518,8 +1517,7 @@ static int compile_cons_dic_expression (hcl_t* hcl, hcl_cnode_t* obj) nargs = hcl_countcnodecons(hcl, obj); if (nargs > MAX_CODE_PARAM) { - /* TODO: change to syntax error */ - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(obj), HCL_NULL, "too many(%zd) elements into dictionary", nargs); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(obj), HCL_NULL, "too many(%zd) elements in dictionary", nargs); return -1; } @@ -1551,8 +1549,7 @@ static int compile_cons_qlist_expression (hcl_t* hcl, hcl_cnode_t* obj) nargs = hcl_countcnodecons(hcl, obj); if (nargs > MAX_CODE_PARAM) { - /* TODO: change to syntax error */ - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_NULL, HCL_NULL, "too many(%zd) elements into list - %O", nargs, obj); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(obj), HCL_NULL, "too many(%zd) elements", nargs); return -1; } @@ -1603,17 +1600,16 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) 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; case HCL_SYNCODE_ELSE: - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ELSE, HCL_NULL, HCL_NULL, "else without if - %O", obj); /* error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ELSE, HCL_CNODE_GET_LOC(car), HCL_CNODE_GET_TOK(car), "else without if"); return -1; case HCL_SYNCODE_ELIF: - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ELIF, HCL_NULL, HCL_NULL, "elif without if - %O", obj); /* error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ELIF, HCL_CNODE_GET_LOC(car), HCL_CNODE_GET_TOK(car), "elif without if"); return -1; case HCL_SYNCODE_IF: @@ -1624,18 +1620,16 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) /* (lambda (x y) (+ x y)) */ if (compile_lambda(hcl, obj, 0) <= -1) return -1; break; -#endif + case HCL_SYNCODE_OR: if (compile_or(hcl, obj) <= -1) return -1; break; -#if 0 case HCL_SYNCODE_SET: /* (set x 10) * (set x (lambda (x y) (+ x y)) */ if (compile_set(hcl, obj) <= -1) return -1; break; -#endif case HCL_SYNCODE_RETURN: /* (return 10) @@ -1643,12 +1637,10 @@ 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; @@ -1656,7 +1648,6 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) case HCL_SYNCODE_WHILE: if (compile_while(hcl, obj, COP_POST_WHILE_COND) <= -1) return -1; break; -#endif default: HCL_DEBUG3 (hcl, "Internal error - unknown syncode %d at %s:%d\n", syncode, __FILE__, __LINE__); @@ -1707,7 +1698,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) nargs = hcl_countcnodecons(hcl, cdr); if (nargs > MAX_CODE_PARAM) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_NULL, HCL_NULL, "too many(%zd) parameters in function call - %O", nargs, obj); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(cdr), HCL_NULL, "too many(%zd) parameters in function call", nargs); return -1; } } @@ -1716,7 +1707,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) { /* only symbols are added to the system dictionary. * perform this lookup only if car is a symbol */ - sdc = hcl_getatsysdic(hcl, car); + sdc = hcl_lookupsysdicforsymbol_noseterr(hcl, HCL_CNODE_GET_TOK(car)); if (sdc) { hcl_oop_word_t sdv; @@ -1725,8 +1716,8 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) { if (nargs < sdv->slot[1] || nargs > sdv->slot[2]) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, - "parameters count(%zd) mismatch in function call - %O - expecting %zu-%zu parameters", nargs, obj, sdv->slot[1], sdv->slot[2]); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(car), HCL_NULL, + "parameters count(%zd) mismatch in function call - %.*js - expecting %zu-%zu parameters", nargs, HCL_CNODE_GET_TOKLEN(car), HCL_CNODE_GET_TOKPTR(car), sdv->slot[1], sdv->slot[2]); return -1; } } @@ -1792,6 +1783,10 @@ static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_cnode_t* obj) } } +static HCL_INLINE int compile_dsymbol (hcl_t* hcl, hcl_cnode_t* obj) +{ +} + static hcl_oop_t string_to_num (hcl_t* hcl, hcl_oocs_t* str, const hcl_ioloc_t* loc, int radixed) { int negsign, base; @@ -1951,13 +1946,9 @@ static int compile_object (hcl_t* hcl) if (compile_symbol(hcl, oprnd) <= -1) return -1; goto done; -#if 0 - -// TODO: ... case HCL_CNODE_DSYMBOL: if (compile_dsymbol(hcl, oprnd) <= -1) return -1; goto done; -#endif case HCL_CNODE_CONS: { @@ -2343,7 +2334,7 @@ static int compile_qlist (hcl_t* hcl) /* ========================================================================= */ -static HCL_INLINE int patch_nearest_post_if_body (hcl_t* hcl) +static HCL_INLINE int patch_nearest_post_if_body (hcl_t* hcl, hcl_cnode_t* cmd) { hcl_ooi_t jump_inst_pos, body_pos; hcl_ooi_t jip, jump_offset; @@ -2374,8 +2365,7 @@ static HCL_INLINE int patch_nearest_post_if_body (hcl_t* hcl) if (jump_offset > MAX_CODE_JUMP * 2) { - HCL_DEBUG1 (hcl, "code in elif/else body too big - size %zu\n", jump_offset); - hcl_setsynerr (hcl, HCL_SYNERR_IFFLOOD, HCL_NULL, HCL_NULL); /* error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_IFFLOOD, HCL_CNODE_GET_LOC(cmd), HCL_NULL, "code in %.*js too big - size %zu", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd), jump_offset); return -1; } patch_long_jump (hcl, jip, jump_offset); @@ -2399,67 +2389,72 @@ static HCL_INLINE int patch_nearest_post_if_body (hcl_t* hcl) static HCL_INLINE int subcompile_elif (hcl_t* hcl) { - hcl_oop_t obj, cond, src; + hcl_cnode_t* cmd, * obj, * cond, * src; hcl_cframe2_t* cf; cf = GET_TOP_CFRAME(hcl); HCL_ASSERT (hcl, cf->opcode == COP_SUBCOMPILE_ELIF); src = cf->operand; - HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); - HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_elif); + HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_ELIF)); - obj = HCL_CONS_CDR(src); + cmd = HCL_CNODE_CONS_CAR(src); + obj = HCL_CNODE_CONS_CDR(src); - if (HCL_IS_NIL(hcl, obj)) + if (!obj) { /* no value */ - HCL_DEBUG1 (hcl, "Syntax error - no condition specified in elif - %O\n", src); - hcl_setsynerr (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(src), HCL_NULL, "no condition in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } - else if (!HCL_IS_CONS(hcl, obj)) + else if (!HCL_CNODE_IS_CONS(obj)) { - HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in elif - %O\n", src); - hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } - cond = HCL_CONS_CAR(obj); + cond = HCL_CNODE_CONS_CAR(obj); obj = HCL_CONS_CDR(obj); SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, cond); /* 1 */ PUSH_SUBCFRAME (hcl, COP_POST_IF_COND, obj); /* 2 */ cf = GET_SUBCFRAME (hcl); cf->u.post_if.body_pos = -1; /* unknown yet */ + cf->u.post_if.start_loc = *HCL_CNODE_GET_LOC(src); - return patch_nearest_post_if_body (hcl); + return patch_nearest_post_if_body(hcl, cmd); } static HCL_INLINE int subcompile_else (hcl_t* hcl) { - hcl_oop_t obj, src; + hcl_cnode_t* cmd, * obj, * src; hcl_cframe2_t* cf; cf = GET_TOP_CFRAME(hcl); HCL_ASSERT (hcl, cf->opcode == COP_SUBCOMPILE_ELSE); src = cf->operand; - HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); - HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_else); + HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_ELSE)); - obj = HCL_CONS_CDR(src); + cmd = HCL_CNODE_CONS_CAR(src); + obj = HCL_CNODE_CONS_CDR(src); - if (!HCL_IS_NIL(hcl, obj) && !HCL_IS_CONS(hcl, obj)) + if (!obj) { - HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in else - %O\n", src); - hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(src), HCL_NULL, "no condition in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); + return -1; + } + else if (!HCL_CNODE_IS_CONS(obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, obj); - return patch_nearest_post_if_body (hcl); + return patch_nearest_post_if_body(hcl, cmd); } /* ========================================================================= */ @@ -2611,7 +2606,7 @@ static HCL_INLINE int post_if_cond (hcl_t* hcl) if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_FORWARD_IF_FALSE, MAX_CODE_JUMP) <= -1) return -1; /* to drop the result of the conditional when it is true */ - if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1; + if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1; HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); body_pos = hcl->code.bc.len; @@ -2646,8 +2641,7 @@ static HCL_INLINE int post_if_body (hcl_t* hcl) if (jump_offset > MAX_CODE_JUMP * 2) { - HCL_DEBUG1 (hcl, "code in if-else body too big - size %zu\n", jump_offset); - hcl_setsynerr (hcl, HCL_SYNERR_IFFLOOD, HCL_NULL, HCL_NULL); /* error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_IFFLOOD, &cf->u.post_if.start_loc, HCL_NULL, "code too big - size %zu", jump_offset); return -1; } patch_long_jump (hcl, jip, jump_offset); @@ -2662,12 +2656,14 @@ static HCL_INLINE int post_while_cond (hcl_t* hcl) hcl_cframe2_t* cf; hcl_ooi_t jump_inst_pos; hcl_ooi_t cond_pos, body_pos; + hcl_ioloc_t start_loc; int jump_inst, next_cop; cf = GET_TOP_CFRAME(hcl); HCL_ASSERT (hcl, cf->opcode == COP_POST_UNTIL_COND || cf->opcode == COP_POST_WHILE_COND); cond_pos = cf->u.post_while.cond_pos; + start_loc = cf->u.post_while.start_loc; HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); jump_inst_pos = hcl->code.bc.len; @@ -2683,7 +2679,7 @@ static HCL_INLINE int post_while_cond (hcl_t* hcl) } if (emit_single_param_instruction (hcl, jump_inst, MAX_CODE_JUMP) <= -1) return -1; - if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1; + if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1; HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); body_pos = hcl->code.bc.len; @@ -2693,6 +2689,7 @@ static HCL_INLINE int post_while_cond (hcl_t* hcl) cf = GET_SUBCFRAME(hcl); cf->u.post_while.cond_pos = cond_pos; cf->u.post_while.body_pos = body_pos; + cf->u.post_while.start_loc = start_loc; return 0; } @@ -2731,8 +2728,7 @@ static HCL_INLINE int post_while_body (hcl_t* hcl) jump_offset = hcl->code.bc.len - jip - (HCL_HCL_CODE_LONG_PARAM_SIZE + 1); if (jump_offset > MAX_CODE_JUMP * 2) { - HCL_DEBUG1 (hcl, "code in loop body too big - size %zu\n", jump_offset); - hcl_setsynerr (hcl, HCL_SYNERR_BLKFLOOD, HCL_NULL, HCL_NULL); /* error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLKFLOOD, &cf->u.post_while.start_loc, HCL_NULL, "code too big - size %zu", jump_offset); return -1; } patch_long_jump (hcl, jip, jump_offset); @@ -2938,8 +2934,7 @@ static HCL_INLINE int emit_lambda (hcl_t* hcl) if (block_code_size > MAX_CODE_JUMP * 2) { - HCL_DEBUG1 (hcl, "Too big a lambda block - size %zu\n", block_code_size); - hcl_setsynerr (hcl, HCL_SYNERR_BLKFLOOD, HCL_NULL, HCL_NULL); /* error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLKFLOOD, &cf->u.lambda.start_loc, HCL_NULL, "code too big - size %zu", block_code_size); return -1; } patch_long_jump (hcl, jip, block_code_size); diff --git a/lib/dic.c b/lib/dic.c index 5ce9d6e..6b852e6 100644 --- a/lib/dic.c +++ b/lib/dic.c @@ -128,7 +128,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,ass->car)); if (HCL_OBJ_GET_SIZE(key) == HCL_OBJ_GET_SIZE(ass->car) && - hcl_equal_oochars(HCL_OBJ_GET_CHAR_SLOT(key), ((hcl_oop_char_t)ass->car)->slot, HCL_OBJ_GET_SIZE(key))) + hcl_equal_oochars(HCL_OBJ_GET_CHAR_SLOT(key), HCL_OBJ_GET_CHAR_SLOT(ass->car), HCL_OBJ_GET_SIZE(key))) { /* the value of HCL_NULL indicates no insertion or update. */ if (value) ass->cdr = value; /* update */ @@ -228,6 +228,52 @@ oops: return HCL_NULL; } +static hcl_oop_cons_t lookupdic_noseterr (hcl_t* hcl, hcl_oop_dic_t dic, const hcl_oocs_t* name) +{ + /* this is special version of hcl_getatsysdic() that performs + * lookup using a plain symbol specified */ + + hcl_oow_t index; + hcl_oop_cons_t ass; + + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(dic->tally)); + HCL_ASSERT (hcl, HCL_IS_ARRAY(hcl,dic->bucket)); + + index = hcl_hash_oochars(name->ptr, name->len) % HCL_OBJ_GET_SIZE(dic->bucket); + + while ((hcl_oop_t)(ass = (hcl_oop_cons_t)HCL_OBJ_GET_OOP_VAL(dic->bucket, index)) != hcl->_nil) + { + HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass)); + if (HCL_IS_SYMBOL(hcl, ass->car)) + { + if (name->len == HCL_OBJ_GET_SIZE(ass->car) && + hcl_equal_oochars(name->ptr, HCL_OBJ_GET_CHAR_SLOT(ass->car), name->len)) + { + return ass; + } + } + + index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket); + } + + + /* when value is HCL_NULL, perform no insertion */ + + /* hcl_seterrXXX() is not called here. the dictionary lookup is very frequent + * and so is lookup failure. for instance, hcl_findmethod() calls this over + * a class chain. there might be a failure at each class level. it's waste to + * set the error information whenever the failure occurs. + * the caller of this function must set the error information upon failure */ + return HCL_NULL; +} + +static HCL_INLINE hcl_oop_cons_t lookupdic (hcl_t* hcl, hcl_oop_dic_t dic, const hcl_oocs_t* name) +{ + hcl_oop_cons_t ass = lookupdic_noseterr(hcl, dic, name); + if (!ass) hcl_seterrbfmt(hcl, HCL_ENOENT, "unable to find %.*js in a dictionary", name->len, name->ptr); + return ass; +} + hcl_oop_cons_t hcl_putatsysdic (hcl_t* hcl, hcl_oop_t key, hcl_oop_t value) { #if defined(SYMBOL_ONLY_KEY) @@ -244,6 +290,16 @@ hcl_oop_cons_t hcl_getatsysdic (hcl_t* hcl, hcl_oop_t key) return find_or_upsert(hcl, hcl->sysdic, key, HCL_NULL); } +hcl_oop_cons_t hcl_lookupsysdicforsymbol_noseterr (hcl_t* hcl, const hcl_oocs_t* name) +{ + return lookupdic_noseterr(hcl, hcl->sysdic, name); +} + +hcl_oop_cons_t hcl_lookupsysdicforsymbol (hcl_t* hcl, const hcl_oocs_t* name) +{ + return lookupdic(hcl, hcl->sysdic, name); +} + int hcl_zapatsysdic (hcl_t* hcl, hcl_oop_t key) { #if defined(SYMBOL_ONLY_KEY) diff --git a/lib/err.c b/lib/err.c index 09e8bbf..b98c0ea 100644 --- a/lib/err.c +++ b/lib/err.c @@ -392,11 +392,19 @@ void hcl_setsynerrbfmt (hcl_t* hcl, hcl_synerrnum_t num, const hcl_ioloc_t* loc, if (tgt) { - hcl->c->synerr.tgt = *tgt; + hcl_oow_t n; + n = hcl_copy_oochars_to_oocstr(hcl->c->synerr.tgt.val, HCL_COUNTOF(hcl->c->synerr.tgt.val), tgt->ptr, tgt->len); + if (n < tgt->len) + { + hcl->c->synerr.tgt.val[n - 1] = '.'; + hcl->c->synerr.tgt.val[n - 2] = '.'; + hcl->c->synerr.tgt.val[n - 3] = '.'; + } + hcl->c->synerr.tgt.len = n; } else { - hcl->c->synerr.tgt.ptr = HCL_NULL; + hcl->c->synerr.tgt.val[0] = '\0'; hcl->c->synerr.tgt.len = 0; } } @@ -443,11 +451,19 @@ void hcl_setsynerrufmt (hcl_t* hcl, hcl_synerrnum_t num, const hcl_ioloc_t* loc, if (tgt) { - hcl->c->synerr.tgt = *tgt; + hcl_oow_t n; + n = hcl_copy_oochars_to_oocstr(hcl->c->synerr.tgt.val, HCL_COUNTOF(hcl->c->synerr.tgt.val), tgt->ptr, tgt->len); + if (n < tgt->len) + { + hcl->c->synerr.tgt.val[n - 1] = '.'; + hcl->c->synerr.tgt.val[n - 2] = '.'; + hcl->c->synerr.tgt.val[n - 3] = '.'; + } + hcl->c->synerr.tgt.len = n; } else { - hcl->c->synerr.tgt.ptr = HCL_NULL; + hcl->c->synerr.tgt.val[0] = '\0'; hcl->c->synerr.tgt.len = 0; } } diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index b1fe224..b3fb181 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -321,11 +321,13 @@ struct hcl_cframe2_t { hcl_ooi_t cond_pos; hcl_ooi_t body_pos; + hcl_ioloc_t start_loc; } post_while; struct { hcl_ooi_t body_pos; + hcl_ioloc_t start_loc; } post_if; struct @@ -340,6 +342,7 @@ struct hcl_cframe2_t struct { + hcl_ioloc_t start_loc; hcl_ooi_t lfbase_pos; hcl_ooi_t lfsize_pos; } lambda; diff --git a/lib/hcl-s.c b/lib/hcl-s.c index aed802a..fbca76f 100644 --- a/lib/hcl-s.c +++ b/lib/hcl-s.c @@ -1349,7 +1349,7 @@ static void reformat_synerr (hcl_t* hcl) "%js%s%.*js at line %zu column %zu", orgmsg, (synerr.tgt.len > 0? " near ": ""), - synerr.tgt.len, synerr.tgt.ptr, + synerr.tgt.len, synerr.tgt.val, synerr.loc.line, synerr.loc.colm ); } diff --git a/lib/hcl-utl.h b/lib/hcl-utl.h index fee469f..847803c 100644 --- a/lib/hcl-utl.h +++ b/lib/hcl-utl.h @@ -356,6 +356,8 @@ HCL_EXPORT int hcl_equal_bchars ( hcl_oow_t len ); +/* ------------------------------ */ + HCL_EXPORT int hcl_comp_uchars ( const hcl_uch_t* str1, hcl_oow_t len1, @@ -409,6 +411,8 @@ HCL_EXPORT int hcl_comp_bchars_ucstr ( const hcl_uch_t* str2 ); +/* ------------------------------ */ + HCL_EXPORT void hcl_copy_uchars ( hcl_uch_t* dst, const hcl_uch_t* src, @@ -427,6 +431,24 @@ HCL_EXPORT void hcl_copy_bchars_to_uchars ( hcl_oow_t len ); +HCL_EXPORT void hcl_copy_uchars_to_bchars ( + hcl_bch_t* dst, + const hcl_uch_t* src, + hcl_oow_t len +); + +HCL_EXPORT hcl_oow_t hcl_copy_uchars_to_ucstr_unlimited ( + hcl_uch_t* dst, + const hcl_uch_t* src, + hcl_oow_t len +); + +HCL_EXPORT hcl_oow_t hcl_copy_bchars_to_bcstr_unlimited ( + hcl_bch_t* dst, + const hcl_bch_t* src, + hcl_oow_t len +); + HCL_EXPORT hcl_oow_t hcl_copy_ucstr ( hcl_uch_t* dst, hcl_oow_t len, @@ -439,6 +461,32 @@ HCL_EXPORT hcl_oow_t hcl_copy_bcstr ( const hcl_bch_t* src ); +HCL_EXPORT hcl_oow_t hcl_copy_uchars_to_ucstr ( + hcl_uch_t* dst, + hcl_oow_t dlen, + const hcl_uch_t* src, + hcl_oow_t slen +); + +HCL_EXPORT hcl_oow_t hcl_copy_bchars_to_bcstr ( + hcl_bch_t* dst, + hcl_oow_t dlen, + const hcl_bch_t* src, + hcl_oow_t slen +); + +HCL_EXPORT hcl_oow_t hcl_copy_ucstr_unlimited ( + hcl_uch_t* dst, + const hcl_uch_t* src +); + +HCL_EXPORT hcl_oow_t hcl_copy_bcstr_unlimited ( + hcl_bch_t* dst, + const hcl_bch_t* src +); + +/* ------------------------------ */ + HCL_EXPORT void hcl_fill_uchars ( hcl_uch_t* dst, const hcl_uch_t ch, @@ -501,9 +549,18 @@ HCL_EXPORT hcl_oow_t hcl_count_bcstr ( # define hcl_comp_oochars_ucstr(str1,len1,str2) hcl_comp_uchars_ucstr(str1,len1,str2) # define hcl_comp_oochars_oocstr(str1,len1,str2) hcl_comp_uchars_ucstr(str1,len1,str2) # define hcl_comp_oocstr(str1,str2) hcl_comp_ucstr(str1,str2) + # define hcl_copy_oochars(dst,src,len) hcl_copy_uchars(dst,src,len) # define hcl_copy_bchars_to_oochars(dst,src,len) hcl_copy_bchars_to_uchars(dst,src,len) +# define hcl_copy_oochars_to_bchars(dst,src,len) hcl_copy_uchars_to_bchars(dst,src,len) +# define hcl_copy_uchars_to_oochars(dst,src,len) hcl_copy_uchars(dst,src,len) +# define hcl_copy_oochars_to_uchars(dst,src,len) hcl_copy_uchars(dst,src,len) + +# define hcl_copy_oochars_to_oocstr(dst,dlen,src,slen) hcl_copy_uchars_to_ucstr(dst,dlen,src,slen) +# define hcl_copy_oochars_to_oocstr_unlimited(dst,src,len) hcl_copy_uchars_to_ucstr_unlimited(dst,src,len) # define hcl_copy_oocstr(dst,len,src) hcl_copy_ucstr(dst,len,src) +# define hcl_copy_oocstr_unlimited(dst,src) hcl_copy_ucstr_unlimited(dst,src) + # define hcl_fill_oochars(dst,ch,len) hcl_fill_uchars(dst,ch,len) # define hcl_find_oochar(ptr,len,c) hcl_find_uchar(ptr,len,c) # define hcl_rfind_oochar(ptr,len,c) hcl_rfind_uchar(ptr,len,c) @@ -517,9 +574,18 @@ HCL_EXPORT hcl_oow_t hcl_count_bcstr ( # define hcl_comp_oochars_ucstr(str1,len1,str2) hcl_comp_bchars_ucstr(str1,len1,str2) # define hcl_comp_oochars_oocstr(str1,len1,str2) hcl_comp_bchars_bcstr(str1,len1,str2) # define hcl_comp_oocstr(str1,str2) hcl_comp_bcstr(str1,str2) + # define hcl_copy_oochars(dst,src,len) hcl_copy_bchars(dst,src,len) # define hcl_copy_bchars_to_oochars(dst,src,len) hcl_copy_bchars(dst,src,len) +# define hcl_copy_oochars_to_bchars(dst,src,len) hcl_copy_bchars(dst,src,len) +# define hcl_copy_uchars_to_oochars(dst,src,len) hcl_copy_uchars_to_bchars(dst,src,len) +# define hcl_copy_oochars_to_uchars(dst,src,len) hcl_copy_bchars_to_uchars(dst,src,len) + +# define hcl_copy_oochars_to_oocstr(dst,dlen,src,slen) hcl_copy_bchars_to_bcstr(dst,dlen,src,slen) +# define hcl_copy_oochars_to_oocstr_unlimited(dst,src,len) hcl_copy_bchars_to_bcstr_unlimited(dst,src,len) # define hcl_copy_oocstr(dst,len,src) hcl_copy_bcstr(dst,len,src) +# define hcl_copy_oocstr_unlimited(dst,src) hcl_copy_bcstr_unlimited(dst,src) + # define hcl_fill_oochars(dst,ch,len) hcl_fill_bchars(dst,ch,len) # define hcl_find_oochar(ptr,len,c) hcl_find_bchar(ptr,len,c) # define hcl_rfind_oochar(ptr,len,c) hcl_rfind_bchar(ptr,len,c) diff --git a/lib/hcl.h b/lib/hcl.h index 95e0b6b..31a3bff 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -1365,7 +1365,11 @@ struct hcl_synerr_t { hcl_synerrnum_t num; hcl_ioloc_t loc; - hcl_oocs_t tgt; + struct + { + hcl_ooch_t val[256]; + hcl_oow_t len; + } tgt; }; #if defined(HCL_INCLUDE_COMPILER) @@ -2419,6 +2423,16 @@ HCL_EXPORT hcl_oop_cons_t hcl_getatsysdic ( hcl_oop_t key ); +hcl_oop_cons_t hcl_lookupsysdicforsymbol ( + hcl_t* hcl, + const hcl_oocs_t* name +); + +hcl_oop_cons_t hcl_lookupsysdicforsymbol_noseterr ( + hcl_t* hcl, + const hcl_oocs_t* name +); + HCL_EXPORT int hcl_zapatsysdic ( hcl_t* hcl, hcl_oop_t key diff --git a/lib/obj.c b/lib/obj.c index bd16628..a0b27ce 100644 --- a/lib/obj.c +++ b/lib/obj.c @@ -543,7 +543,7 @@ int hcl_hashobj (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t* xhv) break; case HCL_OBJ_TYPE_CHAR: - hv = hcl_hash_oochars (((hcl_oop_char_t)obj)->slot, HCL_OBJ_GET_SIZE(obj)); + hv = hcl_hash_oochars(((hcl_oop_char_t)obj)->slot, HCL_OBJ_GET_SIZE(obj)); break; case HCL_OBJ_TYPE_HALFWORD: diff --git a/lib/prim.c b/lib/prim.c index bbd8b5c..a2297d2 100644 --- a/lib/prim.c +++ b/lib/prim.c @@ -798,7 +798,7 @@ static pf_t builtin_prims[] = { 2, 2, pf_nql, 4, { 'n','q','l','?' } }, { 2, 2, pf_nqk, 4, { 'n','q','k','?' } }, - { 1, 1, pf_is_null, 4, { 'n','u','l','l','?' } }, + { 1, 1, pf_is_null, 5, { 'n','u','l','l','?' } }, { 1, 1, pf_is_boolean, 8, { 'b','o','o','l','e','a','n','?' } }, { 1, 1, pf_is_character, 10, { 'c','h','a','r','a','c','t','e','r','?' } }, { 1, 1, pf_is_error, 6, { 'e','r','r','o','r','?' } }, diff --git a/lib/print.c b/lib/print.c index b79f426..f2fb1ab 100644 --- a/lib/print.c +++ b/lib/print.c @@ -106,7 +106,6 @@ static struct { 5, { 'f', 'a', 'l', 's', 'e' } }, { 6, { '#','<','S','E','T','>' } }, - { 9, { '#','<','C','F','R','A','M','E','>' } }, { 7, { '#','<','P','R','I','M','>' } }, { 11, { '#','<','F','U','N','C','T','I','O','N','>' } }, diff --git a/lib/utl.c b/lib/utl.c index b0c816c..f72e5d8 100644 --- a/lib/utl.c +++ b/lib/utl.c @@ -216,11 +216,55 @@ void hcl_copy_bchars (hcl_bch_t* dst, const hcl_bch_t* src, hcl_oow_t len) void hcl_copy_bchars_to_uchars (hcl_uch_t* dst, const hcl_bch_t* src, hcl_oow_t len) { /* copy without conversions. - * use hcl_bctouchars() for conversion encoding */ + * use hcl_convbtouchars() for conversion encoding */ hcl_oow_t i; for (i = 0; i < len; i++) dst[i] = src[i]; } +void hcl_copy_uchars_to_bchars (hcl_bch_t* dst, const hcl_uch_t* src, hcl_oow_t len) +{ + /* copy without conversions. + * use hcl_convutobchars() for conversion encoding */ + hcl_oow_t i; + for (i = 0; i < len; i++) dst[i] = src[i]; +} + +hcl_oow_t hcl_copy_uchars_to_ucstr (hcl_uch_t* dst, hcl_oow_t dlen, const hcl_uch_t* src, hcl_oow_t slen) +{ + hcl_oow_t i; + if (dlen <= 0) return 0; + if (dlen <= slen) slen = dlen - 1; + for (i = 0; i < slen; i++) dst[i] = src[i]; + dst[i] = '\0'; + return i; +} + +hcl_oow_t hcl_copy_bchars_to_bcstr (hcl_bch_t* dst, hcl_oow_t dlen, const hcl_bch_t* src, hcl_oow_t slen) +{ + hcl_oow_t i; + if (dlen <= 0) return 0; + if (dlen <= slen) slen = dlen - 1; + for (i = 0; i < slen; i++) dst[i] = src[i]; + dst[i] = '\0'; + return i; +} + +hcl_oow_t hcl_copy_uchars_to_ucstr_unlimited (hcl_uch_t* dst, const hcl_uch_t* src, hcl_oow_t len) +{ + hcl_oow_t i; + for (i = 0; i < len; i++) dst[i] = src[i]; + dst[i] = '\0'; + return i; +} + +hcl_oow_t hcl_copy_bchars_to_bcstr_unlimited (hcl_bch_t* dst, const hcl_bch_t* src, hcl_oow_t len) +{ + hcl_oow_t i; + for (i = 0; i < len; i++) dst[i] = src[i]; + dst[i] = '\0'; + return i; +} + hcl_oow_t hcl_copy_ucstr (hcl_uch_t* dst, hcl_oow_t len, const hcl_uch_t* src) { hcl_uch_t* p, * p2; @@ -253,6 +297,21 @@ hcl_oow_t hcl_copy_bcstr (hcl_bch_t* dst, hcl_oow_t len, const hcl_bch_t* src) return p - dst; } + +hcl_oow_t hcl_copy_ucstr_unlimited (hcl_uch_t* dst, const hcl_uch_t* src) +{ + hcl_uch_t* org = dst; + while ((*dst++ = *src++) != '\0'); + return dst - org - 1; +} + +hcl_oow_t hcl_copy_bcstr_unlimited (hcl_bch_t* dst, const hcl_bch_t* src) +{ + hcl_bch_t* org = dst; + while ((*dst++ = *src++) != '\0'); + return dst - org - 1; +} + void hcl_fill_uchars (hcl_uch_t* dst, hcl_uch_t ch, hcl_oow_t len) { hcl_oow_t i;