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

touched up code. added eqv? eql? not

Browse Source
This commit is contained in:
hyung-hwan
2018-02-08 07:40:27 +00:00
parent a8729532bb
commit 9270dfa0e7
7 changed files with 184 additions and 90 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
hcl/lib/comp.c
View File

@ -991,44 +991,37 @@ static int compile_set (hcl_t* hcl, hcl_oop_t src)
if (HCL_IS_NIL(hcl, obj))
{
HCL_DEBUG1 (hcl, "Syntax error - no variable name in set - %O\n", src);
hcl_setsynerr (hcl, HCL_SYNERR_VARNAME, HCL_NULL, HCL_NULL); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_NULL, HCL_NULL, "no variable name in set - %O", src); /* TODO: error location */
return -1;
}
else if (!HCL_IS_CONS(hcl, obj))
{
HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in set - %O\n", src);
hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, "redundant cdr in set - %O", src); /* TODO: error location */
return -1;
}
var = HCL_CONS_CAR(obj);
if (HCL_BRANDOF(hcl, var) != HCL_BRAND_SYMBOL)
{
HCL_DEBUG1 (hcl, "Syntax error - variable name not a symbol - %O\n", var);
hcl_setsynerr (hcl, HCL_SYNERR_VARNAME, HCL_NULL, HCL_NULL); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_NULL, HCL_NULL, "variable name not a symbol - %O", var); /* TODO: error location */
return -1;
}
if (HCL_OBJ_GET_FLAGS_SYNCODE(var))
{
HCL_DEBUG1 (hcl, "Syntax error - special symbol not to be used as a variable name - %O\n", var);
hcl_setsynerr (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL); /* TOOD: error location */
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 */
return -1;
}
obj = HCL_CONS_CDR(obj);
if (HCL_IS_NIL(hcl, obj))
{
/* no value */
HCL_DEBUG1 (hcl, "Syntax error - no value specified in set - %O\n", src);
hcl_setsynerr (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, "no value specified in set - %O", src); /* TODO: error location */
return -1;
}
else if (!HCL_IS_CONS(hcl, obj))
{
HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in set - %O\n", src);
hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, "redundant cdr in set - %O", src); /* TODO: error location */
return -1;
}
@ -1037,8 +1030,7 @@ static int compile_set (hcl_t* hcl, hcl_oop_t src)
obj = HCL_CONS_CDR(obj);
if (!HCL_IS_NIL(hcl, obj))
{
HCL_DEBUG1 (hcl, "Synatx error - too many arguments to set - %O\n", src);
hcl_setsynerr (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, "too many arguments to set - %O", src); /* TODO: error location */
return -1;
}

31
hcl/lib/err.c
View File

@ -314,16 +314,25 @@ void hcl_getsynerr (hcl_t* hcl, hcl_synerr_t* synerr)
void hcl_setsynerrbfmt (hcl_t* hcl, hcl_synerrnum_t num, const hcl_ioloc_t* loc, const hcl_oocs_t* tgt, const hcl_bch_t* msgfmt, ...)
{
static hcl_bch_t syntax_error[] = "syntax error - ";
if (msgfmt)
{
va_list ap;
int i, selen;
va_start (ap, msgfmt);
hcl_seterrbfmtv (hcl, HCL_ESYNERR, msgfmt, ap);
va_end (ap);
selen = HCL_COUNTOF(syntax_error) - 1;
HCL_MEMMOVE (&hcl->errmsg.buf[selen], &hcl->errmsg.buf[0], HCL_SIZEOF(hcl->errmsg.buf[0]) * (HCL_COUNTOF(hcl->errmsg.buf) - selen));
for (i = 0; i < selen; i++) hcl->errmsg.buf[i] = syntax_error[i];
hcl->errmsg.buf[HCL_COUNTOF(hcl->errmsg.buf) - 1] = '\0';
}
else
{
hcl_seterrbfmt (hcl, HCL_ESYNERR, "syntax error - %hs", synerr_to_errstr(num));
hcl_seterrbfmt (hcl, HCL_ESYNERR, "%hs%hs", syntax_error, synerr_to_errstr(num));
}
hcl->c->synerr.num = num;
@ -354,16 +363,25 @@ void hcl_setsynerrbfmt (hcl_t* hcl, hcl_synerrnum_t num, const hcl_ioloc_t* loc,
void hcl_setsynerrufmt (hcl_t* hcl, hcl_synerrnum_t num, const hcl_ioloc_t* loc, const hcl_oocs_t* tgt, const hcl_uch_t* msgfmt, ...)
{
static hcl_bch_t syntax_error[] = "syntax error - ";
if (msgfmt)
{
va_list ap;
int i, selen;
va_start (ap, msgfmt);
hcl_seterrufmtv (hcl, HCL_ESYNERR, msgfmt, ap);
va_end (ap);
selen = HCL_COUNTOF(syntax_error) - 1;
HCL_MEMMOVE (&hcl->errmsg.buf[selen], &hcl->errmsg.buf[0], HCL_SIZEOF(hcl->errmsg.buf[0]) * (HCL_COUNTOF(hcl->errmsg.buf) - selen));
for (i = 0; i < selen; i++) hcl->errmsg.buf[i] = syntax_error[i];
hcl->errmsg.buf[HCL_COUNTOF(hcl->errmsg.buf) - 1] = '\0';
}
else
{
hcl_seterrbfmt (hcl, HCL_ESYNERR, "syntax error - %hs", synerr_to_errstr(num));
hcl_seterrbfmt (hcl, HCL_ESYNERR, "%hs%hs", syntax_error, synerr_to_errstr(num));
}
hcl->c->synerr.num = num;
@ -373,11 +391,18 @@ void hcl_setsynerrufmt (hcl_t* hcl, hcl_synerrnum_t num, const hcl_ioloc_t* loc,
* hcl->c->tok.loc due to 'const' prefixed to loc. */
/*hcl->c->synerr.loc = loc? *loc: hcl->c->tok.loc;*/
if (loc)
{
hcl->c->synerr.loc = *loc;
}
else
{
hcl->c->synerr.loc = hcl->c->tok.loc;
}
if (tgt) hcl->c->synerr.tgt = *tgt;
if (tgt)
{
hcl->c->synerr.tgt = *tgt;
}
else
{
hcl->c->synerr.tgt.ptr = HCL_NULL;

18
hcl/lib/hcl.h
View File

@ -818,7 +818,14 @@ struct hcl_cb_t
/* =========================================================================
* PRIMITIVE MODULE MANIPULATION
* ========================================================================= */
typedef int (*hcl_prim_impl_t) (hcl_t* hcl, hcl_ooi_t nargs);
enum hcl_pfrc_t
{
HCL_PF_FAILURE = -1,
HCL_PF_SUCCESS = 0
};
typedef enum hcl_pfrc_t hcl_pfrc_t;
typedef hcl_pfrc_t (*hcl_prim_impl_t) (hcl_t* hcl, hcl_ooi_t nargs);
typedef struct hcl_prim_mod_t hcl_prim_mod_t;
@ -1049,11 +1056,18 @@ struct hcl_t
/* you can't access arguments and receiver after this macro.
* also you must not call this macro more than once */
#define HCL_STACK_SETRET(hcl,nargs,retv) (HCL_STACK_POPS(hcl, nargs), HCL_STACK_SETTOP(hcl, retv))
#define HCL_STACK_SETRET(hcl,nargs,retv) \
do { \
HCL_STACK_POPS(hcl, nargs); \
HCL_STACK_SETTOP(hcl, (retv)); \
} while(0)
#define HCL_STACK_SETRETTORCV(hcl,nargs) (HCL_STACK_POPS(hcl, nargs))
/* =========================================================================
* STRING ENCODING CONVERSION
* ========================================================================= */

13
hcl/lib/main.c
View File

@ -1040,12 +1040,10 @@ int main (int argc, char* argv[])
{
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot compile object - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl));
}
/* carry on? */
}
}
}
else
{
hcl_decode (hcl, 0, hcl->code.bc.len);
HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n");
g_hcl = hcl;
@ -1053,10 +1051,15 @@ g_hcl = hcl;
if (hcl_execute(hcl) <= -1)
{
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot execute - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl));
}
//cancel_tick();
g_hcl = HCL_NULL;
}
}
}

92
hcl/lib/prim.c
View File

@ -95,7 +95,7 @@ start_over:
}
}
static int prim_log (hcl_t* hcl, hcl_ooi_t nargs)
static hcl_pfrc_t prim_log (hcl_t* hcl, hcl_ooi_t nargs)
{
/* TODO: accept log level */
hcl_oop_t msg, level;
@ -158,12 +158,53 @@ static int prim_log (hcl_t* hcl, hcl_ooi_t nargs)
}
HCL_STACK_SETRET (hcl, nargs, hcl->_nil);
return 0;
return HCL_PF_SUCCESS;
}
/* ------------------------------------------------------------------------- */
static hcl_pfrc_t prim_eqv (hcl_t* hcl, hcl_ooi_t nargs)
{
hcl_oop_t a0, a1, rv;
a0 = HCL_STACK_GETARG(hcl, nargs, 0);
a1 = HCL_STACK_GETARG(hcl, nargs, 1);
rv = (a0 == a1? hcl->_true: hcl->_false);
HCL_STACK_SETRET (hcl, nargs, rv);
return HCL_PF_SUCCESS;
}
static hcl_pfrc_t prim_eql (hcl_t* hcl, hcl_ooi_t nargs)
{
int n;
n = hcl_equalobjs(hcl, HCL_STACK_GETARG(hcl, nargs, 0), HCL_STACK_GETARG(hcl, nargs, 1));
if (n <= -1) return HCL_PF_FAILURE;
HCL_STACK_SETRET (hcl, nargs, (n? hcl->_true: hcl->_false));
return HCL_PF_SUCCESS;
}
static hcl_pfrc_t prim_not (hcl_t* hcl, hcl_ooi_t nargs)
{
hcl_oop_t arg, rv;
arg = HCL_STACK_GETARG(hcl, nargs, 0);
if (arg == hcl->_true) rv = hcl->_false;
else if (arg == hcl->_false) rv = hcl->_true;
else
{
hcl_seterrbfmt (hcl, HCL_EINVAL, "boolean parameter expected - %O", arg);
return HCL_PF_FAILURE;
}
HCL_STACK_SETRET (hcl, nargs, rv);
return HCL_PF_SUCCESS;
}
/* ------------------------------------------------------------------------- */
static int oop_to_ooi (hcl_t* hcl, hcl_oop_t iv, hcl_ooi_t* ov)
static hcl_pfrc_t oop_to_ooi (hcl_t* hcl, hcl_oop_t iv, hcl_ooi_t* ov)
{
if (HCL_OOP_IS_SMOOI(iv))
{
@ -177,12 +218,12 @@ static int oop_to_ooi (hcl_t* hcl, hcl_oop_t iv, hcl_ooi_t* ov)
}
else
{
/* TODO: set error number or something...to indicate primitive failure... */
hcl_seterrbfmt (hcl, HCL_EINVAL, "not a numeric object - %O", iv);
return -1;
}
}
static int prim_plus (hcl_t* hcl, hcl_ooi_t nargs)
static hcl_pfrc_t prim_plus (hcl_t* hcl, hcl_ooi_t nargs)
{
hcl_ooi_t x = 0;
hcl_oow_t i;
@ -193,18 +234,18 @@ static int prim_plus (hcl_t* hcl, hcl_ooi_t nargs)
hcl_ooi_t v;
arg = HCL_STACK_GETARG(hcl, nargs, i);
if (oop_to_ooi(hcl, arg, &v) <= -1) return -1;
if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE;
x += v;
}
ret = hcl_makeinteger (hcl, x);
if (!ret) return -1;
if (!ret) return HCL_PF_FAILURE;
HCL_STACK_SETRET (hcl, nargs, ret);
return 0;
return HCL_PF_SUCCESS;
}
static int prim_minus (hcl_t* hcl, hcl_ooi_t nargs)
static hcl_pfrc_t prim_minus (hcl_t* hcl, hcl_ooi_t nargs)
{
hcl_ooi_t x = 0;
hcl_oow_t i;
@ -213,24 +254,24 @@ static int prim_minus (hcl_t* hcl, hcl_ooi_t nargs)
if (nargs > 0)
{
arg = HCL_STACK_GETARG(hcl, nargs, 0);
if (oop_to_ooi(hcl, arg, &x) <= -1) return -1;
if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE;
for (i = 1; i < nargs; i++)
{
hcl_ooi_t v;
arg = HCL_STACK_GETARG(hcl, nargs, i);
if (oop_to_ooi(hcl, arg, &v) <= -1) return -1;
if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE;
x -= v;
}
}
ret = hcl_makeinteger (hcl, x);
if (!ret) return -1;
if (!ret) return HCL_PF_FAILURE;
HCL_STACK_SETRET (hcl, nargs, ret);
return 0;
return HCL_PF_SUCCESS;
}
static int prim_printf (hcl_t* hcl, hcl_ooi_t nargs)
static hcl_pfrc_t prim_printf (hcl_t* hcl, hcl_ooi_t nargs)
{
hcl_ooi_t x = 0;
hcl_oow_t i;
@ -239,21 +280,21 @@ static int prim_printf (hcl_t* hcl, hcl_ooi_t nargs)
if (nargs > 0)
{
arg = HCL_STACK_GETARG(hcl, nargs, 0);
if (oop_to_ooi(hcl, arg, &x) <= -1) return -1;
if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE;
for (i = 1; i < nargs; i++)
{
hcl_ooi_t v;
arg = HCL_STACK_GETARG(hcl, nargs, i);
if (oop_to_ooi(hcl, arg, &v) <= -1) return -1;
if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE;
x -= v;
}
}
ret = hcl_makeinteger (hcl, x);
if (!ret) return -1;
if (!ret) return HCL_PF_FAILURE;
HCL_STACK_SETRET (hcl, nargs, ret);
return 0;
return HCL_PF_SUCCESS;
}
/* ------------------------------------------------------------------------- */
@ -261,6 +302,14 @@ static prim_t builtin_prims[] =
{
{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_log, 3, { 'l','o','g' } },
{ 1, 1, prim_not, 3, { 'n','o','t' } },
/* { 2, 2, prim_and, 3, { 'a','n','d' } },
{ 2, 2, prim_or, 2, { 'o','r' } }, */
{ 2, 2, prim_eqv, 4, { 'e','q','v','?' } },
{ 2, 2, prim_eql, 4, { 'e','q','l','?' } },
/*
{ 2, 2, prim_gt, 1, { '>' } },
{ 2, 2, prim_ge, 2, { '>','=' } },
@ -269,17 +318,16 @@ static prim_t builtin_prims[] =
{ 2, 2, prim_eq, 1, { '=' } },
{ 2, 2, prim_ne, 2, { '/','=' } },
{ 2, 2, prim_eql, 3, { 'e','q','l' } },
{ 2, 2, prim_max, 3, { 'm','a','x' } },
{ 2, 2, prim_min, 3, { 'm','i','n' } },
{ 2, 2, prim_and, 3, { 'a','n','d' } },
{ 2, 2, prim_or, 2, { 'o','r' } },
{ 1, 1, prim_not, 3, { 'n','o','t' } }, */
*/
{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_plus, 1, { '+' } },
{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_minus, 1, { '-' } },
{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_printf, 6, { 'p','r','i','n','t','f' } },
};

33
hcl/lib/read.c
View File

@ -222,7 +222,7 @@ static HCL_INLINE int is_alnumchar (hcl_ooci_t c)
static HCL_INLINE int is_delimiter (hcl_ooci_t c)
{
return c == '(' || c == ')' || c == '[' || c == ']' || c == '{' || c == '}' || c == '\"' || c == '#' || c == ';' || c == '|' || is_spacechar(c) || c == HCL_UCI_EOF;
return c == '(' || c == ')' || c == '[' || c == ']' || c == '{' || c == '}' || c == '\"' || c == '\'' || c == '#' || c == ';' || c == '|' || is_spacechar(c) || c == HCL_UCI_EOF;
}
@ -692,15 +692,13 @@ static int get_sharp_token (hcl_t* hcl)
* #bBBBB binary
* #oOOOO octal
* #xXXXX hexadecimal
* #t
* #f
* #true
* #false
* #include
* #\C * character
* #\xHHHH * unicode
* #\uHHHH
* #( ) * vector
* #( ) * array
* #[ ] * byte array
* #{ } * dictionary
* #< > -- xxx
@ -720,6 +718,8 @@ static int get_sharp_token (hcl_t* hcl)
if (get_radix_number (hcl, c, radix) <= -1) return -1;
break;
#if 0
/* i changed mind. i don't want to have #t for true and #f for false. */
case 't':
ADD_TOKEN_CHAR (hcl, '#');
ADD_TOKEN_CHAR (hcl, 't');
@ -737,6 +737,7 @@ static int get_sharp_token (hcl_t* hcl)
unget_char (hcl, &hcl->c->lxc);
SET_TOKEN_TYPE (hcl, HCL_IOTOK_FALSE);
break;
#endif
case '\\': /* character literal */
ADD_TOKEN_CHAR (hcl, '#');
@ -806,7 +807,7 @@ static int get_sharp_token (hcl_t* hcl)
{
c = '\r';
}
else if (does_token_name_match (hcl, VOCA_NUL))
else if (does_token_name_match(hcl, VOCA_NUL)) /* null character. not #nil */
{
c = '\0';
}
@ -838,19 +839,19 @@ static int get_sharp_token (hcl_t* hcl)
unget_char (hcl, &hcl->c->lxc);
break;
case '(': /* #( - array literal */
case '(': /* #( - array opener */
ADD_TOKEN_CHAR (hcl, '#');
ADD_TOKEN_CHAR(hcl, c);
SET_TOKEN_TYPE (hcl, HCL_IOTOK_APAREN);
break;
case '[': /* #[ - byte array literal */
case '[': /* #[ - byte array opener */
ADD_TOKEN_CHAR (hcl, '#');
ADD_TOKEN_CHAR(hcl, c);
SET_TOKEN_TYPE (hcl, HCL_IOTOK_BAPAREN);
break;
case '{':
case '{': /* #{ - dictionary opener */
ADD_TOKEN_CHAR (hcl, '#');
ADD_TOKEN_CHAR(hcl, c);
SET_TOKEN_TYPE (hcl, HCL_IOTOK_DPAREN);
@ -986,9 +987,11 @@ retry:
if (get_string(hcl, '\"', '\\', 0, 0) <= -1) return -1;
break;
#if 0
case '\'':
if (get_quoted_token(hcl) <= -1) return -1;
break;
#endif
case '#':
if (get_sharp_token(hcl) <= -1) return -1;
@ -1061,6 +1064,12 @@ retry:
default:
ident:
if (is_delimiter(c))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ILCHR, TOKEN_LOC(hcl), HCL_NULL, "illegal character %jc encountered", c);
return -1;
}
SET_TOKEN_TYPE (hcl, HCL_IOTOK_IDENT);
while (1)
{
@ -1351,9 +1360,9 @@ done:
case HCL_CONCODE_DIC:
return (hcl_oop_t)hcl_makedic(hcl, 100); /* TODO: default dictionary size for empty definition? */
case HCL_CONCODE_XLIST:
hcl_setsynerr (hcl, HCL_SYNERR_EMPTYXLIST, TOKEN_LOC(hcl), HCL_NULL);
return HCL_NULL;
/* NOTE: empty xlist will get translated to #nil.
* this is useful when used in the lambda expression to express an empty argument.
* (lambda () ...) is equivalent to (lambda #nil ...) */
}
}
@ -1668,10 +1677,12 @@ static int read_object (hcl_t* hcl)
flagv = 0;
LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_DIC);
goto start_list;
#if 0
case HCL_IOTOK_QPAREN:
flagv = 0;
LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_QLIST);
goto start_list;
#endif
case HCL_IOTOK_LPAREN:
flagv = 0;
LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_XLIST);

1
hcl/lib/utl.c
View File

@ -351,6 +351,7 @@ hcl_bch_t* hcl_findbcharinbcstr (const hcl_bch_t* ptr, hcl_bch_t c)
return HCL_NULL;
}
/* ----------------------------------------------------------------------- */
int hcl_concatoocstrtosbuf (hcl_t* hcl, const hcl_ooch_t* str, int id)