diff --git a/Makefile.in b/Makefile.in index 3cbd986..0d109b6 100644 --- a/Makefile.in +++ b/Makefile.in @@ -163,8 +163,8 @@ am__DIST_COMMON = $(srcdir)/Makefile.in $(top_srcdir)/ac/ar-lib \ $(top_srcdir)/ac/compile $(top_srcdir)/ac/config.guess \ $(top_srcdir)/ac/config.sub $(top_srcdir)/ac/install-sh \ $(top_srcdir)/ac/ltmain.sh $(top_srcdir)/ac/missing ac/ar-lib \ - ac/compile ac/config.guess ac/config.sub ac/install-sh \ - ac/ltmain.sh ac/missing + ac/compile ac/config.guess ac/config.sub ac/depcomp \ + ac/install-sh ac/ltmain.sh ac/missing DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) distdir = $(PACKAGE)-$(VERSION) top_distdir = $(distdir) diff --git a/configure b/configure index 4541f6a..f9e3e9a 100755 --- a/configure +++ b/configure @@ -17563,6 +17563,18 @@ _ACEOF fi done +for ac_func in isatty +do : + ac_fn_c_check_func "$LINENO" "isatty" "ac_cv_func_isatty" +if test "x$ac_cv_func_isatty" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_ISATTY 1 +_ACEOF + +fi +done + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lunicows" >&5 $as_echo_n "checking for main in -lunicows... " >&6; } @@ -17705,6 +17717,52 @@ fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for strftime %z" >&5 +$as_echo_n "checking for strftime %z... " >&6; } +if test "$cross_compiling" = yes; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unknown" >&5 +$as_echo "unknown" >&6; } + +$as_echo "#define HAVE_STRFTIME_SMALL_Z 1" >>confdefs.h + + + +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include + #if defined(HAVE_SYS_TIME_H) + #include + #endif + #if defined(HAVE_TIME_H) + #include + #endif + int main () + { + char buf[100]; + time_t t = 0; + strftime (buf, sizeof(buf), "%z", gmtime(&t)); + return strcmp(buf, "%z") == 0? 1: 0; + } +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + +$as_echo "#define HAVE_STRFTIME_SMALL_Z 1" >>confdefs.h + + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. diff --git a/configure.ac b/configure.ac index 481e7de..ff0e9e8 100644 --- a/configure.ac +++ b/configure.ac @@ -135,6 +135,8 @@ AC_CHECK_FUNCS([gettimeofday settimeofday clock_gettime clock_settime getitimer AC_CHECK_FUNCS([backtrace backtrace_symbols]) AC_CHECK_FUNCS([makecontext swapcontext getcontext setcontext]) AC_CHECK_FUNCS([snprintf _vsnprintf _vsnwprintf]) +AC_CHECK_FUNCS([isatty]) + dnl check is the import library for unicows.dll exists dnl this check doesn't look for a particular symbol @@ -173,6 +175,34 @@ AC_TRY_LINK( [AC_MSG_RESULT(no)] ) +AC_MSG_CHECKING([for strftime %z]) +AC_TRY_RUN( + [#include + #if defined(HAVE_SYS_TIME_H) + #include + #endif + #if defined(HAVE_TIME_H) + #include + #endif + int main () + { + char buf[100]; + time_t t = 0; + strftime (buf, sizeof(buf), "%z", gmtime(&t)); + return strcmp(buf, "%z") == 0? 1: 0; + }], + [ + AC_MSG_RESULT(yes) + AC_DEFINE([HAVE_STRFTIME_SMALL_Z], [1], [strftime supports %z]) + ], + [AC_MSG_RESULT(no)], + [ + dnl cross-compiling, assume yes + AC_MSG_RESULT(unknown) + AC_DEFINE([HAVE_STRFTIME_SMALL_Z], [1], [strftime supports %z]) + ] +) + dnl check the size of primitive data types AC_CHECK_SIZEOF(char,,[[]]) AC_CHECK_SIZEOF(short,,[[]]) diff --git a/lib/Makefile.am b/lib/Makefile.am index 462f7b8..5adc815 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -59,6 +59,8 @@ hcl_SOURCES = main.c hcl_CPPFLAGS = $(CPPFLAGS_LIB_COMMON) hcl_LDFLAGS = $(LDFLAGS_LIB_COMMON) hcl_LDADD = $(LIBADD_LIB_COMMON) -lhcl #-ldyncall_s +hcl_DEPENDENCIES = libhcl.la + install-data-hook: @echo "#ifndef _HCL_CFG_H_" > "$(DESTDIR)$(pkgincludedir)/hcl-cfg.h" diff --git a/lib/Makefile.in b/lib/Makefile.in index 7380c5a..a93e4f9 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -155,7 +155,6 @@ libhcl_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ PROGRAMS = $(bin_PROGRAMS) am_hcl_OBJECTS = hcl-main.$(OBJEXT) hcl_OBJECTS = $(am_hcl_OBJECTS) -hcl_DEPENDENCIES = $(am__DEPENDENCIES_2) hcl_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ $(hcl_LDFLAGS) $(LDFLAGS) -o $@ @@ -423,6 +422,7 @@ hcl_SOURCES = main.c hcl_CPPFLAGS = $(CPPFLAGS_LIB_COMMON) hcl_LDFLAGS = $(LDFLAGS_LIB_COMMON) hcl_LDADD = $(LIBADD_LIB_COMMON) -lhcl #-ldyncall_s +hcl_DEPENDENCIES = libhcl.la all: hcl-cfg.h $(MAKE) $(AM_MAKEFLAGS) all-am diff --git a/lib/comp.c b/lib/comp.c index 037cf21..3e5bbf6 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -1095,6 +1095,14 @@ static int compile_cons_expression (hcl_t* hcl, hcl_oop_t obj) hcl_oop_t car; int syncode; + /* a valid function call + * (function-name argument-list) + * function-name can be: + * a symbol. + * another function call. + * if the name is another function call, i can't know if the + * function name will be valid at the compile time. + */ HCL_ASSERT (hcl, HCL_IS_CONS(hcl, obj)); car = HCL_CONS_CAR(obj); @@ -1102,11 +1110,6 @@ static int compile_cons_expression (hcl_t* hcl, hcl_oop_t obj) { switch (syncode) { - case HCL_SYNCODE_BEGIN: -HCL_DEBUG0 (hcl, "BEGIN NOT IMPLEMENTED...\n"); -/* TODO: not implemented yet */ - break; - case HCL_SYNCODE_BREAK: /* break */ if (compile_break (hcl, obj) <= -1) return -1; @@ -1114,45 +1117,48 @@ HCL_DEBUG0 (hcl, "BEGIN NOT IMPLEMENTED...\n"); case HCL_SYNCODE_DEFUN: HCL_DEBUG0 (hcl, "DEFUN NOT IMPLEMENTED...\n"); +/* TODO: not implemented yet */ + break; + + case HCL_SYNCODE_DO: +HCL_DEBUG0 (hcl, "DO NOT IMPLEMENTED...\n"); /* TODO: not implemented yet */ break; case HCL_SYNCODE_ELSE: - HCL_DEBUG1 (hcl, "Syntax error - else without if - %O\n", obj); - hcl_setsynerr (hcl, HCL_SYNERR_ELSE, HCL_NULL, HCL_NULL); /* error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ELSE, HCL_NULL, HCL_NULL, "else without if - %O", obj); /* error location */ return -1; case HCL_SYNCODE_ELIF: - HCL_DEBUG1 (hcl, "Syntax error - elif without if - %O\n", obj); - hcl_setsynerr (hcl, HCL_SYNERR_ELIF, HCL_NULL, HCL_NULL); /* error location */ + hcl_setsynerrbfmt(hcl, HCL_SYNERR_ELIF, HCL_NULL, HCL_NULL, "elif without if - %O", obj); /* error location */ return -1; case HCL_SYNCODE_IF: - if (compile_if (hcl, obj) <= -1) return -1; + if (compile_if(hcl, obj) <= -1) return -1; break; case HCL_SYNCODE_LAMBDA: /* (lambda (x y) (+ x y)) */ - if (compile_lambda (hcl, obj) <= -1) return -1; + if (compile_lambda(hcl, obj) <= -1) return -1; break; case HCL_SYNCODE_SET: /* (set x 10) * (set x (lambda (x y) (+ x y)) */ - if (compile_set (hcl, obj) <= -1) return -1; + if (compile_set(hcl, obj) <= -1) return -1; break; case HCL_SYNCODE_RETURN: /* (return 10) * (return (+ 10 20)) */ - if (compile_return (hcl, obj) <= -1) return -1; + if (compile_return(hcl, obj) <= -1) return -1; break; case HCL_SYNCODE_UNTIL: - if (compile_while (hcl, obj, COP_POST_UNTIL_COND) <= -1) return -1; + if (compile_while(hcl, obj, COP_POST_UNTIL_COND) <= -1) return -1; break; case HCL_SYNCODE_WHILE: - if (compile_while (hcl, obj, COP_POST_WHILE_COND) <= -1) return -1; + if (compile_while(hcl, obj, COP_POST_WHILE_COND) <= -1) return -1; break; default: @@ -1161,7 +1167,7 @@ HCL_DEBUG0 (hcl, "DEFUN NOT IMPLEMENTED...\n"); return -1; } } - else + else if (HCL_IS_SYMBOL(hcl,car) || HCL_IS_CONS(hcl,car)) { /* normal function call * ( ...) */ @@ -1197,15 +1203,16 @@ HCL_DEBUG0 (hcl, "DEFUN NOT IMPLEMENTED...\n"); { if (HCL_BRANDOF(hcl, cdr) != HCL_BRAND_CONS) { - HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in function call - %O\n", obj); - hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */ + /* (funname . 10) */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, "redundant cdr in function call - %O", obj); /* TODO: error location */ return -1; } - nargs = hcl_countcons (hcl, cdr); + nargs = hcl_countcons(hcl, cdr); if (nargs > MAX_CODE_PARAM) { - hcl_seterrnum (hcl, HCL_ERANGE); + /* TODO: change to syntax error */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_NULL, HCL_NULL, "too many(%zd) parameters in function call - %O", nargs, obj); return -1; } } @@ -1217,6 +1224,11 @@ HCL_DEBUG0 (hcl, "DEFUN NOT IMPLEMENTED...\n"); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_CALL); cf->operand = HCL_SMOOI_TO_OOP(nargs); } + else + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_CALLABLE, HCL_NULL, HCL_NULL, "invalid callable %O in function call - %O", car, obj); /* error location */ + return -1; + } return 0; } @@ -1325,8 +1337,7 @@ static int compile_object (hcl_t* hcl) break; case HCL_BRAND_SYMBOL_ARRAY: - HCL_DEBUG1 (hcl, "Syntax error - variable declaration disallowed - %O\n", cf->operand); - hcl_setsynerr (hcl, HCL_SYNERR_VARDCLBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARDCLBANNED, HCL_NULL, HCL_NULL, "variable declaration disallowed - %O", cf->operand); /* TODO: error location */ return -1; default: @@ -1351,10 +1362,10 @@ static int compile_object_list (hcl_t* hcl) cf = GET_TOP_CFRAME(hcl); HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_OBJECT_LIST || - cf->opcode == COP_COMPILE_IF_OBJECT_LIST || - cf->opcode == COP_COMPILE_ARGUMENT_LIST || - cf->opcode == COP_COMPILE_IF_OBJECT_LIST_TAIL || - cf->opcode == COP_COMPILE_OBJECT_LIST_TAIL); + cf->opcode == COP_COMPILE_IF_OBJECT_LIST || + cf->opcode == COP_COMPILE_ARGUMENT_LIST || + cf->opcode == COP_COMPILE_IF_OBJECT_LIST_TAIL || + cf->opcode == COP_COMPILE_OBJECT_LIST_TAIL); cop = cf->opcode; coperand = cf->operand; diff --git a/lib/gc.c b/lib/gc.c index f56ee42..ce505f3 100644 --- a/lib/gc.c +++ b/lib/gc.c @@ -34,14 +34,14 @@ static struct hcl_oow_t offset; } syminfo[] = { - { 5, { 'b','e','g','i','n' }, HCL_SYNCODE_BEGIN, HCL_OFFSETOF(hcl_t,_begin) }, + { 5, { 'b','r','e','a','k' }, HCL_SYNCODE_BREAK, HCL_OFFSETOF(hcl_t,_break) }, { 5, { 'd','e','f','u','n' }, HCL_SYNCODE_DEFUN, HCL_OFFSETOF(hcl_t,_defun) }, + { 2, { 'd','o' }, HCL_SYNCODE_DO, HCL_OFFSETOF(hcl_t,_do) }, { 4, { 'e','l','i','f' }, HCL_SYNCODE_ELIF, HCL_OFFSETOF(hcl_t,_elif) }, { 4, { 'e','l','s','e' }, HCL_SYNCODE_ELSE, HCL_OFFSETOF(hcl_t,_else) }, { 2, { 'i','f' }, HCL_SYNCODE_IF, HCL_OFFSETOF(hcl_t,_if) }, { 6, { 'l','a','m','b','d','a' }, HCL_SYNCODE_LAMBDA, HCL_OFFSETOF(hcl_t,_lambda) }, - { 5, { 'q','u','o','t','e' }, HCL_SYNCODE_QUOTE, HCL_OFFSETOF(hcl_t,_quote) }, { 6, { 'r','e','t','u','r','n'}, HCL_SYNCODE_RETURN, HCL_OFFSETOF(hcl_t,_return) }, { 3, { 's','e','t' }, HCL_SYNCODE_SET, HCL_OFFSETOF(hcl_t,_set) }, { 5, { 'u','n','t','i','l' }, HCL_SYNCODE_UNTIL, HCL_OFFSETOF(hcl_t,_until) }, diff --git a/lib/hcl-cfg.h.in b/lib/hcl-cfg.h.in index 2e6d2cf..629684b 100644 --- a/lib/hcl-cfg.h.in +++ b/lib/hcl-cfg.h.in @@ -75,6 +75,9 @@ /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H +/* Define to 1 if you have the `isatty' function. */ +#undef HAVE_ISATTY + /* Define to 1 if you have the `log10q' function. */ #undef HAVE_LOG10Q @@ -132,6 +135,9 @@ /* Define to 1 if you have the header file. */ #undef HAVE_STDLIB_H +/* strftime supports %z */ +#undef HAVE_STRFTIME_SMALL_Z + /* Define to 1 if you have the header file. */ #undef HAVE_STRINGS_H diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 615cda9..2be1cf3 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -257,13 +257,16 @@ struct hcl_iotok_t HCL_IOTOK_IDENT, HCL_IOTOK_DOT, - HCL_IOTOK_QUOTE, HCL_IOTOK_LPAREN, HCL_IOTOK_RPAREN, - HCL_IOTOK_ARPAREN, - HCL_IOTOK_BAPAREN, - HCL_IOTOK_LBRACK, + HCL_IOTOK_APAREN, /* #( */ + HCL_IOTOK_BAPAREN, /* #[ */ + HCL_IOTOK_QPAREN, /* '( */ + HCL_IOTOK_DPAREN, /* #{ */ + HCL_IOTOK_LBRACK, HCL_IOTOK_RBRACK, + HCL_IOTOK_LBRACE, + HCL_IOTOK_RBRACE, HCL_IOTOK_VBAR, HCL_IOTOK_INCLUDE @@ -700,6 +703,24 @@ enum hcl_bcode_t extern "C" { #endif +/* ========================================================================= */ +/* err.c */ +/* ========================================================================= */ + +void hcl_seterrbfmtv ( + hcl_t* hcl, + hcl_errnum_t errnum, + const hcl_bch_t* fmt, + va_list ap +); + +void hcl_seterrufmtv ( + hcl_t* hcl, + hcl_errnum_t errnum, + const hcl_uch_t* fmt, + va_list ap +); + /* ========================================================================= */ /* heap.c */ diff --git a/lib/hcl.c b/lib/hcl.c index f3d0115..309776c 100644 --- a/lib/hcl.c +++ b/lib/hcl.c @@ -381,9 +381,46 @@ void hcl_getsynerr (hcl_t* hcl, hcl_synerr_t* synerr) if (synerr) *synerr = hcl->c->synerr; } -void hcl_setsynerr (hcl_t* hcl, hcl_synerrnum_t num, const hcl_ioloc_t* loc, const hcl_oocs_t* tgt) +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, ...) { - hcl_seterrnum (hcl, HCL_ESYNERR); + if (msgfmt) + { + va_list ap; + va_start (ap, msgfmt); + hcl_seterrbfmtv (hcl, HCL_ESYNERR, msgfmt, ap); + va_end (ap); + } + else hcl_seterrnum (hcl, HCL_ESYNERR); + hcl->c->synerr.num = num; + + /* The SCO compiler complains of this ternary operation saying: + * error: operands have incompatible types: op ":" + * it seems to complain of type mismatch between *loc and + * 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; + else + { + hcl->c->synerr.tgt.ptr = HCL_NULL; + hcl->c->synerr.tgt.len = 0; + } +} + +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, ...) +{ + if (msgfmt) + { + va_list ap; + va_start (ap, msgfmt); + hcl_seterrufmtv (hcl, HCL_ESYNERR, msgfmt, ap); + va_end (ap); + } + else hcl_seterrnum (hcl, HCL_ESYNERR); hcl->c->synerr.num = num; /* The SCO compiler complains of this ternary operation saying: diff --git a/lib/hcl.h b/lib/hcl.h index 395bf18..1f26fb2 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -117,6 +117,7 @@ enum hcl_synerrnum_t HCL_SYNERR_LPAREN, /* ( expected */ HCL_SYNERR_RPAREN, /* ) expected */ HCL_SYNERR_RBRACK, /* ] expected */ + HCL_SYNERR_RBRACE, /* } expected */ HCL_SYNERR_VBAR, /* | expected */ HCL_SYNERR_STRING, /* string expected */ @@ -146,7 +147,9 @@ enum hcl_synerrnum_t HCL_SYNERR_ELIF, /* elif without if */ HCL_SYNERR_ELSE, /* else without if */ - HCL_SYNERR_BREAK /* break outside loop */ + HCL_SYNERR_BREAK, /* break outside loop */ + + HCL_SYNERR_CALLABLE /* invalid callable */ }; typedef enum hcl_synerrnum_t hcl_synerrnum_t; @@ -928,9 +931,9 @@ struct hcl_t hcl_oop_t _true; hcl_oop_t _false; - hcl_oop_t _begin; /* symbol */ hcl_oop_t _break; /* symbol */ hcl_oop_t _defun; /* symbol */ + hcl_oop_t _do; /* symbol */ hcl_oop_t _elif; /* symbol */ hcl_oop_t _else; /* symbol */ hcl_oop_t _if; /* symbol */ @@ -1319,20 +1322,30 @@ enum enum { /* SYNCODE 0 means it's not a syncode object. so it begins with 1 */ - HCL_SYNCODE_BEGIN = 1, - HCL_SYNCODE_BREAK, + HCL_SYNCODE_BREAK = 1, HCL_SYNCODE_DEFUN, + HCL_SYNCODE_DO, HCL_SYNCODE_ELIF, HCL_SYNCODE_ELSE, HCL_SYNCODE_IF, HCL_SYNCODE_LAMBDA, - HCL_SYNCODE_QUOTE, HCL_SYNCODE_RETURN, HCL_SYNCODE_SET, HCL_SYNCODE_UNTIL, HCL_SYNCODE_WHILE }; + +enum +{ + /* these can be set in the SYNCODE flags for cons cells */ + HCL_CONCODE_XLIST = 0, /* () - executable list */ + HCL_CONCODE_ARRAY, /* #() */ + HCL_CONCODE_BYTEARRAY, /* #[] */ + HCL_CONCODE_DICTIONARY, /* #{} */ + HCL_CONCODE_QLIST /* '() - quoted list, data list */ +}; + struct hcl_cons_t { HCL_OBJ_HEADER; @@ -1343,6 +1356,8 @@ typedef struct hcl_cons_t hcl_cons_t; typedef struct hcl_cons_t* hcl_oop_cons_t; #define HCL_IS_NIL(hcl,v) (v == (hcl)->_nil) +#define HCL_IS_TRUE(hcl,v) (v == (hcl)->_true) +#define HCL_IS_FALSE(hcl,v) (v == (hcl)->_false) #define HCL_IS_INTEGER(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_INTEGER) #define HCL_IS_SYMBOL(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL) #define HCL_IS_SYMBOL_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL_ARRAY) @@ -1584,13 +1599,34 @@ HCL_EXPORT void hcl_getsynerr ( hcl_synerr_t* synerr ); -HCL_EXPORT void hcl_setsynerr ( - hcl_t* hcl, - hcl_synerrnum_t num, - const hcl_ioloc_t* loc, - const hcl_oocs_t* tgt + +HCL_EXPORT 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, + ... ); +HCL_EXPORT 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, + ... +); + +#if defined(HCL_HAVE_INLINE) + static HCL_INLINE void hcl_setsynerr (hcl_t* hcl, hcl_synerrnum_t num, const hcl_ioloc_t* loc, const hcl_oocs_t* tgt) + { + hcl_setsynerrbfmt (hcl, num, loc, tgt, HCL_NULL); + } +#else +# define hcl_setsynerr(hcl,num,loc,tgt) hcl_setsynerrbfmt(hcl,num,loc,tgt,HCL_NULL) +#endif + /* Memory allocation/deallocation functions using hcl's MMGR */ HCL_EXPORT void* hcl_allocmem ( hcl_t* hcl, diff --git a/lib/logfmt.c b/lib/logfmt.c index 62ce309..3e995be 100644 --- a/lib/logfmt.c +++ b/lib/logfmt.c @@ -476,19 +476,33 @@ hcl_ooi_t hcl_logufmt (hcl_t* hcl, hcl_oow_t mask, const hcl_uch_t* fmt, ...) static int put_prch (hcl_t* hcl, hcl_oow_t mask, hcl_ooch_t ch, hcl_oow_t len) { -/* TODO: error handling, buffering */ +/* TODO: better error handling, buffering. + * buffer should be done by the printer callback? */ + hcl_ooi_t n; + hcl->c->outarg.ptr = &ch; hcl->c->outarg.len = 1; - hcl->c->printer (hcl, HCL_IO_WRITE, &hcl->c->outarg); + + n = hcl->c->printer(hcl, HCL_IO_WRITE, &hcl->c->outarg); + + if (n <= -1) return -1; + if (n == 0) return 0; return 1; /* success */ } static int put_prcs (hcl_t* hcl, hcl_oow_t mask, const hcl_ooch_t* ptr, hcl_oow_t len) { - /* TODO: error handling, buffering */ +/* TODO: better error handling, buffering + * buffer should be done by the printer callback? */ + hcl_ooi_t n; + hcl->c->outarg.ptr = (hcl_ooch_t*)ptr; hcl->c->outarg.len = len; - hcl->c->printer (hcl, HCL_IO_WRITE, &hcl->c->outarg); + + n = hcl->c->printer(hcl, HCL_IO_WRITE, &hcl->c->outarg); + + if (n <= -1) return -1; + if (n == 0) return 0; return 1; /* success */ } diff --git a/lib/main.c b/lib/main.c index 17b8b8a..8ede275 100644 --- a/lib/main.c +++ b/lib/main.c @@ -806,6 +806,7 @@ static char* syntax_error_msg[] = "( expected", ") expected", "] expected", + "} expected", "| expected", "string expected", @@ -834,7 +835,9 @@ static char* syntax_error_msg[] = "elif without if", "else without if", - "break outside loop" + "break outside loop", + + "invalid callable" }; static void print_synerr (hcl_t* hcl) @@ -855,24 +858,23 @@ static void print_synerr (hcl_t* hcl) hcl_logbfmt (hcl, HCL_LOG_STDERR, "%s", xtn->read_path); } - hcl_logbfmt (hcl, HCL_LOG_STDERR, "syntax error at line %lu column %lu - %hs", - (unsigned long int)synerr.loc.line, (unsigned long int)synerr.loc.colm, - syntax_error_msg[synerr.num]); + hcl_logbfmt (hcl, HCL_LOG_STDERR, "[%zu,%zu] syntax error - %hs", + synerr.loc.line, synerr.loc.colm, syntax_error_msg[synerr.num]); if (synerr.tgt.len > 0) { hcl_logbfmt (hcl, HCL_LOG_STDERR, " - %.*js", synerr.tgt.len, synerr.tgt.ptr); } + if (hcl_geterrmsg(hcl) != hcl_geterrstr(hcl)) + { + hcl_logbfmt (hcl, HCL_LOG_STDERR, " - %js", hcl_geterrmsg(hcl)); + } + hcl_logbfmt (hcl, HCL_LOG_STDERR, "\n"); } -hcl_ooch_t str_hcl[] = { 'S', 't', 'i', 'x' }; -hcl_ooch_t str_my_object[] = { 'M', 'y', 'O', 'b','j','e','c','t' }; -hcl_ooch_t str_main[] = { 'm', 'a', 'i', 'n' }; - - -#define MIN_MEMSIZE 2048000ul +#define MIN_MEMSIZE 512000ul int main (int argc, char* argv[]) { diff --git a/lib/prim.c b/lib/prim.c index 8694350..e198dd4 100644 --- a/lib/prim.c +++ b/lib/prim.c @@ -105,7 +105,7 @@ static int prim_log (hcl_t* hcl, hcl_ooi_t nargs) /*level = HCL_STACK_GET(hcl, hcl->sp - nargs + 1); if (!HCL_OOP_IS_SMOOI(level)) mask = HCL_LOG_APP | HCL_LOG_INFO; else mask = HCL_LOG_APP | HCL_OOP_TO_SMOOI(level);*/ - mask = HCL_LOG_APP | HCL_LOG_INFO; /* TODO: accept logging level .. */ + mask = HCL_LOG_APP | HCL_LOG_FATAL; /* TODO: accept logging level .. */ for (k = 0; k < nargs; k++) { @@ -230,6 +230,31 @@ static int prim_minus (hcl_t* hcl, hcl_ooi_t nargs) return 0; } +static int prim_printf (hcl_t* hcl, hcl_ooi_t nargs) +{ + hcl_ooi_t x = 0; + hcl_oow_t i; + hcl_oop_t arg, ret; + + if (nargs > 0) + { + arg = HCL_STACK_GETARG(hcl, nargs, 0); + if (oop_to_ooi(hcl, arg, &x) <= -1) return -1; + 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; + x -= v; + } + } + + ret = hcl_makeinteger (hcl, x); + if (!ret) return -1; + + HCL_STACK_SETRET (hcl, nargs, ret); + return 0; +} /* ------------------------------------------------------------------------- */ static prim_t builtin_prims[] = @@ -252,8 +277,10 @@ static prim_t builtin_prims[] = { 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_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' } }, }; diff --git a/lib/print.c b/lib/print.c index 6c634a5..61d9fab 100644 --- a/lib/print.c +++ b/lib/print.c @@ -257,7 +257,28 @@ next: case HCL_BRAND_CONS: { - if (outbfmt(hcl, mask, "(") <= -1) return -1; + static hcl_bch_t *opening_paren[] = + { + "(", /*HCL_CONCODE_XLIST */ + "#(", /*HCL_CONCODE_ARRAY */ + "#[", /*HCL_CONCODE_BYTEARRAY */ + "#{", /*HCL_CONCODE_DICTIONARY */ + "'(" /*HCL_CONCODE_QLIST */ + }; + + static hcl_bch_t *closing_paren[] = + { + ")", /*HCL_CONCODE_XLIST */ + ")", /*HCL_CONCODE_ARRAY */ + "]", /*HCL_CONCODE_BYTEARRAY */ + "}", /*HCL_CONCODE_DICTIONARY */ + ")" /*HCL_CONCODE_QLIST */ + }; + + int concode; + + concode = HCL_OBJ_GET_FLAGS_SYNCODE(obj); + if (outbfmt(hcl, mask, opening_paren[concode]) <= -1) return -1; cur = obj; do @@ -310,7 +331,8 @@ next: if (outbfmt(hcl, mask, " ") <= -1) return -1; } while (1); - if (outbfmt(hcl, mask, ")") <= -1) return -1; + + if (outbfmt(hcl, mask, closing_paren[concode]) <= -1) return -1; break; } diff --git a/lib/read.c b/lib/read.c index 41cb35c..026049e 100644 --- a/lib/read.c +++ b/lib/read.c @@ -89,12 +89,15 @@ typedef enum voca_id_t voca_id_t; enum list_flag_t { - QUOTED = (1 << 0), - DOTTED = (1 << 1), - CLOSED = (1 << 2), - ARRAY = (1 << 3) + QUOTED = (1 << 0), + DOTTED = (1 << 1), + CLOSED = (1 << 2) }; +#define LIST_FLAG_GET_CONCODE(x) (((x) >> 8) & 0xFF) +#define LIST_FLAG_SET_CONCODE(x,type) ((x) = ((x) & ~0xFF00) | ((type) << 8)) + + static int string_to_ooi (hcl_t* hcl, hcl_oocs_t* str, int radixed, hcl_ooi_t* num) { /* it is not a generic conversion function. @@ -219,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 == '|' || is_spacechar(c) || c == HCL_UCI_EOF; + return c == '(' || c == ')' || c == '[' || c == ']' || c == '{' || c == '}' || c == '\"' || c == '#' || c == ';' || c == '|' || is_spacechar(c) || c == HCL_UCI_EOF; } @@ -651,6 +654,29 @@ HCL_DEBUG2 (hcl, "INVALID DIGIT IN RADIXED NUMBER IN [%.*S] \n", (hcl_ooi_t)hcl- return 0; } +static int get_quote_token (hcl_t* hcl) +{ + hcl_ooci_t c; + int radix; + + HCL_ASSERT (hcl, hcl->c->lxc.c == '\''); + + GET_CHAR_TO (hcl, c); + + switch (c) + { + case '(': + ADD_TOKEN_CHAR (hcl, '\''); + ADD_TOKEN_CHAR(hcl, c); + SET_TOKEN_TYPE (hcl, HCL_IOTOK_QPAREN); + + //default: + + } + + return 0; +} + static int get_sharp_token (hcl_t* hcl) { hcl_ooci_t c; @@ -673,8 +699,8 @@ static int get_sharp_token (hcl_t* hcl) * #\xHHHH * unicode * #\uHHHH * #( ) * vector - * #[ ] * list - * #{ } * hash table + * #[ ] * byte array + * #{ } * dictionary * #< > -- xxx */ @@ -813,7 +839,7 @@ HCL_DEBUG2 (hcl, "INVALID CHARACTER LITERAL [%.*S]\n", (hcl_ooi_t)hcl->c->tok.na case '(': /* #( - array literal */ ADD_TOKEN_CHAR (hcl, '#'); ADD_TOKEN_CHAR(hcl, c); - SET_TOKEN_TYPE (hcl, HCL_IOTOK_ARPAREN); + SET_TOKEN_TYPE (hcl, HCL_IOTOK_APAREN); break; case '[': /* #[ - byte array literal */ @@ -822,6 +848,12 @@ HCL_DEBUG2 (hcl, "INVALID CHARACTER LITERAL [%.*S]\n", (hcl_ooi_t)hcl->c->tok.na SET_TOKEN_TYPE (hcl, HCL_IOTOK_BAPAREN); break; + case '{': + ADD_TOKEN_CHAR (hcl, '#'); + ADD_TOKEN_CHAR(hcl, c); + SET_TOKEN_TYPE (hcl, HCL_IOTOK_DPAREN); + break; + default: if (is_delimiter(c)) { @@ -857,7 +889,7 @@ HCL_DEBUG2 (hcl, "INVALID CHARACTER LITERAL [%.*S]\n", (hcl_ooi_t)hcl->c->tok.na } else { -HCL_DEBUG2 (hcl, "INVALID HASH NAME [%.*S]\n", (hcl_ooi_t)hcl->c->tok.name.len, hcl->c->tok.name.ptr); +HCL_DEBUG2 (hcl, "INVALID HASHED LITERAL NAME [%.*S]\n", (hcl_ooi_t)hcl->c->tok.name.len, hcl->c->tok.name.ptr); hcl_setsynerr (hcl, HCL_SYNERR_HASHLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); return -1; } @@ -928,6 +960,16 @@ retry: SET_TOKEN_TYPE (hcl, HCL_IOTOK_RBRACK); break; + case '{': + ADD_TOKEN_CHAR(hcl, c); + SET_TOKEN_TYPE (hcl, HCL_IOTOK_LBRACE); + break; + + case '}': + ADD_TOKEN_CHAR(hcl, c); + SET_TOKEN_TYPE (hcl, HCL_IOTOK_RBRACE); + break; + case '|': ADD_TOKEN_CHAR (hcl, c); SET_TOKEN_TYPE(hcl, HCL_IOTOK_VBAR); @@ -938,17 +980,18 @@ retry: ADD_TOKEN_CHAR(hcl, c); break; - case '\'': - SET_TOKEN_TYPE (hcl, HCL_IOTOK_QUOTE); - ADD_TOKEN_CHAR(hcl, c); - break; + case '\"': - if (get_string (hcl, '\"', '\\', 0, 0) <= -1) return -1; + if (get_string(hcl, '\"', '\\', 0, 0) <= -1) return -1; + break; + + case '\'': + if (get_quote_token(hcl) <= -1) return -1; break; case '#': - if (get_sharp_token (hcl) <= -1) return -1; + if (get_sharp_token(hcl) <= -1) return -1; break; case '+': @@ -1211,10 +1254,10 @@ static HCL_INLINE hcl_oop_t enter_list (hcl_t* hcl, int flagv) * both to be updated in chain_to_list() as items are added. */ -/* TODO: change to push array of 3 cells instead? or don't use the object memory for stack. use compiler's own memory... */ - return (push (hcl, HCL_SMOOI_TO_OOP(flagv)) == HCL_NULL || - push (hcl, hcl->_nil) == HCL_NULL || - push (hcl, hcl->_nil) == HCL_NULL)? HCL_NULL: hcl->c->r.s; +/* TODO: change to push array of 3 cells instead? or don't use the object memory for stack. use compiler's own memory... */ + return (push(hcl, HCL_SMOOI_TO_OOP(flagv)) == HCL_NULL || + push(hcl, hcl->_nil) == HCL_NULL || + push(hcl, hcl->_nil) == HCL_NULL)? HCL_NULL: hcl->c->r.s; } static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv) @@ -1236,6 +1279,7 @@ static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv) fv = HCL_OOP_TO_SMOOI(HCL_CONS_CAR(hcl->c->r.s)); pop (hcl); +#if 0 if (fv & ARRAY) { /* convert a list to an array */ @@ -1253,7 +1297,7 @@ static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv) } hcl_pushtmp (hcl, &head); - arr = (hcl_oop_oop_t)hcl_makearray (hcl, count); + arr = (hcl_oop_oop_t)hcl_makearray(hcl, count); hcl_poptmp (hcl); if (!arr) return HCL_NULL; @@ -1267,6 +1311,7 @@ static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv) head = (hcl_oop_t)arr; } +#endif *oldflagv = fv; if (HCL_IS_NIL(hcl,hcl->c->r.s)) @@ -1285,10 +1330,11 @@ static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv) } /* return the head of the list being left */ + HCL_OBJ_SET_FLAGS_SYNCODE(head, LIST_FLAG_GET_CONCODE(fv)); return head; } -static HCL_INLINE int dot_list (hcl_t* hcl) +static HCL_INLINE int can_dot_list (hcl_t* hcl) { hcl_oop_t cons; int flagv; @@ -1299,11 +1345,11 @@ static HCL_INLINE int dot_list (hcl_t* hcl) cons = HCL_CONS_CDR(HCL_CONS_CDR(hcl->c->r.s)); flagv = HCL_OOP_TO_SMOOI(HCL_CONS_CAR(cons)); - if (flagv & ARRAY) return -1; + if (LIST_FLAG_GET_CONCODE(flagv) != HCL_CONCODE_QLIST) return 0; flagv |= DOTTED; HCL_CONS_CAR(cons) = HCL_SMOOI_TO_OOP(flagv); - return 0; + return 1; } static hcl_oop_t chain_to_list (hcl_t* hcl, hcl_oop_t obj) @@ -1540,6 +1586,7 @@ static int read_object (hcl_t* hcl) switch (TOKEN_TYPE(hcl)) { default: + HCL_DEBUG3 (hcl, "invalid token type encountered %d - %.*js\n", TOKEN_TYPE(hcl), TOKEN_NAME_LEN(hcl), TOKEN_NAME_PTR(hcl)); HCL_ASSERT (hcl, !"should never happen - invalid token type"); hcl_seterrnum (hcl, HCL_EINTERN); return -1; @@ -1560,6 +1607,7 @@ static int read_object (hcl_t* hcl) if (begin_include(hcl) <= -1) return -1; goto redo; +#if 0 case HCL_IOTOK_QUOTE: if (level >= HCL_TYPE_MAX(int)) { @@ -1579,12 +1627,27 @@ static int read_object (hcl_t* hcl) /* read the next token */ GET_TOKEN (hcl); goto redo; +#endif - case HCL_IOTOK_ARPAREN: - flagv = ARRAY; + case HCL_IOTOK_APAREN: + flagv = 0; + LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_ARRAY); + goto start_list; + case HCL_IOTOK_BAPAREN: + flagv = 0; + LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_BYTEARRAY); + goto start_list; + case HCL_IOTOK_QPAREN: + flagv = 0; + LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_QLIST); + goto start_list; + case HCL_IOTOK_DPAREN: + flagv = 0; + LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_DICTIONARY); goto start_list; case HCL_IOTOK_LPAREN: flagv = 0; + LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_XLIST); start_list: if (level >= HCL_TYPE_MAX(int)) { @@ -1595,16 +1658,16 @@ static int read_object (hcl_t* hcl) /* push some data to simulate recursion into * a list literal or an array literal */ - if (enter_list (hcl, flagv) == HCL_NULL) return -1; + if (enter_list(hcl, flagv) == HCL_NULL) return -1; level++; - if (flagv & ARRAY) array_level++; + if (LIST_FLAG_GET_CONCODE(flagv) == HCL_CONCODE_ARRAY) array_level++; /* read the next token */ GET_TOKEN (hcl); goto redo; case HCL_IOTOK_DOT: - if (level <= 0 || is_list_empty (hcl) || dot_list(hcl) <= -1) + if (level <= 0 || is_list_empty(hcl) || !can_dot_list(hcl)) { /* cannot have a period: * 1. at the top level - not inside () @@ -1617,9 +1680,35 @@ static int read_object (hcl_t* hcl) GET_TOKEN (hcl); goto redo; - case HCL_IOTOK_RPAREN: + case HCL_IOTOK_RPAREN: /* xlist (), array #(), qlist '() */ + case HCL_IOTOK_RBRACK: /* byte array #[] */ + case HCL_IOTOK_RBRACE: /* dictionary #{} */ { + static struct + { + int closer; + int synerr; + } req[] = + { + { HCL_IOTOK_RPAREN, HCL_SYNERR_RPAREN }, /* XLIST */ + { HCL_IOTOK_RPAREN, HCL_SYNERR_RPAREN }, /* ARRAY */ + { HCL_IOTOK_RBRACK, HCL_SYNERR_RBRACK }, /* BYTEARRAY */ + { HCL_IOTOK_RBRACE, HCL_SYNERR_RBRACE }, /* DICTIONARY */ + { HCL_IOTOK_RPAREN, HCL_SYNERR_RPAREN } /* QLIST */ + }; + int oldflagv; + int concode; + + concode = LIST_FLAG_GET_CONCODE(flagv); + + if (req[concode].closer != TOKEN_TYPE(hcl)) + { + hcl_setsynerr (hcl, req[concode].synerr, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); + return -1; + } + +#if 0 if ((flagv & QUOTED) || level <= 0) { /* the right parenthesis can never appear while @@ -1642,20 +1731,27 @@ static int read_object (hcl_t* hcl) hcl_setsynerr (hcl, HCL_SYNERR_LPAREN, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); return -1; } +#endif obj = leave_list (hcl, &flagv, &oldflagv); level--; - if (oldflagv & ARRAY) array_level--; + if (LIST_FLAG_GET_CONCODE(oldflagv) == HCL_CONCODE_ARRAY) array_level--; break; } + + +#if 0 case HCL_IOTOK_BAPAREN: if (get_byte_array_literal(hcl, &obj) <= -1) return -1; break; +#endif case HCL_IOTOK_VBAR: /* TODO: think wheter to allow | | inside a quoted list... */ + +/* TODO: revise this part ... */ if (array_level > 0) { hcl_setsynerr (hcl, HCL_SYNERR_VBARBANNED, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); @@ -1710,6 +1806,7 @@ static int read_object (hcl_t* hcl) if (!obj) return -1; +#if 0 /* check if the element is read for a quoted list */ while (flagv & QUOTED) { @@ -1726,15 +1823,17 @@ static int read_object (hcl_t* hcl) /* one level up toward the top */ level--; - if (oldflagv & ARRAY) array_level--; + + if (LIST_FLAG_GET_CONCODE(oldflagv) == HCL_CONCODE_ARRAY) array_level--; } +#endif /* check if we are at the top level */ if (level <= 0) break; /* yes */ /* if not, append the element read into the current list. * if we are not at the top level, we must be in a list */ - if (chain_to_list (hcl, obj) == HCL_NULL) return -1; + if (chain_to_list(hcl, obj) == HCL_NULL) return -1; /* read the next token */ GET_TOKEN (hcl);