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

yet implementing the new compiler

Browse Source
This commit is contained in:
hyung-hwan 2021-01-19 14:07:42 +00:00
parent e4ae7add8b
commit 16557a970c
8 changed files with 428 additions and 374 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
lib/Makefile.am
View File

@ -66,6 +66,7 @@ libhcl_la_SOURCES = \
bigint.c \
cnode.c \
comp.c \
comp2.c \
debug.c \
decode.c \
dic.c \

28
lib/Makefile.in
View File

@ -151,14 +151,14 @@ am__DEPENDENCIES_5 = $(am__DEPENDENCIES_1) $(am__DEPENDENCIES_2) \
$(am__DEPENDENCIES_3) $(am__DEPENDENCIES_4)
libhcl_la_DEPENDENCIES = $(am__DEPENDENCIES_5) $(am__append_6)
am_libhcl_la_OBJECTS = libhcl_la-bigint.lo libhcl_la-cnode.lo \
libhcl_la-comp.lo libhcl_la-debug.lo libhcl_la-decode.lo \
libhcl_la-dic.lo libhcl_la-err.lo libhcl_la-exec.lo \
libhcl_la-fmt.lo libhcl_la-gc.lo libhcl_la-hcl.lo \
libhcl_la-heap.lo libhcl_la-number.lo libhcl_la-obj.lo \
libhcl_la-opt.lo libhcl_la-prim.lo libhcl_la-print.lo \
libhcl_la-rbt.lo libhcl_la-read.lo libhcl_la-read2.lo \
libhcl_la-sym.lo libhcl_la-utf8.lo libhcl_la-utl.lo \
libhcl_la-xma.lo
libhcl_la-comp.lo libhcl_la-comp2.lo libhcl_la-debug.lo \
libhcl_la-decode.lo libhcl_la-dic.lo libhcl_la-err.lo \
libhcl_la-exec.lo libhcl_la-fmt.lo libhcl_la-gc.lo \
libhcl_la-hcl.lo libhcl_la-heap.lo libhcl_la-number.lo \
libhcl_la-obj.lo libhcl_la-opt.lo libhcl_la-prim.lo \
libhcl_la-print.lo libhcl_la-rbt.lo libhcl_la-read.lo \
libhcl_la-read2.lo libhcl_la-sym.lo libhcl_la-utf8.lo \
libhcl_la-utl.lo libhcl_la-xma.lo
libhcl_la_OBJECTS = $(am_libhcl_la_OBJECTS)
AM_V_lt = $(am__v_lt_@AM_V@)
am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@)
@ -198,6 +198,7 @@ depcomp = $(SHELL) $(top_srcdir)/ac/depcomp
am__maybe_remake_depfiles = depfiles
am__depfiles_remade = ./$(DEPDIR)/libhcl_la-bigint.Plo \
./$(DEPDIR)/libhcl_la-cnode.Plo ./$(DEPDIR)/libhcl_la-comp.Plo \
./$(DEPDIR)/libhcl_la-comp2.Plo \
./$(DEPDIR)/libhcl_la-debug.Plo \
./$(DEPDIR)/libhcl_la-decode.Plo ./$(DEPDIR)/libhcl_la-dic.Plo \
./$(DEPDIR)/libhcl_la-err.Plo ./$(DEPDIR)/libhcl_la-exec.Plo \
@ -440,6 +441,7 @@ libhcl_la_SOURCES = \
bigint.c \
cnode.c \
comp.c \
comp2.c \
debug.c \
decode.c \
dic.c \
@ -578,6 +580,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-bigint.Plo@am__quote@ # am--include-marker
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-cnode.Plo@am__quote@ # am--include-marker
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-comp.Plo@am__quote@ # am--include-marker
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-comp2.Plo@am__quote@ # am--include-marker
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-debug.Plo@am__quote@ # am--include-marker
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-decode.Plo@am__quote@ # am--include-marker
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-dic.Plo@am__quote@ # am--include-marker
@ -657,6 +660,13 @@ libhcl_la-comp.lo: comp.c
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libhcl_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libhcl_la-comp.lo `test -f 'comp.c' || echo '$(srcdir)/'`comp.c
libhcl_la-comp2.lo: comp2.c
@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libhcl_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libhcl_la-comp2.lo -MD -MP -MF $(DEPDIR)/libhcl_la-comp2.Tpo -c -o libhcl_la-comp2.lo `test -f 'comp2.c' || echo '$(srcdir)/'`comp2.c
@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libhcl_la-comp2.Tpo $(DEPDIR)/libhcl_la-comp2.Plo
@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='comp2.c' object='libhcl_la-comp2.lo' libtool=yes @AMDEPBACKSLASH@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libhcl_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libhcl_la-comp2.lo `test -f 'comp2.c' || echo '$(srcdir)/'`comp2.c
libhcl_la-debug.lo: debug.c
@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libhcl_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libhcl_la-debug.lo -MD -MP -MF $(DEPDIR)/libhcl_la-debug.Tpo -c -o libhcl_la-debug.lo `test -f 'debug.c' || echo '$(srcdir)/'`debug.c
@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libhcl_la-debug.Tpo $(DEPDIR)/libhcl_la-debug.Plo
@ -1004,6 +1014,7 @@ distclean: distclean-am
-rm -f ./$(DEPDIR)/libhcl_la-bigint.Plo
-rm -f ./$(DEPDIR)/libhcl_la-cnode.Plo
-rm -f ./$(DEPDIR)/libhcl_la-comp.Plo
-rm -f ./$(DEPDIR)/libhcl_la-comp2.Plo
-rm -f ./$(DEPDIR)/libhcl_la-debug.Plo
-rm -f ./$(DEPDIR)/libhcl_la-decode.Plo
-rm -f ./$(DEPDIR)/libhcl_la-dic.Plo
@ -1080,6 +1091,7 @@ maintainer-clean: maintainer-clean-am
-rm -f ./$(DEPDIR)/libhcl_la-bigint.Plo
-rm -f ./$(DEPDIR)/libhcl_la-cnode.Plo
-rm -f ./$(DEPDIR)/libhcl_la-comp.Plo
-rm -f ./$(DEPDIR)/libhcl_la-comp2.Plo
-rm -f ./$(DEPDIR)/libhcl_la-debug.Plo
-rm -f ./$(DEPDIR)/libhcl_la-decode.Plo
-rm -f ./$(DEPDIR)/libhcl_la-dic.Plo

152
lib/cnode.c
View File

@ -26,119 +26,99 @@
#include "hcl-prv.h"
static hcl_cnode_t* make_cnode (hcl_t* hcl, hcl_cnode_type_t type, const hcl_ioloc_t* loc, hcl_oow_t extra_space)
static hcl_cnode_t* make_cnode (hcl_t* hcl, hcl_cnode_type_t type, const hcl_ioloc_t* loc, const hcl_oocs_t* tok)
{
hcl_cnode_t* cnode;
hcl_oocs_t empty;
hcl_ooch_t dummy;
cnode = hcl_callocmem(hcl, HCL_SIZEOF(*cnode) + extra_space);
if (!tok)
{
empty.ptr = &dummy;
empty.len = 0;
tok = ∅
}
cnode = hcl_callocmem(hcl, HCL_SIZEOF(*cnode) + HCL_SIZEOF(*tok->ptr) * (tok->len + 1));
if (HCL_UNLIKELY(!cnode)) return HCL_NULL;
cnode->type = type;
cnode->loc = *loc;
cnode->cn_type = type;
cnode->cn_loc = *loc;
cnode->cn_tok.ptr = (hcl_ooch_t*)(cnode + 1);
cnode->cn_tok.len = tok->len;
hcl_copy_oochars (cnode->cn_tok.ptr, tok->ptr, tok->len);
cnode->cn_tok.ptr[tok->len] = '\0';
return cnode;
}
hcl_cnode_t* hcl_makecnodenil (hcl_t* hcl, const hcl_ioloc_t* loc)
hcl_cnode_t* hcl_makecnodenil (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok)
{
return make_cnode(hcl, HCL_CNODE_NIL, loc, 0);
return make_cnode(hcl, HCL_CNODE_NIL, loc, tok);
}
hcl_cnode_t* hcl_makecnodetrue (hcl_t* hcl, const hcl_ioloc_t* loc)
hcl_cnode_t* hcl_makecnodetrue (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok)
{
return make_cnode(hcl, HCL_CNODE_TRUE, loc, 0);
return make_cnode(hcl, HCL_CNODE_TRUE, loc, tok);
}
hcl_cnode_t* hcl_makecnodefalse (hcl_t* hcl, const hcl_ioloc_t* loc)
hcl_cnode_t* hcl_makecnodefalse (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok)
{
return make_cnode(hcl, HCL_CNODE_FALSE, loc, 0);
return make_cnode(hcl, HCL_CNODE_FALSE, loc, tok);
}
hcl_cnode_t* hcl_makecnodecharlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t ch)
hcl_cnode_t* hcl_makecnodecharlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok, const hcl_ooch_t v)
{
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_CHARLIT, loc, 0);
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_CHARLIT, loc, tok);
if (HCL_UNLIKELY(!c)) return HCL_NULL;
c->u.charlit.v = ch;
c->u.charlit.v = v;
return c;
}
hcl_cnode_t* hcl_makecnodesymbol (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t* ptr, hcl_oow_t len)
hcl_cnode_t* hcl_makecnodesymbol (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok)
{
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_SYMBOL, loc, HCL_SIZEOF(*ptr) * (len + 1));
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_SYMBOL, loc, tok);
if (HCL_UNLIKELY(!c)) return HCL_NULL;
c->u.symbol.ptr = (hcl_ooch_t*)(c + 1);
c->u.symbol.len = len;
hcl_copy_oochars (c->u.symbol.ptr, ptr, len);
c->u.symbol.ptr[len] = '\0';
c->u.symbol.syncode = hcl_getsyncodebyoocs_noseterr(hcl, tok);
return c;
}
hcl_cnode_t* hcl_makecnodedsymbol (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t* ptr, hcl_oow_t len)
hcl_cnode_t* hcl_makecnodedsymbol (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok)
{
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_DSYMBOL, loc, HCL_SIZEOF(*ptr) * (len + 1));
if (HCL_UNLIKELY(!c)) return HCL_NULL;
c->u.dsymbol.ptr = (hcl_ooch_t*)(c + 1);
c->u.dsymbol.len = len;
hcl_copy_oochars (c->u.dsymbol.ptr, ptr, len);
c->u.dsymbol.ptr[len] = '\0';
return c;
return make_cnode(hcl, HCL_CNODE_DSYMBOL, loc, tok);
}
hcl_cnode_t* hcl_makecnodestrlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t* ptr, hcl_oow_t len)
hcl_cnode_t* hcl_makecnodestrlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok)
{
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_STRLIT, loc, HCL_SIZEOF(*ptr) * (len + 1));
if (HCL_UNLIKELY(!c)) return HCL_NULL;
c->u.strlit.ptr = (hcl_ooch_t*)(c + 1);
c->u.strlit.len = len;
hcl_copy_oochars (c->u.strlit.ptr, ptr, len);
c->u.strlit.ptr[len] = '\0';
return c;
return make_cnode(hcl, HCL_CNODE_STRLIT, loc, tok);
}
hcl_cnode_t* hcl_makecnodenumlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t* ptr, hcl_oow_t len)
hcl_cnode_t* hcl_makecnodenumlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok)
{
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_NUMLIT, loc, HCL_SIZEOF(*ptr) * (len + 1));
if (HCL_UNLIKELY(!c)) return HCL_NULL;
c->u.numlit.ptr = (hcl_ooch_t*)(c + 1);
c->u.numlit.len = len;
hcl_copy_oochars (c->u.numlit.ptr, ptr, len);
c->u.numlit.ptr[len] = '\0';
return c;
return make_cnode(hcl, HCL_CNODE_NUMLIT, loc, tok);
}
hcl_cnode_t* hcl_makecnoderadnumlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t* ptr, hcl_oow_t len)
hcl_cnode_t* hcl_makecnoderadnumlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok)
{
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_RADNUMLIT, loc, HCL_SIZEOF(*ptr) * (len + 1));
if (HCL_UNLIKELY(!c)) return HCL_NULL;
c->u.radnumlit.ptr = (hcl_ooch_t*)(c + 1);
c->u.radnumlit.len = len;
hcl_copy_oochars (c->u.radnumlit.ptr, ptr, len);
c->u.radnumlit.ptr[len] = '\0';
return c;
return make_cnode(hcl, HCL_CNODE_RADNUMLIT, loc, tok);
}
hcl_cnode_t* hcl_makecnodefpdeclit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t* ptr, hcl_oow_t len)
hcl_cnode_t* hcl_makecnodefpdeclit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok)
{
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_FPDECLIT, loc, HCL_SIZEOF(*ptr) * (len + 1));
if (HCL_UNLIKELY(!c)) return HCL_NULL;
c->u.fpdeclit.ptr = (hcl_ooch_t*)(c + 1);
c->u.fpdeclit.len = len;
hcl_copy_oochars (c->u.fpdeclit.ptr, ptr, len);
c->u.fpdeclit.ptr[len] = '\0';
return c;
return make_cnode(hcl, HCL_CNODE_FPDECLIT, loc, tok);
}
hcl_cnode_t* hcl_makecnodesmptrlit (hcl_t* hcl, const hcl_ioloc_t* loc, hcl_oow_t v)
hcl_cnode_t* hcl_makecnodesmptrlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok, hcl_oow_t v)
{
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_SMPTRLIT, loc, 0);
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_SMPTRLIT, loc, tok);
if (HCL_UNLIKELY(!c)) return HCL_NULL;
c->u.smptrlit.v = v;
return c;
}
hcl_cnode_t* hcl_makecnodeerrlit (hcl_t* hcl, const hcl_ioloc_t* loc, hcl_ooi_t v)
hcl_cnode_t* hcl_makecnodeerrlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok, hcl_ooi_t v)
{
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_ERRLIT, loc, 0);
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_ERRLIT, loc, tok);
if (HCL_UNLIKELY(!c)) return HCL_NULL;
c->u.errlit.v = v;
return c;
@ -146,19 +126,18 @@ hcl_cnode_t* hcl_makecnodeerrlit (hcl_t* hcl, const hcl_ioloc_t* loc, hcl_ooi_t
hcl_cnode_t* hcl_makecnodecons (hcl_t* hcl, const hcl_ioloc_t* loc, hcl_cnode_t* car, hcl_cnode_t* cdr)
{
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_CONS, loc, 0);
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_CONS, loc, HCL_NULL);
if (HCL_UNLIKELY(!c)) return HCL_NULL;
c->u.cons.car = car;
c->u.cons.cdr = cdr;
return c;
}
hcl_cnode_t* hcl_makecnodelist (hcl_t* hcl, const hcl_ioloc_t* loc, hcl_concode_t type, hcl_cnode_t* head)
hcl_cnode_t* hcl_makecnodelist (hcl_t* hcl, const hcl_ioloc_t* loc, hcl_concode_t type)
{
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_LIST, loc, 0);
hcl_cnode_t* c = make_cnode(hcl, HCL_CNODE_LIST, loc, HCL_NULL);
if (HCL_UNLIKELY(!c)) return HCL_NULL;
c->u.list.type = type;
c->u.list.head = head;
c->u.list.concode = type;
return c;
}
@ -170,22 +149,8 @@ void hcl_freesinglecnode (hcl_t* hcl, hcl_cnode_t* c)
void hcl_freecnode (hcl_t* hcl, hcl_cnode_t* c)
{
redo:
switch (c->type)
switch (c->cn_type)
{
case HCL_CNODE_LIST:
{
hcl_cnode_t* tmp;
tmp = c->u.list.head;
hcl_freemem (hcl, c);
if (tmp) /* it's not set for an empty list */
{
c = tmp;
goto redo;
}
break;
}
case HCL_CNODE_CONS:
{
hcl_cnode_t* tmp1, * tmp2;
@ -196,7 +161,6 @@ redo:
HCL_ASSERT (hcl, tmp1 != HCL_NULL);
hcl_freemem (hcl, c);
hcl_freecnode (hcl, tmp1); /* TODO: remove recursion? */
if (tmp2)
@ -213,3 +177,21 @@ redo:
break;
}
}
hcl_oow_t hcl_countcnodecons (hcl_t* hcl, hcl_cnode_t* cons)
{
/* this function ignores the last cdr */
hcl_oow_t count = 1;
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(cons));
do
{
cons = HCL_CNODE_CONS_CDR(cons);
if (!cons) break;
count++;
}
while (1);
return count;
}

1
lib/comp.c
View File

@ -804,7 +804,6 @@ static int compile_break (hcl_t* hcl, hcl_oop_t src)
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL,
"redundant cdr in break - %O", src); /* TODO: error location */
return -1;
}
return -1;
}

421
lib/comp2.c
View File

@ -35,12 +35,6 @@ enum
#define TV_BUFFER_ALIGN 256
#define BLK_INFO_BUFFER_ALIGN 128
#define EMIT_BYTE_INSTRUCTION(hcl,code) \
do { if (emit_byte_instruction(hcl, code, HCL_NULL) <= -1) return -1; } while(0)
#define EMIT_SINGLE_PARAM_INSTRUCTION(hcl,code) \
do { if (emit_byte_instruction(hcl, code, HCL_NULL) <= -1) return -1; } while(0)
/* --------------------------------------------
@ -863,33 +857,31 @@ enum
};
/* ========================================================================= */
#if 0
static int compile_and (hcl_t* hcl, hcl_cnode_t* src)
{
hcl_oop_t expr, obj;
hcl_cnode_t* obj, * expr;
HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src));
HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_and);
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src));
HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_AND));
obj = HCL_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, src->loc, HCL_NULL,
"no expression specified in and - %O", src); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(src), HCL_NULL, "no expression specified in and");
return -1;
}
else if (!HCL_IS_CONS(hcl, obj))
else if (!HCL_CNODE_IS_CONS(obj))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, src->loc, HCL_NULL,
"redundant cdr in and - %O", src); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in and");
return -1;
}
/* TODO: optimization - eat away all true expressions */
expr = HCL_CONS_CAR(obj);
obj = HCL_CONS_CDR(obj);
expr = HCL_CNODE_CONS_CAR(obj);
obj = HCL_CNODE_CONS_CDR(obj);
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */
PUSH_SUBCFRAME (hcl, COP_SUBCOMPILE_AND_EXPR, obj); /* 2 */
@ -897,32 +889,30 @@ static int compile_and (hcl_t* hcl, hcl_cnode_t* src)
return 0;
}
static int compile_or (hcl_t* hcl, hcl_oop_t src)
static int compile_or (hcl_t* hcl, hcl_cnode_t* src)
{
hcl_oop_t expr, obj;
hcl_cnode_t* obj, * expr;
HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src));
HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_or);
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src));
HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_OR));
obj = HCL_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 or - %O", src); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(src), HCL_NULL, "no expression specified in or");
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 or - %O", src); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in and");
return -1;
}
/* TODO: optimization - eat away all false expressions */
expr = HCL_CONS_CAR(obj);
obj = HCL_CONS_CDR(obj);
expr = HCL_CNODE_CONS_CAR(obj);
obj = HCL_CNODE_CONS_CDR(obj);
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */
PUSH_SUBCFRAME (hcl, COP_SUBCOMPILE_OR_EXPR, obj); /* 2 */
@ -930,28 +920,25 @@ static int compile_or (hcl_t* hcl, hcl_oop_t src)
return 0;
}
static int compile_break (hcl_t* hcl, hcl_oop_t src)
static int compile_break (hcl_t* hcl, hcl_cnode_t* src)
{
/* (break) */
hcl_oop_t obj;
hcl_cnode_t* obj;
hcl_ooi_t i;
HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src));
HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_break);
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src));
HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_BREAK));
obj = HCL_CONS_CDR(src);
if (!HCL_IS_NIL(hcl,obj))
obj = HCL_CNODE_CONS_CDR(src);
if (obj)
{
if (HCL_IS_CONS(hcl,obj))
if (HCL_CNODE_IS_CONS(obj))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL,
"redundant argument in break - %O", src); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(obj), HCL_NULL, "redundant argument in break");
}
else
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL,
"redundant cdr in break - %O", src); /* TODO: error location */
return -1;
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in break");
}
return -1;
}
@ -985,11 +972,11 @@ static int compile_break (hcl_t* hcl, hcl_oop_t src)
}
}
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BREAK, HCL_NULL, HCL_NULL,
"break outside loop - %O", src); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BREAK, HCL_CNODE_GET_LOC(src), HCL_NULL, "break outside loop");
return -1;
}
#if 0
static int compile_if (hcl_t* hcl, hcl_oop_t src)
{
hcl_oop_t obj, cond;
@ -1488,9 +1475,10 @@ static int compile_while (hcl_t* hcl, hcl_oop_t src, int next_cop)
return 0;
}
#endif
/* ========================================================================= */
static int compile_cons_array_expression (hcl_t* hcl, hcl_oop_t obj)
static int compile_cons_array_expression (hcl_t* hcl, hcl_cnode_t* obj)
{
/* [ ] */
hcl_ooi_t nargs;
@ -1500,11 +1488,11 @@ static int compile_cons_array_expression (hcl_t* hcl, hcl_oop_t obj)
* many operations can be performed without taking GC into account */
SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_ARRAY, HCL_SMOOI_TO_OOP(0));
nargs = hcl_countcons(hcl, 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 array - %O", nargs, obj);
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(obj), HCL_NULL, "too many(%zd) elements into array", nargs);
return -1;
}
@ -1521,7 +1509,7 @@ static int compile_cons_array_expression (hcl_t* hcl, hcl_oop_t obj)
return 0;
}
static int compile_cons_bytearray_expression (hcl_t* hcl, hcl_oop_t obj)
static int compile_cons_bytearray_expression (hcl_t* hcl, hcl_cnode_t* obj)
{
/* #[ ] - e.g. #[1, 2, 3] or #[ 1 2 3 ] */
hcl_ooi_t nargs;
@ -1531,11 +1519,11 @@ static int compile_cons_bytearray_expression (hcl_t* hcl, hcl_oop_t obj)
* many operations can be performed without taking GC into account */
SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_BYTEARRAY, HCL_SMOOI_TO_OOP(0));
nargs = hcl_countcons(hcl, 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 byte-array - %O", nargs, obj);
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(obj), HCL_NULL, "too many(%zd) elements into byte-array", nargs);
return -1;
}
@ -1552,7 +1540,7 @@ static int compile_cons_bytearray_expression (hcl_t* hcl, hcl_oop_t obj)
return 0;
}
static int compile_cons_dic_expression (hcl_t* hcl, hcl_oop_t obj)
static int compile_cons_dic_expression (hcl_t* hcl, hcl_cnode_t* obj)
{
/* { } - e.g. {1:2, 3:4,"abc":def, "hwaddr":"00:00:00:01"} or { 1 2 3 4 } */
hcl_ooi_t nargs;
@ -1560,11 +1548,11 @@ static int compile_cons_dic_expression (hcl_t* hcl, hcl_oop_t obj)
SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_DIC, HCL_SMOOI_TO_OOP(0));
nargs = hcl_countcons(hcl, 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 dictionary - %O", nargs, obj);
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_CNODE_GET_LOC(obj), HCL_NULL, "too many(%zd) elements into dictionary", nargs);
return -1;
}
@ -1579,7 +1567,8 @@ static int compile_cons_dic_expression (hcl_t* hcl, hcl_oop_t obj)
return 0;
}
static int compile_cons_qlist_expression (hcl_t* hcl, hcl_oop_t obj)
#if 0
static int compile_cons_qlist_expression (hcl_t* hcl, hcl_cnode_t* obj)
{
/* #( 1 2 3 )
* #(1 (+ 2 3) 5)
@ -1592,11 +1581,11 @@ static int compile_cons_qlist_expression (hcl_t* hcl, hcl_oop_t obj)
* many operations can be performed without taking GC into account */
SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_DLIST, HCL_SMOOI_TO_OOP(0));
nargs = hcl_countcons(hcl, 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 array - %O", nargs, obj);
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_NULL, HCL_NULL, "too many(%zd) elements into list - %O", nargs, obj);
return -1;
}
@ -1616,7 +1605,6 @@ static int compile_cons_qlist_expression (hcl_t* hcl, hcl_oop_t obj)
static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj)
{
hcl_cnode_t* head;
hcl_cnode_t* car;
int syncode; /* syntax code of the first element */
@ -1628,18 +1616,10 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj)
* 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, obj->type == HCL_CNODE_LIST);
HCL_ASSERT (hcl, obj->u.list.type == HCL_CONCODE_XLIST);
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS_CONCODED(obj, HCL_CONCODE_XLIST));
head = obj->u.list.head;
if (!head)
{
/* empty list */
}
HCL_ASSERT (hcl, head->type == HCL_CNODE_CONS);
car = head->u.cons.car;
if (car->type == HCL_CNODE_SYMBOL && (syncode = hcl_getsyncodebyoocs_noseterr(hcl, &car->u.symbol)) > 0)
car = HCL_CNODE_CONS_CAR(obj);
if (HCL_CNODE_IS_SYMBOL(car) && (syncode = HCL_CNODE_SYMBOL_SYNCODE(car)))
{
switch (syncode)
{
@ -1652,6 +1632,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj)
if (compile_break(hcl, obj) <= -1) return -1;
break;
#if 0
case HCL_SYNCODE_DEFUN:
if (compile_lambda(hcl, obj, 1) <= -1) return -1;
break;
@ -1676,11 +1657,12 @@ 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)) */
@ -1704,23 +1686,23 @@ 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__);
hcl_setsynerrbfmt (hcl, HCL_SYNERR_INTERN, &car->loc, HCL_NULL, "internal error - unknown syncode %d", syncode);
hcl_setsynerrbfmt (hcl, HCL_SYNERR_INTERN, HCL_CNODE_GET_LOC(car), HCL_NULL, "internal error - unknown syncode %d", syncode);
return -1;
}
}
//else if (car->type == HCL_CNODE_SYMBOL || HCL_IS_CONS_CONCODED(hcl,car,HCL_CONCODE_XLIST))
else if (car->type == HCL_CNODE_SYMBOL || (car->type == HCL_CNODE_LIST && car->u.list.type == HCL_CONCODE_XLIST))
else if (HCL_CNODE_IS_SYMBOL(car) || HCL_CNODE_IS_CONS_CONCODED(car, HCL_CONCODE_XLIST))
{
/* normal function call
* (<operator> <operand1> ...) */
hcl_ooi_t nargs;
hcl_ooi_t oldtop;
hcl_cframe2_t* cf;
hcl_oop_t cdr;
hcl_oop_cons_t sdc;
hcl_cnode_t* cdr;
hcl_cnode_t* sdc;
/* NOTE: cframe management functions don't use the object memory.
* many operations can be performed without taking GC into account */
@ -1737,22 +1719,22 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj)
PUSH_CFRAME (hcl, COP_COMPILE_OBJECT, car);
/* compile <operand1> ... etc */
cdr = HCL_CONS_CDR(obj);
cdr = HCL_CNODE_CONS_CDR(obj);
if (HCL_IS_NIL(hcl, cdr))
if (!cdr)
{
nargs = 0;
}
else
{
if (!HCL_IS_NIL(hcl, cdr) && !HCL_IS_CONS(hcl, cdr))
if (!HCL_CNODE_IS_CONS(cdr))
{
/* (funname . 10) */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, "redundant cdr in function call - %O", obj); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(cdr), HCL_CNODE_GET_TOK(cdr), "redundant cdr in function call");
return -1;
}
nargs = hcl_countcons(hcl, cdr);
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);
@ -1760,7 +1742,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj)
}
}
if (HCL_IS_SYMBOL(hcl, car))
if (HCL_CNODE_IS_SYMBOL(car))
{
/* only symbols are added to the system dictionary.
* perform this lookup only if car is a symbol */
@ -1791,7 +1773,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj)
}
else
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_CALLABLE, HCL_NULL, HCL_NULL, "invalid callable %O in function call - %O", car, obj); /* error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_CALLABLE, HCL_CNODE_GET_LOC(car), HCL_CNODE_GET_TOK(car), "invalid callable in function call");
return -1;
}
@ -1802,23 +1784,23 @@ static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_cnode_t* obj)
{
hcl_oow_t index;
HCL_ASSERT (hcl, obj->type == HCL_CNODE_SYMBOL);
HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL(obj));
if (hcl_getsyncodebyoocs_noseterr(hcl, &obj->u.symbol) > 0)
if (hcl_getsyncodebyoocs_noseterr(hcl, HCL_CNODE_GET_TOK(obj)) > 0)
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, &obj->loc, HCL_NULL,
"special symbol not to be used as a variable name - %.*js", obj->u.symbol.len, obj->u.symbol.ptr);
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_CNODE_GET_LOC(obj), HCL_NULL,
"special symbol not to be used as a variable name - %.*js", HCL_CNODE_GET_TOKLEN(obj), HCL_CNODE_GET_TOKPTR(obj));
return -1;
}
/* check if a symbol is a local variable */
if (find_temporary_variable_backward(hcl, &obj->u.symbol, &index) <= -1)
if (find_temporary_variable_backward(hcl, HCL_CNODE_GET_TOK(obj), &index) <= -1)
{
hcl_oop_t sym, cons;
/* TODO: if i require all variables to be declared, this part is not needed and should handle it as an error */
/* TODO: change the scheme... allow declaration??? */
/* global variable */
sym = hcl_makesymbol(hcl, obj->u.symbol.ptr, obj->u.symbol.len);
sym = hcl_makesymbol(hcl, HCL_CNODE_GET_TOKPTR(obj), HCL_CNODE_GET_TOKLEN(obj));
if (HCL_UNLIKELY(!sym)) return -1;
cons = (hcl_oop_t)hcl_getatsysdic(hcl, sym);
@ -1883,7 +1865,7 @@ static hcl_oop_t string_to_num (hcl_t* hcl, hcl_oocs_t* str, const hcl_ioloc_t*
if (*ptr != '#')
{
hcl_setsynerrbfmt(hcl, HCL_SYNERR_RADIX, loc, HCL_NULL, "radixed number not starting with # - %.*js", str->len, str->ptr);
hcl_setsynerrbfmt(hcl, HCL_SYNERR_RADIX, loc, str, "radixed number not starting with #");
return HCL_NULL;
}
ptr++; /* skip '#' */
@ -1893,7 +1875,7 @@ static hcl_oop_t string_to_num (hcl_t* hcl, hcl_oocs_t* str, const hcl_ioloc_t*
else if (*ptr == 'b') base = 2;
else
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_RADIX, loc, HCL_NULL, "invalid radix specifier - %c", *ptr);
hcl_setsynerrbfmt (hcl, HCL_SYNERR_RADIX, loc, str, "invalid radix specifier %c", *ptr);
return HCL_NULL;
}
ptr++;
@ -1940,7 +1922,6 @@ static hcl_oop_t string_to_fpdec (hcl_t* hcl, hcl_oocs_t* str, const hcl_ioloc_t
return hcl_makefpdec(hcl, v, scale);
}
static int compile_object (hcl_t* hcl)
{
hcl_cframe2_t* cf;
@ -1951,18 +1932,18 @@ static int compile_object (hcl_t* hcl)
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_OBJECT);
oprnd = cf->operand;
switch (oprnd->type)
switch (HCL_CNODE_GET_TYPE(oprnd))
{
case HCL_CNODE_NIL:
EMIT_BYTE_INSTRUCTION (hcl, HCL_CODE_PUSH_NIL);
if (emit_byte_instruction(hcl, HCL_CODE_PUSH_NIL, HCL_NULL) <= -1) return -1;
goto done;
case HCL_CNODE_TRUE:
EMIT_BYTE_INSTRUCTION (hcl, HCL_CODE_PUSH_TRUE);
if (emit_byte_instruction(hcl, HCL_CODE_PUSH_TRUE, HCL_NULL) <= -1) return -1;
goto done;
case HCL_CNODE_FALSE:
EMIT_BYTE_INSTRUCTION (hcl, HCL_CODE_PUSH_FALSE);
if (emit_byte_instruction(hcl, HCL_CODE_PUSH_FALSE, HCL_NULL) <= -1) return -1;
goto done;
case HCL_CNODE_CHARLIT:
@ -1970,22 +1951,22 @@ static int compile_object (hcl_t* hcl)
goto literal;
case HCL_CNODE_STRLIT:
lit = hcl_makestring(hcl, oprnd->u.strlit.ptr, oprnd->u.strlit.len, 0);
lit = hcl_makestring(hcl, HCL_CNODE_GET_TOKPTR(oprnd), HCL_CNODE_GET_TOKLEN(oprnd), 0);
if (HCL_UNLIKELY(!lit)) return -1;
goto literal;
case HCL_CNODE_NUMLIT:
lit = string_to_num(hcl, &oprnd->u.numlit, &oprnd->loc, 0);
lit = string_to_num(hcl, HCL_CNODE_GET_TOK(oprnd), HCL_CNODE_GET_LOC(oprnd), 0);
if (HCL_UNLIKELY(!lit)) return -1;
goto literal;
case HCL_CNODE_RADNUMLIT:
lit = string_to_num(hcl, &oprnd->u.radnumlit, &oprnd->loc, 1);
lit = string_to_num(hcl, HCL_CNODE_GET_TOK(oprnd), HCL_CNODE_GET_LOC(oprnd), 1);
if (HCL_UNLIKELY(!lit)) return -1;
goto literal;
case HCL_CNODE_FPDECLIT:
lit = string_to_fpdec(hcl, &oprnd->u.fpdeclit, &oprnd->loc);
lit = string_to_fpdec(hcl, HCL_CNODE_GET_TOK(oprnd), HCL_CNODE_GET_LOC(oprnd));
if (HCL_UNLIKELY(!lit)) return -1;
goto literal;
@ -2002,43 +1983,88 @@ static int compile_object (hcl_t* hcl)
goto done;
#if 0
// TODO: ...
case HCL_CNODE_DSYMBOL:
if (compile_dsymbol(hcl, oprnd) <= -1) return -1;
goto done;
#endif
case HCL_CNODE_LIST:
case HCL_CNODE_CONS:
{
switch (oprnd->u.list.type)
switch (HCL_CNODE_CONS_CONCODE(oprnd))
{
case HCL_CONCODE_XLIST:
if (compile_cons_xlist_expression(hcl, oprnd) <= -1) return -1;
break;
case HCL_CONCODE_ARRAY:
//if (compile_cons_array_expression(hcl, oprnd) <= -1) return -1;
if (compile_cons_array_expression(hcl, oprnd) <= -1) return -1;
break;
case HCL_CONCODE_BYTEARRAY:
//if (compile_cons_bytearray_expression(hcl, oprnd) <= -1) return -1;
if (compile_cons_bytearray_expression(hcl, oprnd) <= -1) return -1;
break;
case HCL_CONCODE_DIC:
//if (compile_cons_dic_expression(hcl, oprnd) <= -1) return -1;
if (compile_cons_dic_expression(hcl, oprnd) <= -1) return -1;
break;
case HCL_CONCODE_QLIST:
#if 0
//if (compile_cons_qlist_expression(hcl, oprnd) <= -1) return -1;
break;
// break;
#else
hcl_setsynerrbfmt (hcl, HCL_SYNERR_INTERN, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "internal error - qlist not implemented");
return -1;
#endif
case HCL_CONCODE_VLIST:
hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARDCLBANNED, &oprnd->loc, HCL_NULL, "variable declaration disallowed");
hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARDCLBANNED, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "variable declaration disallowed");
return -1;
default:
hcl_setsynerrbfmt (hcl, HCL_SYNERR_INTERN, &oprnd->loc, HCL_NULL, "internal error - unknown list type %d ", oprnd->u.list.type);
hcl_setsynerrbfmt (hcl, HCL_SYNERR_INTERN, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "internal error - unknown cons type %d", HCL_CNODE_CONS_CONCODE(oprnd));
return -1;
}
break;
}
case HCL_CNODE_CONS: /* this type can never start a list. it should never be seen here. */
//default:
hcl_setsynerrbfmt (hcl, HCL_SYNERR_INTERN, &oprnd->loc, HCL_NULL, "internal error - unexpected object type %d ", oprnd->type);
case HCL_CNODE_LIST:
{
/* empty list */
switch (HCL_CNODE_LIST_CONCODE(oprnd))
{
case HCL_CONCODE_XLIST:
hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARDCLBANNED, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "empty executable list");
return -1;
case HCL_CONCODE_ARRAY:
if (emit_single_param_instruction(hcl, HCL_CODE_MAKE_ARRAY, 0) <= -1) return -1;
goto done;
case HCL_CONCODE_BYTEARRAY:
if (emit_single_param_instruction(hcl, HCL_CODE_MAKE_BYTEARRAY, 0) <= -1) return -1;
goto done;
case HCL_CONCODE_DIC:
if (emit_single_param_instruction(hcl, HCL_CODE_MAKE_DIC, 16) <= -1) return -1;
goto done;
case HCL_CONCODE_QLIST:
if (emit_byte_instruction(hcl, HCL_CODE_PUSH_NIL, HCL_NULL) <= -1) return -1;
goto done;
case HCL_CONCODE_VLIST:
hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARDCLBANNED, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "variable declaration disallowed");
return -1;
default:
hcl_setsynerrbfmt (hcl, HCL_SYNERR_INTERN, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "internal error - unknown list type %d", HCL_CNODE_CONS_CONCODE(oprnd));
return -1;
}
break;
}
default:
hcl_setsynerrbfmt (hcl, HCL_SYNERR_INTERN, HCL_CNODE_GET_LOC(oprnd), HCL_CNODE_GET_TOK(oprnd), "internal error - unexpected object type %d", HCL_CNODE_GET_TYPE(oprnd));
return -1;
}
@ -2055,7 +2081,7 @@ done:
static int compile_object_list (hcl_t* hcl)
{
hcl_cframe2_t* cf;
hcl_oop_t coprnd;
hcl_cnode_t* oprnd;
int cop;
cf = GET_TOP_CFRAME(hcl);
@ -2066,68 +2092,66 @@ static int compile_object_list (hcl_t* hcl)
cf->opcode == COP_COMPILE_OBJECT_LIST_TAIL);
cop = cf->opcode;
coprnd = cf->operand;
oprnd = cf->operand;
if (HCL_IS_NIL(hcl, coprnd))
if (!oprnd)
{
POP_CFRAME (hcl);
}
else
{
hcl_oop_t car, cdr;
hcl_cnode_t* car, * cdr;
if (cop != COP_COMPILE_ARGUMENT_LIST)
{
/* eliminate unnecessary non-function calls. keep the last one */
while (HCL_IS_CONS(hcl, coprnd))
while (HCL_CNODE_IS_CONS(oprnd))
{
cdr = HCL_CONS_CDR(coprnd);
if (HCL_IS_NIL(hcl,cdr)) break; /* keep the last one */
cdr = HCL_CNODE_CONS_CDR(oprnd);
if (!cdr) break; /* keep the last one */
if (HCL_IS_CONS(hcl, cdr))
if (HCL_CNODE_IS_CONS(cdr))
{
/* look ahead */
/* keep the last one before elif or else... */
car = HCL_CONS_CAR(cdr);
if (HCL_IS_SYMBOL(hcl, car) && HCL_OBJ_GET_FLAGS_SYNCODE(car)) break;
car = HCL_CNODE_CONS_CAR(cdr);
if (HCL_CNODE_IS_SYMBOL(car) && HCL_CNODE_SYMBOL_SYNCODE(car)) break;
}
car = HCL_CONS_CAR(coprnd);
if (HCL_IS_CONS(hcl, car) || (HCL_IS_SYMBOL(hcl, car) && HCL_OBJ_GET_FLAGS_SYNCODE(car))) break;
coprnd = cdr;
car = HCL_CNODE_CONS_CAR(oprnd);
if (HCL_CNODE_IS_CONS(car) || (HCL_CNODE_IS_SYMBOL(car) && HCL_CNODE_SYMBOL_SYNCODE(car))) break;
oprnd = cdr;
}
HCL_ASSERT (hcl, !HCL_IS_NIL(hcl, coprnd));
HCL_ASSERT (hcl, oprnd != HCL_NULL);
}
if (!HCL_IS_CONS(hcl, coprnd))
if (!HCL_CNODE_IS_CONS(oprnd))
{
hcl_setsynerrbfmt (
hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL,
"redundant cdr in the object list - %O", coprnd); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(oprnd), HCL_CNODE_GET_TOK(oprnd), "redundant cdr in the object list");
return -1;
}
car = HCL_CONS_CAR(coprnd);
cdr = HCL_CONS_CDR(coprnd);
car = HCL_CNODE_CONS_CAR(oprnd);
cdr = HCL_CNODE_CONS_CDR(oprnd);
if (cop == COP_COMPILE_IF_OBJECT_LIST || cop == COP_COMPILE_IF_OBJECT_LIST_TAIL)
{
if (car == hcl->_elif)
if (HCL_CNODE_IS_SYMBOL_SYNCODED(car, HCL_SYNCODE_ELIF))
{
SWITCH_TOP_CFRAME (hcl, COP_SUBCOMPILE_ELIF, coprnd);
SWITCH_TOP_CFRAME (hcl, COP_SUBCOMPILE_ELIF, oprnd);
goto done;
}
else if (car == hcl->_else)
else if (HCL_CNODE_IS_SYMBOL_SYNCODED(car, HCL_SYNCODE_ELSE))
{
SWITCH_TOP_CFRAME (hcl, COP_SUBCOMPILE_ELSE, coprnd);
SWITCH_TOP_CFRAME (hcl, COP_SUBCOMPILE_ELSE, oprnd);
goto done;
}
}
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car);
if (!HCL_IS_NIL(hcl, cdr))
if (cdr)
{
/* there is a next statement to compile
*
@ -2152,7 +2176,7 @@ static int compile_object_list (hcl_t* hcl)
{
/* emit POP_STACKTOP before evaluating the second objects
* and onwards. this goes above COP_COMPILE_OBJECT */
PUSH_CFRAME (hcl, COP_EMIT_POP_STACKTOP, hcl->_nil);
PUSH_CFRAME (hcl, COP_EMIT_POP_STACKTOP, HCL_NULL);
}
}
@ -2163,37 +2187,35 @@ done:
static int compile_array_list (hcl_t* hcl)
{
hcl_cframe2_t* cf;
hcl_oop_t coprnd;
hcl_cnode_t* oprnd;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_ARRAY_LIST);
coprnd = cf->operand;
oprnd = cf->operand;
if (HCL_IS_NIL(hcl, coprnd))
if (!oprnd)
{
POP_CFRAME (hcl);
}
else
{
hcl_oop_t car, cdr;
hcl_cnode_t* car, * cdr;
hcl_ooi_t oldidx;
if (!HCL_IS_CONS(hcl, coprnd))
if (!HCL_CNODE_IS_CONS(oprnd))
{
hcl_setsynerrbfmt (
hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL,
"redundant cdr in the array list - %O", coprnd); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(oprnd), HCL_CNODE_GET_TOK(oprnd), "redundant cdr in the array list");
return -1;
}
car = HCL_CONS_CAR(coprnd);
cdr = HCL_CONS_CDR(coprnd);
car = HCL_CNODE_CONS_CAR(oprnd);
cdr = HCL_CNODE_CONS_CDR(oprnd);
oldidx = cf->u.array_list.index;
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car);
if (!HCL_IS_NIL(hcl, cdr))
if (cdr)
{
PUSH_SUBCFRAME (hcl, COP_COMPILE_ARRAY_LIST, cdr);
cf = GET_SUBCFRAME(hcl);
@ -2210,37 +2232,35 @@ static int compile_array_list (hcl_t* hcl)
static int compile_bytearray_list (hcl_t* hcl)
{
hcl_cframe2_t* cf;
hcl_oop_t coprnd;
hcl_cnode_t* oprnd;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_BYTEARRAY_LIST);
coprnd = cf->operand;
oprnd = cf->operand;
if (HCL_IS_NIL(hcl, coprnd))
if (!oprnd)
{
POP_CFRAME (hcl);
}
else
{
hcl_oop_t car, cdr;
hcl_cnode_t* car, * cdr;
hcl_ooi_t oldidx;
if (!HCL_IS_CONS(hcl, coprnd))
if (!HCL_CNODE_IS_CONS(oprnd))
{
hcl_setsynerrbfmt (
hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL,
"redundant cdr in the byte-array list - %O", coprnd); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(oprnd), HCL_CNODE_GET_TOK(oprnd), "redundant cdr in the byte-array list");
return -1;
}
car = HCL_CONS_CAR(coprnd);
cdr = HCL_CONS_CDR(coprnd);
car = HCL_CNODE_CONS_CAR(oprnd);
cdr = HCL_CNODE_CONS_CDR(oprnd);
oldidx = cf->u.bytearray_list.index;
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car);
if (!HCL_IS_NIL(hcl, cdr))
if (cdr)
{
PUSH_SUBCFRAME (hcl, COP_COMPILE_BYTEARRAY_LIST, cdr);
cf = GET_SUBCFRAME(hcl);
@ -2257,45 +2277,41 @@ static int compile_bytearray_list (hcl_t* hcl)
static int compile_dic_list (hcl_t* hcl)
{
hcl_cframe2_t* cf;
hcl_oop_t coprnd;
hcl_cnode_t* oprnd;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_DIC_LIST);
coprnd = cf->operand;
oprnd = cf->operand;
if (HCL_IS_NIL(hcl, coprnd))
if (!oprnd)
{
POP_CFRAME (hcl);
}
else
{
hcl_oop_t car, cdr, cadr, cddr;
hcl_cnode_t* car, * cdr, * cadr, * cddr;
if (!HCL_IS_CONS(hcl, coprnd))
if (!HCL_CNODE_IS_CONS(oprnd))
{
hcl_setsynerrbfmt (
hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL,
"redundant cdr in the dictionary list - %O", coprnd); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(oprnd), HCL_CNODE_GET_TOK(oprnd), "redundant cdr in the dictionary list");
return -1;
}
car = HCL_CONS_CAR(coprnd);
cdr = HCL_CONS_CDR(coprnd);
car = HCL_CNODE_CONS_CAR(oprnd);
cdr = HCL_CNODE_CONS_CDR(oprnd);
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car);
if (HCL_IS_NIL(hcl, cdr))
if (!cdr)
{
hcl_setsynerrbfmt (
hcl, HCL_SYNERR_UNBALKV, HCL_NULL, HCL_NULL,
"no value for key %O", car);
hcl_setsynerrbfmt (hcl, HCL_SYNERR_UNBALKV, HCL_CNODE_GET_LOC(car), HCL_NULL, "no value for key %.*js", HCL_CNODE_GET_TOKLEN(car), HCL_CNODE_GET_TOKPTR(car));
return -1;
}
cadr = HCL_CONS_CAR(cdr);
cddr = HCL_CONS_CDR(cdr);
cadr = HCL_CNODE_CONS_CAR(cdr);
cddr = HCL_CNODE_CONS_CDR(cdr);
if (!HCL_IS_NIL(hcl, cddr))
if (cddr)
{
PUSH_SUBCFRAME (hcl, COP_COMPILE_DIC_LIST, cddr);
}
@ -2310,37 +2326,39 @@ static int compile_dic_list (hcl_t* hcl)
static int compile_qlist (hcl_t* hcl)
{
hcl_cframe2_t* cf;
hcl_oop_t coprnd;
hcl_cnode_t* oprnd;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_QLIST);
coprnd = cf->operand;
oprnd = cf->operand;
if (HCL_IS_NIL(hcl, coprnd))
if (!oprnd)
{
POP_CFRAME (hcl);
}
else
{
hcl_oop_t car, cdr;
hcl_cnode_t* car, * cdr;
hcl_ooi_t oldidx;
if (!HCL_IS_CONS(hcl, coprnd))
// TODO: correct this function in pair with compile_cons_qlist_expression()
#if 0
//qlist allows non-nil cdr...
if (!HCL_CNODE_IS_CONS(oprnd))
{
hcl_setsynerrbfmt (
hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL,
"redundant cdr in the qlist list - %O", coprnd); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(oprnd), HCL_CNODE_GET_TOK(oprnd), "redundant cdr in the q-list");
return -1;
}
#endif
car = HCL_CONS_CAR(coprnd);
cdr = HCL_CONS_CDR(coprnd);
car = HCL_CNODE_CONS_CAR(oprnd);
cdr = HCL_CNODE_CONS_CDR(oprnd);
/*oldidx = cf->u.qlist.index;*/
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car);
if (!HCL_IS_NIL(hcl, cdr))
if (!cdr)
{
PUSH_SUBCFRAME (hcl, COP_COMPILE_QLIST, cdr);
cf = GET_SUBCFRAME(hcl);
@ -2479,7 +2497,7 @@ static HCL_INLINE int subcompile_else (hcl_t* hcl)
static HCL_INLINE int subcompile_and_expr (hcl_t* hcl)
{
hcl_oop_t obj, expr;
hcl_cnode_t* obj, * expr;
hcl_cframe2_t* cf;
hcl_ooi_t jump_inst_pos;
@ -2489,16 +2507,15 @@ static HCL_INLINE int subcompile_and_expr (hcl_t* hcl)
obj = cf->operand;
/* TODO: optimization - eat away all true expressions */
if (HCL_IS_NIL(hcl, obj))
if (!obj)
{
/* no more */
POP_CFRAME (hcl);
return 0;
}
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 and - %O", obj); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in and");
return -1;
}
@ -2508,8 +2525,8 @@ static HCL_INLINE int subcompile_and_expr (hcl_t* hcl)
if (emit_single_param_instruction(hcl, HCL_CODE_JUMP_FORWARD_IF_FALSE, MAX_CODE_JUMP) <= -1) return -1;
if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1;
expr = HCL_CONS_CAR(obj);
obj = HCL_CONS_CDR(obj);
expr = HCL_CNODE_CONS_CAR(obj);
obj = HCL_CNODE_CONS_CDR(obj);
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */
@ -2546,7 +2563,7 @@ static HCL_INLINE int post_and_expr (hcl_t* hcl)
static HCL_INLINE int subcompile_or_expr (hcl_t* hcl)
{
hcl_oop_t obj, expr;
hcl_cnode_t* obj, * expr;
hcl_cframe2_t* cf;
hcl_ooi_t jump_inst_pos;
@ -2556,16 +2573,15 @@ static HCL_INLINE int subcompile_or_expr (hcl_t* hcl)
obj = cf->operand;
/* TODO: optimization - eat away all false expressions */
if (HCL_IS_NIL(hcl, obj))
if (!obj)
{
/* no more */
POP_CFRAME (hcl);
return 0;
}
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 or - %O", obj); /* TODO: error location */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in or");
return -1;
}
@ -2575,8 +2591,8 @@ static HCL_INLINE int subcompile_or_expr (hcl_t* hcl)
if (emit_single_param_instruction(hcl, HCL_CODE_JUMP_FORWARD_IF_TRUE, MAX_CODE_JUMP) <= -1) return -1;
if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1;
expr = HCL_CONS_CAR(obj);
obj = HCL_CONS_CDR(obj);
expr = HCL_CNODE_CONS_CAR(obj);
obj = HCL_CNODE_CONS_CDR(obj);
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */
@ -3007,8 +3023,7 @@ static HCL_INLINE int emit_set (hcl_t* hcl)
hcl_oow_t index;
hcl_oop_t cons;
//HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, cf->operand));
HCL_ASSERT (hcl, cf->operand->type == HCL_CNODE_SYMBOL);
HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL(cf->operand));
/* TODO: make a symbol now */
cons = (hcl_oop_t)hcl_getatsysdic(hcl, cf->operand);

22
lib/gc.c
View File

@ -840,6 +840,7 @@ int hcl_ignite (hcl_t* hcl)
}
int hcl_getsyncodebyoocs_noseterr (hcl_t* hcl, const hcl_oocs_t* name)
{
hcl_oow_t i;
@ -850,3 +851,24 @@ int hcl_getsyncodebyoocs_noseterr (hcl_t* hcl, const hcl_oocs_t* name)
}
return 0; /* 0 indicates no syntax code found */
}
int hcl_getsyncode_noseterr (hcl_t* hcl, const hcl_ooch_t* ptr, const hcl_oow_t len)
{
hcl_oow_t i;
for (i = 0; i < HCL_COUNTOF(syminfo); i++)
{
if (hcl_comp_oochars(syminfo[i].ptr, syminfo[i].len, ptr, len) == 0)
return syminfo[i].syncode;
}
return 0; /* 0 indicates no syntax code found */
}
const hcl_ooch_t* hcl_getsyncodename_noseterr (hcl_t* hcl, hcl_syncode_t syncode)
{
hcl_oow_t i;
for (i = 0; i < HCL_COUNTOF(syminfo); i++)
{
if (syncode == syminfo[i].syncode) return syminfo[i].ptr;
}
return HCL_NULL;
}

96
lib/hcl-prv.h
View File

@ -196,33 +196,38 @@ enum hcl_cnode_type_t
HCL_CNODE_TRUE,
HCL_CNODE_FALSE,
#if 0
HCL_CNODE_AND,
HCL_CNODE_BREAK,
HCL_CNODE_DEFUN,
HCL_CNODE_DO,
HCL_CNODE_ELIF,
HCL_CNODE_ELSE,
HCL_CNODE_IF,
HCL_CNODE_LAMBDA,
HCL_CNODE_OR,
HCL_CNODE_RETURN,
HCL_CNODE_RETURN_FROM_HOME,
HCL_CNODE_SET,
HCL_CNODE_UNTIL,
HCL_CNODE_WHILE,
#endif
HCL_CNODE_CONS,
HCL_CNODE_LIST
};
typedef enum hcl_cnode_type_t hcl_cnode_type_t;
#define HCL_CNODE_GET_TYPE(x) ((x)->cn_type)
#define HCL_CNODE_GET_LOC(x) (&(x)->cn_loc)
#define HCL_CNODE_GET_TOK(x) (&(x)->cn_tok)
#define HCL_CNODE_GET_TOKPTR(x) ((x)->cn_tok.ptr)
#define HCL_CNODE_GET_TOKLEN(x) ((x)->cn_tok.len)
#define HCL_CNODE_IS_SYMBOL(x) ((x)->cn_type == HCL_CNODE_SYMBOL)
#define HCL_CNODE_IS_SYMBOL_SYNCODED(x, code) ((x)->cn_type == HCL_CNODE_SYMBOL && (x)->u.symbol.syncode == (code))
#define HCL_CNODE_SYMBOL_SYNCODE(x) ((x)->u.symbol.syncode)
#define HCL_CNODE_IS_CONS(x) ((x)->cn_type == HCL_CNODE_CONS)
#define HCL_CNODE_IS_CONS_CONCODED(x, code) ((x)->cn_type == HCL_CNODE_CONS && (x)->u.cons.concode == (code))
#define HCL_CNODE_CONS_CONCODE(x) ((x)->u.cons.concode)
#define HCL_CNODE_CONS_CAR(x) ((x)->u.cons.car)
#define HCL_CNODE_CONS_CDR(x) ((x)->u.cons.cdr)
#define HCL_CNODE_IS_LIST(x) ((x)->cn_type == HCL_CNODE_LIST)
#define HCL_CNODE_IS_LIST_CONCODED(x) ((x)->cn_type == HCL_CNODE_LIST && (x)->u.list.concode == (code))
#define HCL_CNODE_LIST_CONCODE(x) ((x)->u.list.concode)
/* NOTE: hcl_cnode_t used by the built-in compiler is not an OOP object */
struct hcl_cnode_t
{
hcl_cnode_type_t type;
hcl_ioloc_t loc;
hcl_cnode_type_t cn_type;
hcl_ioloc_t cn_loc;
hcl_oocs_t cn_tok;
union
{
@ -231,12 +236,10 @@ struct hcl_cnode_t
hcl_ooch_t v;
} charlit;
hcl_oocs_t symbol;
hcl_oocs_t dsymbol;
hcl_oocs_t strlit;
hcl_oocs_t numlit;
hcl_oocs_t radnumlit;
hcl_oocs_t fpdeclit;
struct
{
hcl_syncode_t syncode; /* special if non-zero */
} symbol;
struct
{
@ -248,13 +251,13 @@ struct hcl_cnode_t
} errlit;
struct
{
hcl_concode_t concode;
hcl_cnode_t* car;
hcl_cnode_t* cdr;
} cons;
struct
{
hcl_cnode_t* head; /* its type must be HCL_CNODE_CONS */
hcl_concode_t type;
hcl_concode_t concode;
} list;
} u;
};
@ -955,6 +958,18 @@ int hcl_getsyncodebyoocs_noseterr (
const hcl_oocs_t* name
);
int hcl_getsyncode_noseterr (
hcl_t* hcl,
const hcl_ooch_t* ptr,
const hcl_oow_t len
);
const hcl_ooch_t* hcl_getsyncodename_noseterr (
hcl_t* hcl,
hcl_syncode_t syncode
);
/* ========================================================================= */
/* utf8.c */
/* ========================================================================= */
@ -1307,22 +1322,23 @@ int hcl_emitbyteinstruction (
/* ========================================================================= */
/* cnode.c */
/* ========================================================================= */
hcl_cnode_t* hcl_makecnodenil (hcl_t* hcl, const hcl_ioloc_t* loc);
hcl_cnode_t* hcl_makecnodetrue (hcl_t* hcl, const hcl_ioloc_t* loc);
hcl_cnode_t* hcl_makecnodefalse (hcl_t* hcl, const hcl_ioloc_t* loc);
hcl_cnode_t* hcl_makecnodecharlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t ch);
hcl_cnode_t* hcl_makecnodesymbol (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t* ptr, hcl_oow_t len);
hcl_cnode_t* hcl_makecnodedsymbol (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t* ptr, hcl_oow_t len);
hcl_cnode_t* hcl_makecnodestrlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t* ptr, hcl_oow_t len);
hcl_cnode_t* hcl_makecnodenumlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t* ptr, hcl_oow_t len);
hcl_cnode_t* hcl_makecnoderadnumlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t* ptr, hcl_oow_t len);
hcl_cnode_t* hcl_makecnodefpdeclit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_ooch_t* ptr, hcl_oow_t len);
hcl_cnode_t* hcl_makecnodesmptrlit (hcl_t* hcl, const hcl_ioloc_t* loc, hcl_oow_t v);
hcl_cnode_t* hcl_makecnodeerrlit (hcl_t* hcl, const hcl_ioloc_t* loc, hcl_ooi_t v);
hcl_cnode_t* hcl_makecnodenil (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok);
hcl_cnode_t* hcl_makecnodetrue (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok);
hcl_cnode_t* hcl_makecnodefalse (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok);
hcl_cnode_t* hcl_makecnodecharlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok, const hcl_ooch_t v);
hcl_cnode_t* hcl_makecnodesymbol (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok);
hcl_cnode_t* hcl_makecnodedsymbol (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok);
hcl_cnode_t* hcl_makecnodestrlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok);
hcl_cnode_t* hcl_makecnodenumlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok);
hcl_cnode_t* hcl_makecnoderadnumlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok);
hcl_cnode_t* hcl_makecnodefpdeclit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok);
hcl_cnode_t* hcl_makecnodesmptrlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok, hcl_oow_t v);
hcl_cnode_t* hcl_makecnodeerrlit (hcl_t* hcl, const hcl_ioloc_t* loc, const hcl_oocs_t* tok, hcl_ooi_t v);
hcl_cnode_t* hcl_makecnodecons (hcl_t* hcl, const hcl_ioloc_t* loc, hcl_cnode_t* car, hcl_cnode_t* cdr);
hcl_cnode_t* hcl_makecnodelist (hcl_t* hcl, const hcl_ioloc_t* loc, hcl_concode_t type, hcl_cnode_t* head);
hcl_cnode_t* hcl_makecnodelist (hcl_t* hcl, const hcl_ioloc_t* loc, hcl_concode_t type);
void hcl_freesinglecnode (hcl_t* hcl, hcl_cnode_t* c);
void hcl_freecnode (hcl_t* hcl, hcl_cnode_t* c);
hcl_oow_t hcl_countcnodecons (hcl_t* hcl, hcl_cnode_t* cons);
#if defined(__cplusplus)
}

79
lib/read2.c
View File

@ -1461,10 +1461,15 @@ static HCL_INLINE hcl_cnode_t* leave_list (hcl_t* hcl, int* flagv, int* oldflagv
* (lambda () ...) is equivalent to (lambda #nil ...)
* (defun x() ...) */
/* [NOTE] the head is NULL if the list is empty */
list = hcl_makecnodelist(hcl, &loc, concode, head);
if (HCL_UNLIKELY(!list)) hcl_freecnode (hcl, head);
return list;
if (head)
{
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(head));
HCL_CNODE_CONS_CONCODE(head) = concode;
return head;
}
/* the list is empty */
return hcl_makecnodelist(hcl, &loc, concode);
}
static HCL_INLINE int can_dot_list (hcl_t* hcl)
@ -1569,7 +1574,7 @@ static int chain_to_list (hcl_t* hcl, hcl_cnode_t* obj)
/* chain the object via 'cdr' of the tail cell */
tail = rstl->tail;
HCL_ASSERT (hcl, tail != HCL_NULL);
HCL_ASSERT (hcl, tail->type == HCL_CNODE_CONS);
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(tail));
tail->u.cons.cdr = obj;
/* update the flag to CLOSED so that you can have more than
@ -1591,7 +1596,7 @@ static int chain_to_list (hcl_t* hcl, hcl_cnode_t* obj)
return -1;
}
cons = hcl_makecnodecons(hcl, &obj->loc, obj, HCL_NULL);
cons = hcl_makecnodecons(hcl, HCL_CNODE_GET_LOC(obj), obj, HCL_NULL);
if (HCL_UNLIKELY(!cons)) return -1;
if (rstl->count <= 0)
@ -1610,7 +1615,7 @@ static int chain_to_list (hcl_t* hcl, hcl_cnode_t* obj)
/* the new cons cell is not the first element.
* append it to the list */
tail = rstl->tail;
HCL_ASSERT (hcl, tail->type == HCL_CNODE_CONS);
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(tail));
tail->u.cons.cdr = cons;
rstl->tail = cons;
}
@ -1624,13 +1629,13 @@ static int chain_to_list (hcl_t* hcl, hcl_cnode_t* obj)
static hcl_cnode_t* read_vlist (hcl_t* hcl)
{
hcl_cnode_t* l;
hcl_cnode_t* ve;
hcl_cnode_t* vh, * ve;
hcl_ioloc_t start_loc;
HCL_ASSERT (hcl, TOKEN_TYPE(hcl) == HCL_IOTOK_VBAR);
l = hcl_makecnodelist(hcl, TOKEN_LOC(hcl), HCL_CONCODE_VLIST, HCL_NULL);
if (HCL_UNLIKELY(!l)) goto oops;
vh = ve = HCL_NULL;
start_loc = *TOKEN_LOC(hcl);
GET_TOKEN_WITH_GOTO(hcl, oops);
@ -1638,7 +1643,7 @@ static hcl_cnode_t* read_vlist (hcl_t* hcl)
{
hcl_cnode_t* sym, * cons;
sym = hcl_makecnodesymbol(hcl, TOKEN_LOC(hcl), TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl));
sym = hcl_makecnodesymbol(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
if (HCL_UNLIKELY(!sym)) goto oops;
#if 0
@ -1651,21 +1656,21 @@ static hcl_cnode_t* read_vlist (hcl_t* hcl)
/* TODO: exclude special symbols.... or do the above check in the compiler code?? */
#endif
cons = hcl_makecnodecons(hcl, &sym->loc, sym, HCL_NULL);
cons = hcl_makecnodecons(hcl, HCL_CNODE_GET_LOC(sym), sym, HCL_NULL);
if (HCL_UNLIKELY(!cons))
{
hcl_freesinglecnode (hcl, sym); /* manual disposal because sym is not chained to the list */
goto oops;
}
if (!l->u.list.head)
if (!vh)
{
l->u.list.head = cons;
vh = cons;
ve = cons;
}
else
{
HCL_ASSERT (hcl, ve->type == HCL_CNODE_CONS);
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(ve));
ve->u.cons.cdr = cons;
ve = cons;
}
@ -1679,10 +1684,17 @@ static hcl_cnode_t* read_vlist (hcl_t* hcl)
goto oops;
}
return l;
if (vh)
{
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(vh));
HCL_CNODE_CONS_CONCODE(vh) = HCL_CONCODE_VLIST;
return vh;
}
return hcl_makecnodelist(hcl, &start_loc, HCL_CONCODE_VLIST);
oops:
if (l) hcl_freecnode (hcl, l);
if (vh) hcl_freecnode (hcl, vh);
return HCL_NULL;
}
@ -1735,14 +1747,9 @@ static hcl_cnode_t* read_object (hcl_t* hcl)
goto start_list;
case HCL_IOTOK_QLPAREN: /* #() */
#if 1
hcl_setsynerr (hcl, HCL_SYNERR_ILTOK, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
goto oops;
#else
flagv = 0;
LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_QLIST);
goto start_list;
#endif
case HCL_IOTOK_LPAREN: /* () */
flagv = 0;
@ -1771,7 +1778,7 @@ static hcl_cnode_t* read_object (hcl_t* hcl)
/* cannot have a period:
* 1. at the top level - not inside ()
* 2. at the beginning of a list
* 3. inside an #(), #[], #{}, () */
* 3. inside an array, byte-array, dictionary, xlist */
hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, TOKEN_LOC(hcl), HCL_NULL);
goto oops;
}
@ -1876,15 +1883,15 @@ static hcl_cnode_t* read_object (hcl_t* hcl)
break;
case HCL_IOTOK_NIL:
obj = hcl_makecnodenil(hcl, TOKEN_LOC(hcl));
obj = hcl_makecnodenil(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
break;
case HCL_IOTOK_TRUE:
obj = hcl_makecnodetrue(hcl, TOKEN_LOC(hcl));
obj = hcl_makecnodetrue(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
break;
case HCL_IOTOK_FALSE:
obj = hcl_makecnodefalse(hcl, TOKEN_LOC(hcl));
obj = hcl_makecnodefalse(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
break;
case HCL_IOTOK_SMPTRLIT:
@ -1905,7 +1912,7 @@ static hcl_cnode_t* read_object (hcl_t* hcl)
goto oops;
}
obj = hcl_makecnodesmptrlit(hcl, TOKEN_LOC(hcl), v);
obj = hcl_makecnodesmptrlit(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl), v);
break;
}
@ -1927,24 +1934,24 @@ static hcl_cnode_t* read_object (hcl_t* hcl)
}
}
obj = hcl_makecnodeerrlit(hcl, TOKEN_LOC(hcl), v);
obj = hcl_makecnodeerrlit(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl), v);
break;
}
case HCL_IOTOK_CHARLIT:
obj = hcl_makecnodecharlit(hcl, TOKEN_LOC(hcl), TOKEN_NAME_CHAR(hcl, 0));
obj = hcl_makecnodecharlit(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl), TOKEN_NAME_CHAR(hcl, 0));
break;
case HCL_IOTOK_NUMLIT:
obj = hcl_makecnodenumlit(hcl, TOKEN_LOC(hcl), TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl));
obj = hcl_makecnodenumlit(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
break;
case HCL_IOTOK_RADNUMLIT:
obj = hcl_makecnoderadnumlit(hcl, TOKEN_LOC(hcl), TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl));
obj = hcl_makecnoderadnumlit(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
break;
case HCL_IOTOK_FPDECLIT:
obj = hcl_makecnodefpdeclit(hcl, TOKEN_LOC(hcl), TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl));
obj = hcl_makecnodefpdeclit(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
break;
/*
@ -1954,15 +1961,15 @@ static hcl_cnode_t* read_object (hcl_t* hcl)
*/
case HCL_IOTOK_STRLIT:
obj = hcl_makecnodestrlit(hcl, TOKEN_LOC(hcl), TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl));
obj = hcl_makecnodestrlit(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
break;
case HCL_IOTOK_IDENT:
obj = hcl_makecnodesymbol(hcl, TOKEN_LOC(hcl), TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl));
obj = hcl_makecnodesymbol(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
break;
case HCL_IOTOK_IDENT_DOTTED:
obj = hcl_makecnodedsymbol(hcl, TOKEN_LOC(hcl), TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl));
obj = hcl_makecnodedsymbol(hcl, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
break;
}