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

changed the reader to handle #(), #[], #{}, '() specially

Browse Source
This commit is contained in:
hyung-hwan 2018-02-06 10:16:01 +00:00
parent 380784cf57
commit 7826f0ff06
16 changed files with 463 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile.in
View File

@ -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)

58
configure vendored
View File

@ -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 <string.h>
#if defined(HAVE_SYS_TIME_H)
#include <sys/time.h>
#endif
#if defined(HAVE_TIME_H)
#include <time.h>
#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]];'.

30
configure.ac
View File

@ -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 <string.h>
#if defined(HAVE_SYS_TIME_H)
#include <sys/time.h>
#endif
#if defined(HAVE_TIME_H)
#include <time.h>
#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,,[[]])

2
lib/Makefile.am
View File

@ -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"

2
lib/Makefile.in
View File

@ -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

63
lib/comp.c
View File

@ -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
* (<operator> <operand1> ...) */
@ -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;

4
lib/gc.c
View File

@ -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) },

6
lib/hcl-cfg.h.in
View File

@ -75,6 +75,9 @@
/* Define to 1 if you have the <inttypes.h> 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 <stdlib.h> header file. */
#undef HAVE_STDLIB_H
/* strftime supports %z */
#undef HAVE_STRFTIME_SMALL_Z
/* Define to 1 if you have the <strings.h> header file. */
#undef HAVE_STRINGS_H

27
lib/hcl-prv.h
View File

@ -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_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 */

41
lib/hcl.c
View File

@ -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:

56
lib/hcl.h
View File

@ -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,

22
lib/logfmt.c
View File

@ -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 */
}

22
lib/main.c
View File

@ -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[])
{

33
lib/prim.c
View File

@ -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' } },
};

26
lib/print.c
View File

@ -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;
}

163
lib/read.c
View File

@ -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);