From b327791484222f6503cbb06de5ad71e84d8ed3d8 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Fri, 15 Jan 2021 09:12:28 +0000 Subject: [PATCH] experimenting with the new reader --- bin/main.c | 44 +- lib/Makefile.am | 2 + lib/Makefile.in | 44 +- lib/cnode.c | 9 +- lib/comp.c | 2 +- lib/comp2.c | 2993 +++++++++++++++++++++++++++++++++++++++++++++++ lib/hcl-prv.h | 3 - lib/hcl.h | 5 + lib/read2.c | 107 +- 9 files changed, 3136 insertions(+), 73 deletions(-) create mode 100644 lib/comp2.c diff --git a/bin/main.c b/bin/main.c index a4f5bd7..1de4815 100644 --- a/bin/main.c +++ b/bin/main.c @@ -810,7 +810,7 @@ static int handle_logopt (hcl_t* hcl, const hcl_bch_t* str) #if defined(HCL_BUILD_DEBUG) static int handle_dbgopt (hcl_t* hcl, const hcl_bch_t* str) { - xtn_t* xtn = (xtn_t*)hcl_getxtn(hcl); + /*xtn_t* xtn = (xtn_t*)hcl_getxtn(hcl);*/ const hcl_bch_t* cm, * flt; hcl_oow_t len; hcl_bitmask_t trait, dbgopt = 0; @@ -1173,6 +1173,48 @@ hcl_logufmt (hcl, HCL_LOG_WARN, fmt, ustr, 0x6789); } #endif + + +#if 0 +//////////////////////////// +{ +hcl_cnode_t* xx; +while (1) +{ + xx = hcl_read2(hcl); + if (!xx) + { + if (hcl->errnum == HCL_EFINIS) + { + /* end of input */ + break; + } + else if (hcl->errnum == HCL_ESYNERR) + { + print_synerr (hcl); + if (xtn->reader_istty && hcl_getsynerrnum(hcl) != HCL_SYNERR_EOF) + { + /* TODO: drain remaining data in the reader including the actual inputstream and buffered data in hcl */ + } + continue; + } + else + { + hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot read object - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); + } + goto oops; + } + else + { + hcl_logbfmt (hcl, HCL_LOG_STDERR, "OK: got cnode - %p\n", xx); + hcl_freecnode (hcl, xx); + } +} + +} +//////////////////////////// +#endif + while (1) { hcl_oop_t obj; diff --git a/lib/Makefile.am b/lib/Makefile.am index 063c762..2b84be5 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -66,6 +66,7 @@ libhcl_la_SOURCES = \ bigint.c \ cnode.c \ comp.c \ + comp2.c \ debug.c \ decode.c \ dic.c \ @@ -83,6 +84,7 @@ libhcl_la_SOURCES = \ prim.c \ print.c \ rbt.c \ + read.c \ read2.c \ sym.c \ utf8.c \ diff --git a/lib/Makefile.in b/lib/Makefile.in index b00ab1a..f88b08d 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -151,13 +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-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@) @@ -197,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 \ @@ -205,9 +207,9 @@ am__depfiles_remade = ./$(DEPDIR)/libhcl_la-bigint.Plo \ ./$(DEPDIR)/libhcl_la-number.Plo ./$(DEPDIR)/libhcl_la-obj.Plo \ ./$(DEPDIR)/libhcl_la-opt.Plo ./$(DEPDIR)/libhcl_la-prim.Plo \ ./$(DEPDIR)/libhcl_la-print.Plo ./$(DEPDIR)/libhcl_la-rbt.Plo \ - ./$(DEPDIR)/libhcl_la-read2.Plo ./$(DEPDIR)/libhcl_la-sym.Plo \ - ./$(DEPDIR)/libhcl_la-utf8.Plo ./$(DEPDIR)/libhcl_la-utl.Plo \ - ./$(DEPDIR)/libhcl_la-xma.Plo \ + ./$(DEPDIR)/libhcl_la-read.Plo ./$(DEPDIR)/libhcl_la-read2.Plo \ + ./$(DEPDIR)/libhcl_la-sym.Plo ./$(DEPDIR)/libhcl_la-utf8.Plo \ + ./$(DEPDIR)/libhcl_la-utl.Plo ./$(DEPDIR)/libhcl_la-xma.Plo \ ./$(DEPDIR)/libhclx_la-cb-impl.Plo \ ./$(DEPDIR)/libhclx_la-hcl-c.Plo \ ./$(DEPDIR)/libhclx_la-hcl-s.Plo \ @@ -438,6 +440,7 @@ libhcl_la_SOURCES = \ bigint.c \ cnode.c \ comp.c \ + comp2.c \ debug.c \ decode.c \ dic.c \ @@ -455,6 +458,7 @@ libhcl_la_SOURCES = \ prim.c \ print.c \ rbt.c \ + read.c \ read2.c \ sym.c \ utf8.c \ @@ -575,6 +579,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 @@ -590,6 +595,7 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-prim.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-print.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-rbt.Plo@am__quote@ # am--include-marker +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-read.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-read2.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-sym.Plo@am__quote@ # am--include-marker @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-utf8.Plo@am__quote@ # am--include-marker @@ -653,6 +659,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 @@ -758,6 +771,13 @@ libhcl_la-rbt.lo: rbt.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-rbt.lo `test -f 'rbt.c' || echo '$(srcdir)/'`rbt.c +libhcl_la-read.lo: read.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-read.lo -MD -MP -MF $(DEPDIR)/libhcl_la-read.Tpo -c -o libhcl_la-read.lo `test -f 'read.c' || echo '$(srcdir)/'`read.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libhcl_la-read.Tpo $(DEPDIR)/libhcl_la-read.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='read.c' object='libhcl_la-read.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-read.lo `test -f 'read.c' || echo '$(srcdir)/'`read.c + libhcl_la-read2.lo: read2.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-read2.lo -MD -MP -MF $(DEPDIR)/libhcl_la-read2.Tpo -c -o libhcl_la-read2.lo `test -f 'read2.c' || echo '$(srcdir)/'`read2.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libhcl_la-read2.Tpo $(DEPDIR)/libhcl_la-read2.Plo @@ -993,6 +1013,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 @@ -1008,6 +1029,7 @@ distclean: distclean-am -rm -f ./$(DEPDIR)/libhcl_la-prim.Plo -rm -f ./$(DEPDIR)/libhcl_la-print.Plo -rm -f ./$(DEPDIR)/libhcl_la-rbt.Plo + -rm -f ./$(DEPDIR)/libhcl_la-read.Plo -rm -f ./$(DEPDIR)/libhcl_la-read2.Plo -rm -f ./$(DEPDIR)/libhcl_la-sym.Plo -rm -f ./$(DEPDIR)/libhcl_la-utf8.Plo @@ -1068,6 +1090,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 @@ -1083,6 +1106,7 @@ maintainer-clean: maintainer-clean-am -rm -f ./$(DEPDIR)/libhcl_la-prim.Plo -rm -f ./$(DEPDIR)/libhcl_la-print.Plo -rm -f ./$(DEPDIR)/libhcl_la-rbt.Plo + -rm -f ./$(DEPDIR)/libhcl_la-read.Plo -rm -f ./$(DEPDIR)/libhcl_la-read2.Plo -rm -f ./$(DEPDIR)/libhcl_la-sym.Plo -rm -f ./$(DEPDIR)/libhcl_la-utf8.Plo diff --git a/lib/cnode.c b/lib/cnode.c index 6aa0dc8..b64755b 100644 --- a/lib/cnode.c +++ b/lib/cnode.c @@ -167,8 +167,9 @@ redo: hcl_cnode_t* tmp; tmp = c->u.list.head; hcl_freemem (hcl, c); - if (tmp) + if (tmp) /* it's not set for an empty list */ { + c = tmp; goto redo; } @@ -182,7 +183,10 @@ redo: tmp1 = c->u.cons.car; tmp2 = c->u.cons.cdr; + HCL_ASSERT (hcl, tmp1 != HCL_NULL); hcl_freemem (hcl, c); + + hcl_freecnode (hcl, tmp1); /* TODO: remove recursion? */ if (tmp2) @@ -190,9 +194,12 @@ redo: c = tmp2; goto redo; } + + break; } default: hcl_freemem (hcl, c); + break; } } diff --git a/lib/comp.c b/lib/comp.c index 825ed23..1f876ac 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -2770,7 +2770,7 @@ static HCL_INLINE int emit_set (hcl_t* hcl) /* ========================================================================= */ -int hcl_compile (hcl_t* hcl, hcl_oop_t obj) +int hcl_compile2 (hcl_t* hcl, hcl_oop_t obj) { hcl_oow_t saved_bc_len, saved_lit_len; hcl_bitmask_t log_default_type_mask; diff --git a/lib/comp2.c b/lib/comp2.c new file mode 100644 index 0000000..825ed23 --- /dev/null +++ b/lib/comp2.c @@ -0,0 +1,2993 @@ +/* + * $Id$ + * + Copyright (c) 2016-2018 Chung, Hyung-Hwan. All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +#include "hcl-prv.h" + +enum +{ + VAR_NAMED, + VAR_INDEXED +}; + +#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) + +/* -------------------------------------------- + + +(defun plus(x y) + (printf "plus %d %d\n" x y) + (defun minus(x y) + (printf "minus %d %d\n" x y) + (- x y) + ) + (+ x y) +) + +(defun dummy(q) + (printf "%s\n" q) +) + +(plus 10 20) + <---- minus is now available + +(minus 10 1) + +literals --> +// +// characeter 'A' +// "string" +// B"byte string" +// array ---> #[ ] or [ ] ? constant or not? dynamic??? +// hash table - dictionary ---> #{ } or { } <--- ambuguity with blocks... +// the rest must be manipulated with code... + +------------------------------ */ + +static int add_literal (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t* index) +{ + hcl_oow_t capa, i, lfbase = 0; + + + lfbase = (hcl->option.trait & HCL_TRAIT_INTERACTIVE)? hcl->c->blk.info[hcl->c->blk.depth].lfbase: 0; + + /* TODO: speed up the following duplicate check loop */ + for (i = lfbase; i < hcl->code.lit.len; i++) + { + /* this removes redundancy of symbols, characters, and integers. */ + if (((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i] == obj) + { + *index = i - lfbase; + return i; + } + } + + capa = HCL_OBJ_GET_SIZE(hcl->code.lit.arr); + if (hcl->code.lit.len >= capa) + { + hcl_oop_t tmp; + hcl_oow_t newcapa; + + newcapa = HCL_ALIGN(capa + 1, HCL_LIT_BUFFER_ALIGN); + tmp = hcl_remakengcarray(hcl, (hcl_oop_t)hcl->code.lit.arr, newcapa); + if (!tmp) return -1; + + hcl->code.lit.arr = (hcl_oop_oop_t)tmp; + } + + *index = hcl->code.lit.len - lfbase; + + ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[hcl->code.lit.len++] = obj; + return 0; +} + +static int add_temporary_variable (hcl_t* hcl, hcl_oop_t name, hcl_oow_t dup_check_start) +{ + hcl_oow_t i; + + HCL_ASSERT (hcl, HCL_IS_SYMBOL (hcl, name)); + + for (i = dup_check_start; i < hcl->c->tv.size; i++) + { + HCL_ASSERT (hcl, HCL_IS_SYMBOL (hcl, hcl->c->tv.ptr[i])); + if (hcl->c->tv.ptr[i] == name) + { + hcl_seterrnum (hcl, HCL_EEXIST); + return -1; + } + } + + if (hcl->c->tv.size >= hcl->c->tv.capa) + { + hcl_oop_t* tmp; + hcl_oow_t newcapa; + + newcapa = HCL_ALIGN (hcl->c->tv.capa + 1, TV_BUFFER_ALIGN); /* TODO: set a better resizing policy */ + tmp = (hcl_oop_t*)hcl_reallocmem (hcl, hcl->c->tv.ptr, newcapa); + if (!tmp) return -1; + + hcl->c->tv.capa = newcapa; + hcl->c->tv.ptr = tmp; + } + + hcl->c->tv.ptr[hcl->c->tv.size++] = name; + return 0; +} + +static int find_temporary_variable_backward (hcl_t* hcl, hcl_oop_t name, hcl_oow_t* index) +{ + hcl_oow_t i; + + HCL_ASSERT (hcl, HCL_IS_SYMBOL (hcl, name)); + for (i = hcl->c->tv.size; i > 0; ) + { + --i; + HCL_ASSERT (hcl, HCL_IS_SYMBOL (hcl, hcl->c->tv.ptr[i])); + if (hcl->c->tv.ptr[i] == name) + { + *index = i; + return 0; + } + } + + hcl_seterrnum (hcl, HCL_ENOENT); + return -1; +} + +static int store_temporary_variable_count_for_block (hcl_t* hcl, hcl_oow_t tmpr_count, hcl_oow_t lfbase) +{ + HCL_ASSERT (hcl, hcl->c->blk.depth >= 0); + + if (hcl->c->blk.depth >= hcl->c->blk.info_capa) + { + hcl_blk_info_t* tmp; + hcl_oow_t newcapa; + + newcapa = HCL_ALIGN (hcl->c->blk.depth + 1, BLK_INFO_BUFFER_ALIGN); + tmp = (hcl_blk_info_t*)hcl_reallocmem (hcl, hcl->c->blk.info, newcapa * HCL_SIZEOF(*tmp)); + if (!tmp) return -1; + + hcl->c->blk.info_capa = newcapa; + hcl->c->blk.info = tmp; + } + + hcl->c->blk.info[hcl->c->blk.depth].tmprcnt = tmpr_count; + hcl->c->blk.info[hcl->c->blk.depth].lfbase = lfbase; + return 0; +} + +/* ========================================================================= */ + +static HCL_INLINE void patch_instruction (hcl_t* hcl, hcl_oow_t index, hcl_oob_t bc) +{ + HCL_ASSERT (hcl, index < hcl->code.bc.len); + hcl->code.bc.ptr[index] = bc; +} + +static int emit_byte_instruction (hcl_t* hcl, hcl_oob_t bc, const hcl_ioloc_t* srcloc) +{ + /* the context object has the ip field. it should be representable + * in a small integer. for simplicity, limit the total byte code length + * to fit in a small integer. because 'ip' points to the next instruction + * to execute, the upper bound should be (max - 1) so that 'ip' stays + * at the max when incremented */ + if (hcl->code.bc.len == HCL_SMOOI_MAX - 1) + { + hcl_seterrnum (hcl, HCL_EBCFULL); /* byte code full/too big */ + return -1; + } + + if (hcl->code.bc.len >= hcl->code.bc.capa) + { + hcl_oow_t newcapa; + hcl_oob_t* tmp; + hcl_oow_t* tmp2; + + newcapa = HCL_ALIGN(hcl->code.bc.capa + 1, HCL_BC_BUFFER_ALIGN); + tmp = (hcl_oob_t*)hcl_reallocmem(hcl, hcl->code.bc.ptr, HCL_SIZEOF(*tmp) * newcapa); + if (HCL_UNLIKELY(!tmp)) return -1; + + tmp2 = (hcl_oow_t*)hcl_reallocmem(hcl, hcl->code.locptr, HCL_SIZEOF(*tmp2) * newcapa); + if (HCL_UNLIKELY(!tmp2)) + { + hcl_freemem (hcl, tmp); + return -1; + } + HCL_MEMSET (&tmp2[hcl->code.bc.capa], 0, HCL_SIZEOF(*tmp2) * (newcapa - hcl->code.bc.capa)); + + hcl->code.bc.ptr = tmp; + hcl->code.bc.capa = newcapa; + hcl->code.locptr = tmp2; + } + + hcl->code.bc.ptr[hcl->code.bc.len] = bc; + + if (srcloc) + { + hcl->code.locptr[hcl->code.bc.len] = srcloc->line; + } + + hcl->code.bc.len++; + return 0; +} + +int hcl_emitbyteinstruction (hcl_t* hcl, hcl_oob_t bc) +{ + return emit_byte_instruction(hcl, bc, HCL_NULL); +} + +static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1) +{ + hcl_oob_t bc; + + switch (cmd) + { + case HCL_CODE_PUSH_INSTVAR_0: + case HCL_CODE_STORE_INTO_INSTVAR_0: + case HCL_CODE_POP_INTO_INSTVAR_0: + case HCL_CODE_PUSH_TEMPVAR_0: + case HCL_CODE_STORE_INTO_TEMPVAR_0: + case HCL_CODE_POP_INTO_TEMPVAR_0: + if (param_1 < 8) + { + /* low 3 bits to hold the parameter */ + bc = (hcl_oob_t)(cmd & 0xF8) | (hcl_oob_t)param_1; + goto write_short; + } + else + { + /* convert the code to a long version */ + bc = cmd | 0x80; + goto write_long; + } + + case HCL_CODE_PUSH_LITERAL_0: + if (param_1 < 8) + { + /* low 3 bits to hold the parameter */ + bc = (hcl_oob_t)(cmd & 0xF8) | (hcl_oob_t)param_1; + goto write_short; + } + else if (param_1 <= MAX_CODE_PARAM) + { + bc = HCL_CODE_PUSH_LITERAL_X; /* cmd | 0x80 */ + goto write_long; + } + else + { + bc = HCL_CODE_PUSH_LITERAL_X2; /* HCL_CODE_PUSH_LITERAL_4 | 0x80 */ + goto write_long2; + } + + case HCL_CODE_PUSH_OBJECT_0: + case HCL_CODE_STORE_INTO_OBJECT_0: + case HCL_CODE_POP_INTO_OBJECT_0: + case HCL_CODE_JUMP_FORWARD_0: + case HCL_CODE_JUMP_BACKWARD_0: + case HCL_CODE_CALL_0: + if (param_1 < 4) + { + /* low 2 bits to hold the parameter */ + bc = (hcl_oob_t)(cmd & 0xFC) | (hcl_oob_t)param_1; + goto write_short; + } + else + { + /* convert the code to a long version */ + bc = cmd | 0x80; + goto write_long; + } + + case HCL_CODE_JUMP_FORWARD_IF_TRUE: + case HCL_CODE_JUMP_FORWARD_IF_FALSE: + case HCL_CODE_JUMP2_FORWARD_IF_TRUE: + case HCL_CODE_JUMP2_FORWARD_IF_FALSE: + case HCL_CODE_JUMP2_FORWARD: + case HCL_CODE_JUMP2_BACKWARD: + case HCL_CODE_PUSH_INTLIT: + case HCL_CODE_PUSH_NEGINTLIT: + case HCL_CODE_PUSH_CHARLIT: + + case HCL_CODE_MAKE_DIC: /* TODO: don't these need write_long2? */ + case HCL_CODE_MAKE_ARRAY: + case HCL_CODE_MAKE_BYTEARRAY: + case HCL_CODE_POP_INTO_ARRAY: + case HCL_CODE_POP_INTO_BYTEARRAY: + bc = cmd; + goto write_long; + } + + hcl_seterrnum (hcl, HCL_EINVAL); + return -1; + +write_short: + if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1) return -1; + return 0; + +write_long: + if (param_1 > MAX_CODE_PARAM) + { + hcl_seterrnum (hcl, HCL_ERANGE); + return -1; + } +#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2) + if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, (param_1 >> 8) & 0xFF, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, param_1 & 0xFF, HCL_NULL) <= -1) return -1; +#else + if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, param_1, HCL_NULL) <= -1) return -1; +#endif + return 0; + +write_long2: + if (param_1 > MAX_CODE_PARAM2) + { + hcl_seterrnum (hcl, HCL_ERANGE); + return -1; + } +#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2) + if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, (param_1 >> 24) & 0xFF, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, (param_1 >> 16) & 0xFF, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, (param_1 >> 8) & 0xFF, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, param_1 & 0xFF, HCL_NULL) <= -1) return -1; +#else + if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, (param_1 >> 8) & 0xFF, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, param_1 & 0xFF, HCL_NULL) <= -1) return -1; +#endif + return 0; +} + +static int emit_double_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1, hcl_oow_t param_2) +{ + hcl_oob_t bc; + + switch (cmd) + { + case HCL_CODE_STORE_INTO_CTXTEMPVAR_0: + case HCL_CODE_POP_INTO_CTXTEMPVAR_0: + case HCL_CODE_PUSH_CTXTEMPVAR_0: + case HCL_CODE_PUSH_OBJVAR_0: + case HCL_CODE_STORE_INTO_OBJVAR_0: + case HCL_CODE_POP_INTO_OBJVAR_0: + case HCL_CODE_SEND_MESSAGE_0: + case HCL_CODE_SEND_MESSAGE_TO_SUPER_0: + if (param_1 < 4 && param_2 < 0xFF) + { + /* low 2 bits of the instruction code is the first parameter */ + bc = (hcl_oob_t)(cmd & 0xFC) | (hcl_oob_t)param_1; + goto write_short; + } + else + { + /* convert the code to a long version */ + bc = cmd | 0x80; + goto write_long; + } + + /* MAKE_FUNCTION is a quad-parameter instruction. + * The caller must emit two more parameters after the call to this function. + * however the instruction format is the same up to the second + * parameters between MAKE_FUNCTION and MAKE_BLOCK. + */ + case HCL_CODE_MAKE_FUNCTION: + case HCL_CODE_MAKE_BLOCK: + bc = cmd; + goto write_long; + } + + hcl_seterrnum (hcl, HCL_EINVAL); + return -1; + +write_short: + if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, param_2, HCL_NULL) <= -1) return -1; + return 0; + +write_long: + if (param_1 > MAX_CODE_PARAM || param_2 > MAX_CODE_PARAM) + { + hcl_seterrnum (hcl, HCL_ERANGE); + return -1; + } +#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2) + if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, param_1 >> 8, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, param_1 & 0xFF, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, param_2 >> 8, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, param_2 & 0xFF, HCL_NULL) <= -1) return -1; +#else + if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, param_1, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, param_2, HCL_NULL) <= -1) return -1; +#endif + return 0; +} + +static HCL_INLINE int emit_long_param (hcl_t* hcl, hcl_oow_t param) +{ + if (param > MAX_CODE_PARAM) + { + hcl_seterrnum (hcl, HCL_ERANGE); + return -1; + } + +#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2) + return (emit_byte_instruction(hcl, param >> 8, HCL_NULL) <= -1 || + emit_byte_instruction(hcl, param & 0xFF, HCL_NULL) <= -1)? -1: 0; +#else + return emit_byte_instruction(hcl, param_1, HCL_NULL); +#endif +} + +static int emit_push_literal (hcl_t* hcl, hcl_oop_t obj) +{ + hcl_oow_t index; + + if (HCL_OOP_IS_SMOOI(obj)) + { + hcl_ooi_t i; + + i = HCL_OOP_TO_SMOOI(obj); + switch (i) + { + case -1: + return emit_byte_instruction(hcl, HCL_CODE_PUSH_NEGONE, HCL_NULL); + + case 0: + return emit_byte_instruction(hcl, HCL_CODE_PUSH_ZERO, HCL_NULL); + + case 1: + return emit_byte_instruction(hcl, HCL_CODE_PUSH_ONE, HCL_NULL); + + case 2: + return emit_byte_instruction(hcl, HCL_CODE_PUSH_TWO, HCL_NULL); + } + + if (i >= 0 && i <= MAX_CODE_PARAM) + { + return emit_single_param_instruction(hcl, HCL_CODE_PUSH_INTLIT, i); + } + else if (i < 0 && i >= -(hcl_ooi_t)MAX_CODE_PARAM) + { + return emit_single_param_instruction(hcl, HCL_CODE_PUSH_NEGINTLIT, -i); + } + } + else if (HCL_OOP_IS_CHAR(obj)) + { + hcl_ooch_t i; + + i = HCL_OOP_TO_CHAR(obj); + + if (i >= 0 && i <= MAX_CODE_PARAM) + return emit_single_param_instruction(hcl, HCL_CODE_PUSH_CHARLIT, i); + } + + if (add_literal(hcl, obj, &index) <= -1 || + emit_single_param_instruction(hcl, HCL_CODE_PUSH_LITERAL_0, index) <= -1) return -1; + + return 0; +} + +static HCL_INLINE void patch_long_jump (hcl_t* hcl, hcl_ooi_t jip, hcl_ooi_t jump_offset) +{ + if (jump_offset > MAX_CODE_JUMP) + { + /* switch to JUMP2 instruction to allow a bigger jump offset. + * up to twice MAX_CODE_JUMP only */ + + HCL_ASSERT (hcl, jump_offset <= MAX_CODE_JUMP * 2); + + HCL_ASSERT (hcl, hcl->code.bc.ptr[jip] == HCL_CODE_JUMP_FORWARD_X || + hcl->code.bc.ptr[jip] == HCL_CODE_JUMP_BACKWARD_X || + hcl->code.bc.ptr[jip] == HCL_CODE_JUMP_FORWARD_IF_TRUE || + hcl->code.bc.ptr[jip] == HCL_CODE_JUMP_FORWARD_IF_FALSE); + + /* JUMP2 instructions are chosen to be greater than its JUMP counterpart by 1 */ + patch_instruction (hcl, jip, hcl->code.bc.ptr[jip] + 1); + jump_offset -= MAX_CODE_JUMP; + } + +#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2) + patch_instruction (hcl, jip + 1, jump_offset >> 8); + patch_instruction (hcl, jip + 2, jump_offset & 0xFF); +#else + patch_instruction (hcl, jip + 1, jump_offset); +#endif +} + +static HCL_INLINE void patch_long_param (hcl_t* hcl, hcl_ooi_t ip, hcl_oow_t param) +{ +#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2) + patch_instruction (hcl, ip, param >> 8); + patch_instruction (hcl, ip + 1, param & 0xFF); +#else + patch_instruction (hcl, ip, param); +#endif +} + +/* ========================================================================= */ +static HCL_INLINE int _insert_cframe (hcl_t* hcl, hcl_ooi_t index, int opcode, hcl_oop_t operand) +{ + hcl_cframe_t* tmp; + + HCL_ASSERT (hcl, index >= 0); + + hcl->c->cfs.top++; + HCL_ASSERT (hcl, hcl->c->cfs.top >= 0); + HCL_ASSERT (hcl, index <= hcl->c->cfs.top); + + if ((hcl_oow_t)hcl->c->cfs.top >= hcl->c->cfs.capa) + { + hcl_oow_t newcapa; + + newcapa = HCL_ALIGN (hcl->c->cfs.top + 256, 256); /* TODO: adjust this capacity */ + tmp = (hcl_cframe_t*)hcl_reallocmem (hcl, hcl->c->cfs.ptr, newcapa * HCL_SIZEOF(hcl_cframe_t)); + if (HCL_UNLIKELY(!tmp)) + { + hcl->c->cfs.top--; + return -1; + } + + hcl->c->cfs.capa = newcapa; + hcl->c->cfs.ptr = tmp; + } + + if (index < hcl->c->cfs.top) + { + HCL_MEMMOVE (&hcl->c->cfs.ptr[index + 1], &hcl->c->cfs.ptr[index], (hcl->c->cfs.top - index) * HCL_SIZEOF(*tmp)); + } + + tmp = &hcl->c->cfs.ptr[index]; + tmp->opcode = opcode; + tmp->operand = operand; + /* leave tmp->u untouched/uninitialized */ + return 0; +} + +static int insert_cframe (hcl_t* hcl, hcl_ooi_t index, int opcode, hcl_oop_t operand) +{ + if (hcl->c->cfs.top == HCL_TYPE_MAX(hcl_ooi_t)) + { + hcl_seterrnum (hcl, HCL_EFRMFLOOD); + return -1; + } + + return _insert_cframe(hcl, index, opcode, operand); +} + +static int push_cframe (hcl_t* hcl, int opcode, hcl_oop_t operand) +{ + if (hcl->c->cfs.top == HCL_TYPE_MAX(hcl_ooi_t)) + { + hcl_seterrnum (hcl, HCL_EFRMFLOOD); + return -1; + } + + return _insert_cframe(hcl, hcl->c->cfs.top + 1, opcode, operand); +} + +static HCL_INLINE void pop_cframe (hcl_t* hcl) +{ + HCL_ASSERT (hcl, hcl->c->cfs.top >= 0); + hcl->c->cfs.top--; +} + +#define PUSH_CFRAME(hcl,opcode,operand) \ + do { if (push_cframe(hcl,opcode,operand) <= -1) return -1; } while(0) + +#define INSERT_CFRAME(hcl,index,opcode,operand) \ + do { if (insert_cframe(hcl,index,opcode,operand) <= -1) return -1; } while(0) + +#define POP_CFRAME(hcl) pop_cframe(hcl) + +#define POP_ALL_CFRAMES(hcl) (hcl->c->cfs.top = -1) + +#define GET_TOP_CFRAME_INDEX(hcl) (hcl->c->cfs.top) + +#define GET_TOP_CFRAME(hcl) (&hcl->c->cfs.ptr[hcl->c->cfs.top]) + +#define GET_CFRAME(hcl,index) (&hcl->c->cfs.ptr[index]) + +#define SWITCH_TOP_CFRAME(hcl,_opcode,_operand) \ + do { \ + hcl_cframe_t* _cf = GET_TOP_CFRAME(hcl); \ + _cf->opcode = _opcode; \ + _cf->operand = _operand; \ + } while (0); + +#define SWITCH_CFRAME(hcl,_index,_opcode,_operand) \ + do { \ + hcl_cframe_t* _cf = GET_CFRAME(hcl,_index); \ + _cf->opcode = _opcode; \ + _cf->operand = _operand; \ + } while (0); + +static int push_subcframe (hcl_t* hcl, int opcode, hcl_oop_t operand) +{ + hcl_cframe_t* cf, tmp; + + cf = GET_TOP_CFRAME(hcl); + tmp = *cf; + cf->opcode = opcode; + cf->operand = operand; + + return push_cframe(hcl, tmp.opcode, tmp.operand); +} + +static HCL_INLINE hcl_cframe_t* find_cframe_from_top (hcl_t* hcl, int opcode) +{ + hcl_cframe_t* cf; + hcl_ooi_t i; + + for (i = hcl->c->cfs.top; i >= 0; i--) + { + cf = &hcl->c->cfs.ptr[i]; + if (cf->opcode == opcode) return cf; + } + + return HCL_NULL; +} + +#define PUSH_SUBCFRAME(hcl,opcode,operand) \ + do { if (push_subcframe(hcl,opcode,operand) <= -1) return -1; } while(0) + +#define GET_SUBCFRAME(hcl) (&hcl->c->cfs.ptr[hcl->c->cfs.top - 1]) + +enum +{ + COP_COMPILE_OBJECT, + + COP_COMPILE_OBJECT_LIST, + COP_COMPILE_IF_OBJECT_LIST, + COP_COMPILE_ARGUMENT_LIST, + COP_COMPILE_OBJECT_LIST_TAIL, + COP_COMPILE_IF_OBJECT_LIST_TAIL, + + COP_COMPILE_ARRAY_LIST, + COP_COMPILE_BYTEARRAY_LIST, + COP_COMPILE_DIC_LIST, + COP_COMPILE_QLIST, /* compile data list */ + + COP_SUBCOMPILE_ELIF, + COP_SUBCOMPILE_ELSE, + + COP_EMIT_CALL, + + COP_EMIT_MAKE_ARRAY, + COP_EMIT_MAKE_BYTEARRAY, + COP_EMIT_MAKE_DIC, + COP_EMIT_MAKE_DLIST, + COP_EMIT_POP_INTO_ARRAY, + COP_EMIT_POP_INTO_BYTEARRAY, + COP_EMIT_POP_INTO_DIC, + COP_EMIT_POP_INTO_DLIST, + + COP_EMIT_LAMBDA, + COP_EMIT_POP_STACKTOP, + COP_EMIT_RETURN, + COP_EMIT_SET, + + COP_SUBCOMPILE_AND_EXPR, + COP_SUBCOMPILE_OR_EXPR, + + COP_POST_AND_EXPR, + COP_POST_OR_EXPR, + + COP_POST_IF_COND, + COP_POST_IF_BODY, + + COP_POST_UNTIL_BODY, + COP_POST_UNTIL_COND, + COP_POST_WHILE_BODY, + COP_POST_WHILE_COND, + + COP_UPDATE_BREAK +}; + +/* ========================================================================= */ +static int compile_and (hcl_t* hcl, hcl_oop_t src) +{ + hcl_oop_t expr, obj; + + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); + HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_and); + + obj = HCL_CONS_CDR(src); + + if (HCL_IS_NIL(hcl, obj)) + { + /* no value */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, + "no expression specified in and - %O", src); /* TODO: error location */ + return -1; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in and - %O", src); /* TODO: error location */ + return -1; + } + +/* TODO: optimization - eat away all truee expressions */ + expr = HCL_CONS_CAR(obj); + obj = HCL_CONS_CDR(obj); + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */ + PUSH_SUBCFRAME (hcl, COP_SUBCOMPILE_AND_EXPR, obj); /* 2 */ + + return 0; +} + +static int compile_or (hcl_t* hcl, hcl_oop_t src) +{ + hcl_oop_t expr, obj; + + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); + HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_or); + + obj = HCL_CONS_CDR(src); + + if (HCL_IS_NIL(hcl, obj)) + { + /* no value */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, + "no expression specified in or - %O", src); /* TODO: error location */ + return -1; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in or - %O", src); /* TODO: error location */ + return -1; + } + +/* TODO: optimization - eat away all false expressions */ + expr = HCL_CONS_CAR(obj); + obj = HCL_CONS_CDR(obj); + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */ + PUSH_SUBCFRAME (hcl, COP_SUBCOMPILE_OR_EXPR, obj); /* 2 */ + + return 0; +} + +static int compile_break (hcl_t* hcl, hcl_oop_t src) +{ + /* (break) */ + hcl_oop_t obj; + hcl_ooi_t i; + + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); + HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_break); + + obj = HCL_CONS_CDR(src); + if (!HCL_IS_NIL(hcl,obj)) + { + if (HCL_IS_CONS(hcl,obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, + "redundant argument in break - %O", src); /* TODO: error location */ + } + else + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in break - %O", src); /* TODO: error location */ + return -1; + } + return -1; + } + + for (i = hcl->c->cfs.top; i >= 0; --i) + { + const hcl_cframe_t* tcf; + tcf = &hcl->c->cfs.ptr[i]; + + if (tcf->opcode == COP_EMIT_LAMBDA) break; /* seems to cross lambda boundary */ + + if (tcf->opcode == COP_POST_UNTIL_BODY || tcf->opcode == COP_POST_WHILE_BODY) + { + hcl_ooi_t jump_inst_pos; + + /* (break) is not really a function call. but to make it look like a + * function call, i generate PUSH_NIL so nil becomes a return value. + * (set x (until #f (break))) + * x will get nill. */ + if (emit_byte_instruction (hcl, HCL_CODE_PUSH_NIL, HCL_NULL) <= -1) return -1; + +/* TODO: study if supporting expression after break is good like return. (break (+ 10 20)) */ + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + jump_inst_pos = hcl->code.bc.len; + + if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_FORWARD_0, MAX_CODE_JUMP) <= -1) return -1; + INSERT_CFRAME (hcl, i, COP_UPDATE_BREAK, HCL_SMOOI_TO_OOP(jump_inst_pos)); + + POP_CFRAME (hcl); + return 0; + } + } + + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BREAK, HCL_NULL, HCL_NULL, + "break outside loop - %O", src); /* TODO: error location */ + return -1; +} + +static int compile_if (hcl_t* hcl, hcl_oop_t src) +{ + hcl_oop_t obj, cond; + hcl_cframe_t* cf; + + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); + HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_if); + + /* (if (< 20 30) + * (do this) + * (do that) + * elif (< 20 30) + * (do it) + * else + * (do this finally) + * ) + */ + obj = HCL_CONS_CDR(src); + + if (HCL_IS_NIL(hcl, obj)) + { + /* no value */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, + "no condition specified in if - %O", src); /* TODO: error location */ + return -1; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in if - %O", src); /* TODO: error location */ + return -1; + } + + cond = HCL_CONS_CAR(obj); + obj = HCL_CONS_CDR(obj); + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, cond); /* 1 */ + PUSH_SUBCFRAME (hcl, COP_POST_IF_COND, obj); /* 2 */ + cf = GET_SUBCFRAME (hcl); + cf->u.post_if.body_pos = -1; /* unknown yet */ +/* TODO: OPTIMIZATION: + * pass information on the conditional if it's an absoluate true or absolute false to + * eliminate some code .. i can't eliminate code because there can be else or elif... + * if absoluate true, don't need else or other elif part + * if absoluate false, else or other elif part is needed. + */ + return 0; +} + +static int compile_lambda (hcl_t* hcl, hcl_oop_t src, int defun) +{ + hcl_oop_t obj, args; + hcl_oow_t nargs, ntmprs; + hcl_ooi_t jump_inst_pos, lfbase_pos, lfsize_pos; + hcl_oow_t saved_tv_count, tv_dup_start; + hcl_oop_t defun_name; + + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); + + saved_tv_count = hcl->c->tv.size; + obj = HCL_CONS_CDR(src); + + if (defun) + { + HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_defun); + + if (HCL_IS_NIL(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_NULL, HCL_NULL, + "no defun name - %O", src); /* TODO: error location */ + return -1; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in defun - %O", src); /* TODO: error location */ + return -1; + } + + defun_name = HCL_CONS_CAR(obj); + if (!HCL_IS_SYMBOL(hcl, defun_name)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_NULL, HCL_NULL, + "defun name not a symbol - %O", defun_name); /* TODO: error location */ + return -1; + } + + if (HCL_OBJ_GET_FLAGS_SYNCODE(defun_name) || HCL_OBJ_GET_FLAGS_KERNEL(defun_name) >= 1) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL, + "special symbol not to be used as a defun name - %O", defun_name); /* TOOD: error location */ + return -1; + } + + obj = HCL_CONS_CDR(obj); + } + else + { + HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_lambda); + } + + if (HCL_IS_NIL(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_NULL, HCL_NULL, + "no argument list in lambda - %O", src); /* TODO: error location */ + return -1; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in lambda - %O", src); /* TODO: error location */ + return -1; + } + + args = HCL_CONS_CAR(obj); + if (HCL_IS_NIL(hcl, args)) + { + /* no argument - (lambda () (+ 10 20)) */ + nargs = 0; + } + else + { + hcl_oop_t arg, ptr; + + if (!HCL_IS_CONS(hcl, args)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_NULL, HCL_NULL, + "not a lambda argument list - %O", args); /* TODO: error location */ + return -1; + } + + tv_dup_start = hcl->c->tv.size; + nargs = 0; + ptr = args; + do + { + arg = HCL_CONS_CAR(ptr); + if (!HCL_IS_SYMBOL(hcl, arg)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAME, HCL_NULL, HCL_NULL, + "lambda argument not a symbol - %O", arg); /* TODO: error location */ + return -1; + } + + if (HCL_OBJ_GET_FLAGS_SYNCODE(arg) || HCL_OBJ_GET_FLAGS_KERNEL(arg) >= 2) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDARGNAME, HCL_NULL, HCL_NULL, + "special symbol not to be declared as an argument - %O", arg); /* TOOD: error location */ + return -1; + } + + if (add_temporary_variable (hcl, arg, tv_dup_start) <= -1) + { + if (hcl->errnum == HCL_EEXIST) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMEDUP, HCL_NULL, HCL_NULL, + "lambda argument duplicate - %O", arg); /* TODO: error location */ + } + return -1; + } + nargs++; + + ptr = HCL_CONS_CDR(ptr); + if (!HCL_IS_CONS(hcl, ptr)) + { + if (!HCL_IS_NIL(hcl, ptr)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in lambda argument list - %O", args); /* TODO: error location */ + return -1; + } + break; + } + } + while (1); + } + + HCL_ASSERT (hcl, nargs == hcl->c->tv.size - saved_tv_count); + if (nargs > MAX_CODE_NBLKARGS) /*TODO: change this limit to max call argument count */ + { + /* while an integer object is pused to indicate the number of + * block arguments, evaluation which is done by message passing + * limits the number of arguments that can be passed. so the + * check is implemented */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_NULL, HCL_NULL, "too many(%zu) arguments - %O", nargs, args); + return -1; + } + + ntmprs = nargs; + obj = HCL_CONS_CDR(obj); + + tv_dup_start = hcl->c->tv.size; + while (HCL_IS_CONS(hcl, obj)) + { + hcl_oop_t dcl; + + dcl = HCL_CONS_CAR(obj); + if (HCL_IS_SYMBOL_ARRAY(hcl, dcl)) + { + hcl_oow_t i, sz; + + sz = HCL_OBJ_GET_SIZE(dcl); + for (i = 0; i < sz; i++) + { + if (HCL_OBJ_GET_FLAGS_SYNCODE(((hcl_oop_oop_t)dcl)->slot[i]) || + HCL_OBJ_GET_FLAGS_KERNEL(((hcl_oop_oop_t)dcl)->slot[i]) >= 2) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL, + "special symbol not to be declared as a variable - %O", obj); /* TOOD: error location */ + return -1; + } + + if (add_temporary_variable(hcl, ((hcl_oop_oop_t)dcl)->slot[i], tv_dup_start) <= -1) + { + if (hcl->errnum == HCL_EEXIST) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAMEDUP, HCL_NULL, HCL_NULL, + "local variable duplicate - %O", ((hcl_oop_oop_t)dcl)->slot[i]); /* TODO: error location */ + } + + return -1; + } + + ntmprs++; + } + + obj = HCL_CONS_CDR(obj); + } + else break; + } + + /* ntmprs: number of temporary variables including arguments */ + HCL_ASSERT (hcl, ntmprs == hcl->c->tv.size - saved_tv_count); + if (ntmprs > MAX_CODE_NBLKTMPRS) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARFLOOD, HCL_NULL, HCL_NULL, "too many(%zu) variables - %O", ntmprs, args); + return -1; + } + + if (hcl->c->blk.depth == HCL_TYPE_MAX(hcl_ooi_t)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLKDEPTH, HCL_NULL, HCL_NULL, "lambda block depth too deep - %O", src); + return -1; + } + hcl->c->blk.depth++; + if (store_temporary_variable_count_for_block(hcl, hcl->c->tv.size, hcl->code.lit.len) <= -1) return -1; + + + if (hcl->option.trait & HCL_TRAIT_INTERACTIVE) + { + /* make_function nargs ntmprs lfbase lfsize */ + if (emit_double_param_instruction(hcl, HCL_CODE_MAKE_FUNCTION, nargs, ntmprs) <= -1) return -1; + lfbase_pos = hcl->code.bc.len; + if (emit_long_param(hcl, hcl->code.lit.len - hcl->c->blk.info[hcl->c->blk.depth - 1].lfbase) <= -1) return -1; /* literal frame base */ + lfsize_pos = hcl->code.bc.len; /* literal frame size */ + if (emit_long_param(hcl, 0) <= -1) return -1; + } + else + { + if (emit_double_param_instruction(hcl, HCL_CODE_MAKE_BLOCK, nargs, ntmprs) <= -1) return -1; + } + + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); /* guaranteed in emit_byte_instruction() */ + jump_inst_pos = hcl->code.bc.len; + /* specifying MAX_CODE_JUMP causes emit_single_param_instruction() to + * produce the long jump instruction (HCL_CODE_JUMP_FORWARD_X) */ + if (emit_single_param_instruction(hcl, HCL_CODE_JUMP_FORWARD_0, MAX_CODE_JUMP) <= -1) return -1; + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, obj); + + if (defun) + { + hcl_oow_t index; + hcl_cframe_t* cf; + + if (find_temporary_variable_backward(hcl, defun_name, &index) <= -1) + { + PUSH_SUBCFRAME (hcl, COP_EMIT_SET, defun_name); /* set doesn't evaluate the variable name */ + cf = GET_SUBCFRAME(hcl); + cf->u.set.var_type = VAR_NAMED; + } + else + { + /* the check in compile_lambda() must ensure this condition */ + HCL_ASSERT (hcl, index <= HCL_SMOOI_MAX); + + PUSH_SUBCFRAME (hcl, COP_EMIT_SET, HCL_SMOOI_TO_OOP(index)); + cf = GET_SUBCFRAME(hcl); + cf->u.set.var_type = VAR_INDEXED; + } + } + + PUSH_SUBCFRAME (hcl, COP_EMIT_LAMBDA, HCL_SMOOI_TO_OOP(jump_inst_pos)); + + if (hcl->option.trait & HCL_TRAIT_INTERACTIVE) + { + hcl_cframe_t* cf; + cf = GET_SUBCFRAME (hcl); + cf->u.lambda.lfbase_pos = lfbase_pos; + cf->u.lambda.lfsize_pos = lfsize_pos; + } + + return 0; +} + +static int compile_return (hcl_t* hcl, hcl_oop_t src, int mode) +{ + hcl_oop_t obj, val; + + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); + HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_return || HCL_CONS_CAR(src) == hcl->_return_from_home); + + obj = HCL_CONS_CDR(src); + +/* TODO: error message - cater for return-from home */ + if (HCL_IS_NIL(hcl, obj)) + { +/* TODO: should i allow (return)? does it return the last value on the stack? */ + /* no value */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, "no value specified in return - %O", src); /* TODO: error location */ + return -1; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, "redundant cdr in return - %O", src); /* TODO: error location */ + return -1; + } + + val = HCL_CONS_CAR(obj); + + obj = HCL_CONS_CDR(obj); + if (!HCL_IS_NIL(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, "more than 1 argument to return - %O", src); /* TODO: error location */ + return -1; + } + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, val); + + PUSH_SUBCFRAME (hcl, COP_EMIT_RETURN, HCL_SMOOI_TO_OOP(mode)); + + return 0; +} + +static int compile_set (hcl_t* hcl, hcl_oop_t src) +{ + hcl_cframe_t* cf; + hcl_oop_t obj, var, val; + hcl_oow_t index; + + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); + HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_set); + + obj = HCL_CONS_CDR(src); + + if (HCL_IS_NIL(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_NULL, HCL_NULL, "no variable name in set - %O", src); /* TODO: error location */ + return -1; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, "redundant cdr in set - %O", src); /* TODO: error location */ + return -1; + } + + var = HCL_CONS_CAR(obj); + if (!HCL_IS_SYMBOL(hcl, var)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_NULL, HCL_NULL, "variable name not a symbol - %O", var); /* TODO: error location */ + return -1; + } + + if (HCL_OBJ_GET_FLAGS_SYNCODE(var) || HCL_OBJ_GET_FLAGS_KERNEL(var) >= 2) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL, "special symbol not to be used as a variable name - %O", var); /* TOOD: error location */ + return -1; + } + + obj = HCL_CONS_CDR(obj); + if (HCL_IS_NIL(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, "no value specified in set - %O", src); /* TODO: error location */ + return -1; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, "redundant cdr in set - %O", src); /* TODO: error location */ + return -1; + } + + val = HCL_CONS_CAR(obj); + + obj = HCL_CONS_CDR(obj); + if (!HCL_IS_NIL(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, "too many arguments to set - %O", src); /* TODO: error location */ + return -1; + } + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, val); + + if (find_temporary_variable_backward(hcl, var, &index) <= -1) + { + PUSH_SUBCFRAME (hcl, COP_EMIT_SET, var); /* set doesn't evaluate the variable name */ + cf = GET_SUBCFRAME(hcl); + cf->u.set.var_type = VAR_NAMED; + } + else + { + /* the check in compile_lambda() must ensure this condition */ + HCL_ASSERT (hcl, index <= HCL_SMOOI_MAX); + + PUSH_SUBCFRAME (hcl, COP_EMIT_SET, HCL_SMOOI_TO_OOP(index)); + cf = GET_SUBCFRAME(hcl); + cf->u.set.var_type = VAR_INDEXED; + } + + return 0; +} + +static int compile_do (hcl_t* hcl, hcl_oop_t src) +{ + hcl_oop_t obj; + + /* (do + * (+ 10 20) + * (* 2 30) + * ... + * ) + * you can use this to combine multiple expressions to a single expression + */ + + HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_do); + + obj = HCL_CONS_CDR(src); + + if (HCL_IS_NIL(hcl, obj)) + { + /* no value */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, + "no expression specified in do - %O", src); /* TODO: error location */ + return -1; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in do - %O", src); /* TODO: error location */ + return -1; + } + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, obj); + return 0; +} + + +static int compile_while (hcl_t* hcl, hcl_oop_t src, int next_cop) +{ + /* (while (xxxx) ... ) + * (until (xxxx) ... ) */ + hcl_oop_t obj, cond; + hcl_oow_t cond_pos; + hcl_cframe_t* cf; + + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); + HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_until || HCL_CONS_CAR(src) == hcl->_while); + HCL_ASSERT (hcl, next_cop == COP_POST_UNTIL_COND || next_cop == COP_POST_WHILE_COND); + + obj = HCL_CONS_CDR(src); + + if (HCL_IS_NIL(hcl, obj)) + { + /* no value */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, + "no loop condition specified - %O", src); /* TODO: error location */ + return -1; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in loop - %O", src); /* TODO: error location */ + return -1; + } + + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + cond_pos = hcl->code.bc.len; /* position where the bytecode for the conditional is emitted */ + + cond = HCL_CONS_CAR(obj); + obj = HCL_CONS_CDR(obj); + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, cond); /* 1 */ + PUSH_SUBCFRAME (hcl, next_cop, obj); /* 2 */ + cf = GET_SUBCFRAME (hcl); + cf->u.post_while.cond_pos = cond_pos; + cf->u.post_while.body_pos = -1; /* unknown yet*/ + + return 0; +} +/* ========================================================================= */ + +static int compile_cons_array_expression (hcl_t* hcl, hcl_oop_t obj) +{ + /* [ ] */ + hcl_ooi_t nargs; + hcl_cframe_t* cf; + + /* NOTE: cframe management functions don't use the object memory. + * 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); + 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); + return -1; + } + + /* redundant cdr check is performed inside compile_object_list() */ + PUSH_SUBCFRAME (hcl, COP_COMPILE_ARRAY_LIST, obj); + cf = GET_SUBCFRAME(hcl); + cf->u.array_list.index = 0; + + /* patch the argument count in the operand field of the COP_EMIT_MAKE_ARRAY frame */ + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_ARRAY); + cf->operand = HCL_SMOOI_TO_OOP(nargs); + + return 0; +} + +static int compile_cons_bytearray_expression (hcl_t* hcl, hcl_oop_t obj) +{ + /* #[ ] - e.g. #[1, 2, 3] or #[ 1 2 3 ] */ + hcl_ooi_t nargs; + hcl_cframe_t* cf; + + /* NOTE: cframe management functions don't use the object memory. + * 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); + 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); + return -1; + } + + /* redundant cdr check is performed inside compile_object_list() */ + PUSH_SUBCFRAME (hcl, COP_COMPILE_BYTEARRAY_LIST, obj); + cf = GET_SUBCFRAME(hcl); + cf->u.bytearray_list.index = 0; + + /* patch the argument count in the operand field of the COP_EMIT_MAKE_BYTEARRAY frame */ + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_BYTEARRAY); + cf->operand = HCL_SMOOI_TO_OOP(nargs); + + return 0; +} + +static int compile_cons_dic_expression (hcl_t* hcl, hcl_oop_t obj) +{ + /* { } - e.g. {1:2, 3:4,"abc":def, "hwaddr":"00:00:00:01"} or { 1 2 3 4 } */ + hcl_ooi_t nargs; + hcl_cframe_t* cf; + + SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_DIC, HCL_SMOOI_TO_OOP(0)); + + nargs = hcl_countcons(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); + return -1; + } + + /* redundant cdr check is performed inside compile_object_list() */ + PUSH_SUBCFRAME (hcl, COP_COMPILE_DIC_LIST, obj); + + /* patch the argument count in the operand field of the COP_EMIT_MAKE_DIC frame */ + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_DIC); + cf->operand = HCL_SMOOI_TO_OOP(nargs); + + return 0; +} + +static int compile_cons_qlist_expression (hcl_t* hcl, hcl_oop_t obj) +{ + /* #( 1 2 3 ) + * #(1 (+ 2 3) 5) + * */ + + hcl_ooi_t nargs; + hcl_cframe_t* cf; + + /* NOTE: cframe management functions don't use the object memory. + * 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); + 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); + return -1; + } + + /* redundant cdr check is performed inside compile_object_list() */ + PUSH_SUBCFRAME (hcl, COP_COMPILE_QLIST, obj); + cf = GET_SUBCFRAME(hcl); +/* cf->u.qlist.index = 0;*/ + + /* patch the argument count in the operand field of the COP_EMIT_MAKE_ARRAY frame */ + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_DLIST); + cf->operand = HCL_SMOOI_TO_OOP(nargs); + + return 0; +} + +static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj) +{ + hcl_oop_t car; + int syncode; /* syntax code of the first element */ + + /* 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_CONCODED(hcl, obj, HCL_CONCODE_XLIST)); + + car = HCL_CONS_CAR(obj); + if (HCL_IS_SYMBOL(hcl,car) && (syncode = HCL_OBJ_GET_FLAGS_SYNCODE(car))) + { + switch (syncode) + { + case HCL_SYNCODE_AND: + if (compile_and(hcl, obj) <= -1) return -1; + break; + + case HCL_SYNCODE_BREAK: + /* break */ + if (compile_break(hcl, obj) <= -1) return -1; + break; + + case HCL_SYNCODE_DEFUN: + if (compile_lambda(hcl, obj, 1) <= -1) return -1; + break; + + case HCL_SYNCODE_DO: + if (compile_do(hcl, obj) <= -1) return -1; + break; + + case HCL_SYNCODE_ELSE: + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ELSE, HCL_NULL, HCL_NULL, "else without if - %O", obj); /* error location */ + return -1; + + case HCL_SYNCODE_ELIF: + 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; + break; + + case HCL_SYNCODE_LAMBDA: + /* (lambda (x y) (+ x y)) */ + if (compile_lambda(hcl, obj, 0) <= -1) return -1; + break; + + case HCL_SYNCODE_OR: + if (compile_or(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; + break; + + case HCL_SYNCODE_RETURN: + /* (return 10) + * (return (+ 10 20)) */ + if (compile_return(hcl, obj, 0) <= -1) return -1; + break; + + case HCL_SYNCODE_RETURN_FROM_HOME: + if (compile_return(hcl, obj, 1) <= -1) return -1; + break; + + case HCL_SYNCODE_UNTIL: + 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; + break; + + default: + HCL_DEBUG3 (hcl, "Internal error - unknown syncode %d at %s:%d\n", syncode, __FILE__, __LINE__); + hcl_seterrnum (hcl, HCL_EINTERN); + return -1; + } + } + else if (HCL_IS_SYMBOL(hcl,car) || HCL_IS_CONS_CONCODED(hcl,car,HCL_CONCODE_XLIST)) + { + /* normal function call + * ( ...) */ + hcl_ooi_t nargs; + hcl_ooi_t oldtop; + hcl_cframe_t* cf; + hcl_oop_t cdr; + hcl_oop_cons_t sdc; + + /* NOTE: cframe management functions don't use the object memory. + * many operations can be performed without taking GC into account */ + + /* store the position of COP_EMIT_CALL to be produced with + * SWITCH_TOP_CFRAME() in oldtop for argument count patching + * further down */ + oldtop = GET_TOP_CFRAME_INDEX(hcl); + HCL_ASSERT (hcl, oldtop >= 0); + + SWITCH_TOP_CFRAME (hcl, COP_EMIT_CALL, HCL_SMOOI_TO_OOP(0)); + + /* compile */ + PUSH_CFRAME (hcl, COP_COMPILE_OBJECT, car); + + /* compile ... etc */ + cdr = HCL_CONS_CDR(obj); + + if (HCL_IS_NIL(hcl, cdr)) + { + nargs = 0; + } + else + { + if (!HCL_IS_NIL(hcl, cdr) && !HCL_IS_CONS(hcl, cdr)) + { + /* (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); + 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); + return -1; + } + } + + if (HCL_IS_SYMBOL(hcl, car)) + { + /* only symbols are added to the system dictionary. + * perform this lookup only if car is a symbol */ + sdc = hcl_getatsysdic(hcl, car); + if (sdc) + { + hcl_oop_word_t sdv; + sdv = (hcl_oop_word_t)HCL_CONS_CDR(sdc); + if (HCL_IS_PRIM(hcl, sdv)) + { + if (nargs < sdv->slot[1] || nargs > sdv->slot[2]) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, + "parameters count(%zd) mismatch in function call - %O - expecting %zu-%zu parameters", nargs, obj, sdv->slot[1], sdv->slot[2]); + return -1; + } + } + } + } + + /* redundant cdr check is performed inside compile_object_list() */ + PUSH_SUBCFRAME (hcl, COP_COMPILE_ARGUMENT_LIST, cdr); + + /* patch the argument count in the operand field of the COP_EMIT_CALL frame */ + cf = GET_CFRAME(hcl, oldtop); + 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; +} + +static int emit_indexed_variable_access (hcl_t* hcl, hcl_oow_t index, hcl_oob_t baseinst1, hcl_oob_t baseinst2) +{ + if (hcl->c->blk.depth >= 0) + { + hcl_oow_t i; + + /* if a temporary variable is accessed inside a block, + * use a special instruction to indicate it */ + HCL_ASSERT (hcl, index < hcl->c->blk.info[hcl->c->blk.depth].tmprcnt); + for (i = hcl->c->blk.depth; i > 0; i--) /* excluded the top level -- TODO: change this code depending on global variable handling */ + { + if (index >= hcl->c->blk.info[i - 1].tmprcnt) + { + hcl_oow_t ctx_offset, index_in_ctx; + ctx_offset = hcl->c->blk.depth - i; + index_in_ctx = index - hcl->c->blk.info[i - 1].tmprcnt; + /* ctx_offset 0 means the current context. + * 1 means current->home. + * 2 means current->home->home. + * index_in_ctx is a relative index within the context found. + */ + if (emit_double_param_instruction(hcl, baseinst1, ctx_offset, index_in_ctx) <= -1) return -1; + return 0; + } + } + } + + /* TODO: top-level... verify this. this will vary depending on how i implement the top-level and global variables... */ + if (emit_single_param_instruction (hcl, baseinst2, index) <= -1) return -1; + return 0; +} + +static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_oop_t obj) +{ + hcl_oow_t index; + + HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, obj)); + + if (HCL_OBJ_GET_FLAGS_SYNCODE(obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL, + "special symbol not to be used as a variable name - %O", obj); /* TOOD: error location */ + return -1; + } + + /* check if a symbol is a local variable */ + if (find_temporary_variable_backward(hcl, obj, &index) <= -1) + { + hcl_oop_t 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 */ + cons = (hcl_oop_t)hcl_getatsysdic(hcl, obj); + if (!cons) + { + cons = (hcl_oop_t)hcl_putatsysdic(hcl, obj, hcl->_nil); + if (!cons) return -1; + } + + /* add the entire cons pair to the literal frame */ + + if (add_literal(hcl, cons, &index) <= -1 || + emit_single_param_instruction(hcl, HCL_CODE_PUSH_OBJECT_0, index) <= -1) return -1; + + return 0; + } + else + { + return emit_indexed_variable_access(hcl, index, HCL_CODE_PUSH_CTXTEMPVAR_0, HCL_CODE_PUSH_TEMPVAR_0); + } +} + +static int compile_object (hcl_t* hcl) +{ + hcl_cframe_t* cf; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_OBJECT); + + if (HCL_OOP_IS_NUMERIC(cf->operand)) goto literal; + + switch (HCL_OBJ_GET_FLAGS_BRAND(cf->operand)) + { + case HCL_BRAND_NIL: + EMIT_BYTE_INSTRUCTION (hcl, HCL_CODE_PUSH_NIL); + goto done; + + case HCL_BRAND_TRUE: + EMIT_BYTE_INSTRUCTION (hcl, HCL_CODE_PUSH_TRUE); + goto done; + + case HCL_BRAND_FALSE: + EMIT_BYTE_INSTRUCTION (hcl, HCL_CODE_PUSH_FALSE); + goto done; + + case HCL_BRAND_SYMBOL: + if (compile_symbol(hcl, cf->operand) <= -1) return -1; + goto done; + + case HCL_BRAND_CONS: + { + switch (HCL_OBJ_GET_FLAGS_SYNCODE(cf->operand)) + { + case HCL_CONCODE_ARRAY: + if (compile_cons_array_expression(hcl, cf->operand) <= -1) return -1; + break; + + case HCL_CONCODE_BYTEARRAY: + if (compile_cons_bytearray_expression(hcl, cf->operand) <= -1) return -1; + break; + + case HCL_CONCODE_DIC: + if (compile_cons_dic_expression(hcl, cf->operand) <= -1) return -1; + break; + + case HCL_CONCODE_QLIST: + if (compile_cons_qlist_expression(hcl, cf->operand) <= -1) return -1; + break; + + default: + if (compile_cons_xlist_expression(hcl, cf->operand) <= -1) return -1; + break; + } + break; + } + + case HCL_BRAND_SYMBOL_ARRAY: + hcl_setsynerrbfmt ( + hcl, HCL_SYNERR_VARDCLBANNED, HCL_NULL, HCL_NULL, + "variable declaration disallowed - %O", cf->operand); /* TODO: error location */ + return -1; + + default: + goto literal; + } + + return 0; + +literal: + if (emit_push_literal(hcl, cf->operand) <= -1) return -1; + +done: + POP_CFRAME (hcl); + return 0; +} + +static int compile_object_list (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_oop_t coperand; + int cop; + + 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); + + cop = cf->opcode; + coperand = cf->operand; + + if (HCL_IS_NIL(hcl, coperand)) + { + POP_CFRAME (hcl); + } + else + { + hcl_oop_t car, cdr; + + if (cop != COP_COMPILE_ARGUMENT_LIST) + { + /* eliminate unnecessary non-function calls. keep the last one */ + while (HCL_IS_CONS(hcl, coperand)) + { + cdr = HCL_CONS_CDR(coperand); + if (HCL_IS_NIL(hcl,cdr)) break; /* keep the last one */ + + if (HCL_IS_CONS(hcl, 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_CONS_CAR(coperand); + if (HCL_IS_CONS(hcl, car) || (HCL_IS_SYMBOL(hcl, car) && HCL_OBJ_GET_FLAGS_SYNCODE(car))) break; + coperand = cdr; + } + + HCL_ASSERT (hcl, !HCL_IS_NIL(hcl, coperand)); + } + + if (!HCL_IS_CONS(hcl, coperand)) + { + hcl_setsynerrbfmt ( + hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in the object list - %O", coperand); /* TODO: error location */ + return -1; + } + + car = HCL_CONS_CAR(coperand); + cdr = HCL_CONS_CDR(coperand); + + if (cop == COP_COMPILE_IF_OBJECT_LIST || cop == COP_COMPILE_IF_OBJECT_LIST_TAIL) + { + if (car == hcl->_elif) + { + SWITCH_TOP_CFRAME (hcl, COP_SUBCOMPILE_ELIF, coperand); + goto done; + } + else if (car == hcl->_else) + { + SWITCH_TOP_CFRAME (hcl, COP_SUBCOMPILE_ELSE, coperand); + goto done; + } + } + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car); + + if (!HCL_IS_NIL(hcl, cdr)) + { + /* there is a next statement to compile + * + * (+ 1 2 3) - argument list. 1, 2, 3 pushed must remain in + * the stack until the function '+' is called. + * + * (lambda (x y) (+ x 10) (+ y 20)) + * - the result of (+ x 10) should be popped before (+ y 20) + * is executed + * + * for the latter, inject POP_STACKTOP after each object evaluation + * except the last. + */ + int nextcop; + nextcop = (cop == COP_COMPILE_OBJECT_LIST)? COP_COMPILE_OBJECT_LIST_TAIL: + (cop == COP_COMPILE_IF_OBJECT_LIST)? COP_COMPILE_IF_OBJECT_LIST_TAIL: cop; + PUSH_SUBCFRAME (hcl, nextcop, cdr); + } + + if (cop == COP_COMPILE_OBJECT_LIST_TAIL || + cop == COP_COMPILE_IF_OBJECT_LIST_TAIL) + { + /* 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); + } + } + +done: + return 0; +} + +static int compile_array_list (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_oop_t coperand; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_ARRAY_LIST); + + coperand = cf->operand; + + if (HCL_IS_NIL(hcl, coperand)) + { + POP_CFRAME (hcl); + } + else + { + hcl_oop_t car, cdr; + hcl_ooi_t oldidx; + + if (!HCL_IS_CONS(hcl, coperand)) + { + hcl_setsynerrbfmt ( + hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in the array list - %O", coperand); /* TODO: error location */ + return -1; + } + + car = HCL_CONS_CAR(coperand); + cdr = HCL_CONS_CDR(coperand); + + oldidx = cf->u.array_list.index; + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car); + if (!HCL_IS_NIL(hcl, cdr)) + { + PUSH_SUBCFRAME (hcl, COP_COMPILE_ARRAY_LIST, cdr); + cf = GET_SUBCFRAME(hcl); + cf->u.array_list.index = oldidx + 1; + } + + PUSH_SUBCFRAME (hcl, COP_EMIT_POP_INTO_ARRAY, HCL_SMOOI_TO_OOP(oldidx)); + } + + return 0; +} + + +static int compile_bytearray_list (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_oop_t coperand; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_BYTEARRAY_LIST); + + coperand = cf->operand; + + if (HCL_IS_NIL(hcl, coperand)) + { + POP_CFRAME (hcl); + } + else + { + hcl_oop_t car, cdr; + hcl_ooi_t oldidx; + + if (!HCL_IS_CONS(hcl, coperand)) + { + hcl_setsynerrbfmt ( + hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in the byte-array list - %O", coperand); /* TODO: error location */ + return -1; + } + + car = HCL_CONS_CAR(coperand); + cdr = HCL_CONS_CDR(coperand); + + oldidx = cf->u.bytearray_list.index; + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car); + if (!HCL_IS_NIL(hcl, cdr)) + { + PUSH_SUBCFRAME (hcl, COP_COMPILE_BYTEARRAY_LIST, cdr); + cf = GET_SUBCFRAME(hcl); + cf->u.bytearray_list.index = oldidx + 1; + } + + PUSH_SUBCFRAME (hcl, COP_EMIT_POP_INTO_BYTEARRAY, HCL_SMOOI_TO_OOP(oldidx)); + } + + return 0; +} + + +static int compile_dic_list (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_oop_t coperand; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_DIC_LIST); + + coperand = cf->operand; + + if (HCL_IS_NIL(hcl, coperand)) + { + POP_CFRAME (hcl); + } + else + { + hcl_oop_t car, cdr, cadr, cddr; + + if (!HCL_IS_CONS(hcl, coperand)) + { + hcl_setsynerrbfmt ( + hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in the dictionary list - %O", coperand); /* TODO: error location */ + return -1; + } + + car = HCL_CONS_CAR(coperand); + cdr = HCL_CONS_CDR(coperand); + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car); + if (HCL_IS_NIL(hcl, cdr)) + { + hcl_setsynerrbfmt ( + hcl, HCL_SYNERR_UNBALKV, HCL_NULL, HCL_NULL, + "no value for key %O", car); + return -1; + } + + cadr = HCL_CONS_CAR(cdr); + cddr = HCL_CONS_CDR(cdr); + + if (!HCL_IS_NIL(hcl, cddr)) + { + PUSH_SUBCFRAME (hcl, COP_COMPILE_DIC_LIST, cddr); + } + + PUSH_SUBCFRAME (hcl, COP_EMIT_POP_INTO_DIC, HCL_SMOOI_TO_OOP(0)); + PUSH_SUBCFRAME(hcl, COP_COMPILE_OBJECT, cadr); + } + + return 0; +} + +static int compile_qlist (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_oop_t coperand; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_QLIST); + + coperand = cf->operand; + + if (HCL_IS_NIL(hcl, coperand)) + { + POP_CFRAME (hcl); + } + else + { + hcl_oop_t car, cdr; + hcl_ooi_t oldidx; + + if (!HCL_IS_CONS(hcl, coperand)) + { + hcl_setsynerrbfmt ( + hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in the qlist list - %O", coperand); /* TODO: error location */ + return -1; + } + + car = HCL_CONS_CAR(coperand); + cdr = HCL_CONS_CDR(coperand); + + /*oldidx = cf->u.qlist.index;*/ + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car); + if (!HCL_IS_NIL(hcl, cdr)) + { + PUSH_SUBCFRAME (hcl, COP_COMPILE_QLIST, cdr); + cf = GET_SUBCFRAME(hcl); + /*cf->u.qlist_list.index = oldidx + 1;*/ + } + + PUSH_SUBCFRAME (hcl, COP_EMIT_POP_INTO_DLIST, HCL_SMOOI_TO_OOP(oldidx)); + } + + return 0; +} + + +/* ========================================================================= */ + +static HCL_INLINE int patch_nearest_post_if_body (hcl_t* hcl) +{ + hcl_ooi_t jump_inst_pos, body_pos; + hcl_ooi_t jip, jump_offset; + hcl_cframe_t* cf; + + cf = find_cframe_from_top (hcl, COP_POST_IF_BODY); + HCL_ASSERT (hcl, cf != HCL_NULL); + + /* jump instruction position of the JUMP_FORWARD_IF_FALSE after the conditional of the previous if or elif*/ + jip = HCL_OOP_TO_SMOOI(cf->operand); + + if (hcl->code.bc.len <= cf->u.post_if.body_pos) + { + /* the if body is empty. */ + if (emit_byte_instruction (hcl, HCL_CODE_PUSH_NIL, HCL_NULL) <= -1) return -1; + } + + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + jump_inst_pos = hcl->code.bc.len; + + /* emit jump_forward before the beginning of the else block. + * this is to make the earlier if or elif block to skip + * the else part. it is to be patched in post_else_body(). */ + if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_FORWARD_0, MAX_CODE_JUMP) <= -1) return -1; + + /* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD instruction */ + jump_offset = hcl->code.bc.len - jip - (HCL_HCL_CODE_LONG_PARAM_SIZE + 1); + + if (jump_offset > MAX_CODE_JUMP * 2) + { + HCL_DEBUG1 (hcl, "code in elif/else body too big - size %zu\n", jump_offset); + hcl_setsynerr (hcl, HCL_SYNERR_IFFLOOD, HCL_NULL, HCL_NULL); /* error location */ + return -1; + } + patch_long_jump (hcl, jip, jump_offset); + + /* beginning of the elif/else block code */ + /* to drop the result of the conditional when the conditional is false */ + if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1; + + /* this is the actual beginning */ + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + body_pos = hcl->code.bc.len; + + /* modify the POST_IF_BODY frame */ + HCL_ASSERT (hcl, cf->opcode == COP_POST_IF_BODY); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + cf->operand = HCL_SMOOI_TO_OOP(jump_inst_pos); + cf->u.post_if.body_pos = body_pos; + + return 0; +} + +static HCL_INLINE int subcompile_elif (hcl_t* hcl) +{ + hcl_oop_t obj, cond, src; + hcl_cframe_t* cf; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_SUBCOMPILE_ELIF); + + src = cf->operand; + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); + HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_elif); + + obj = HCL_CONS_CDR(src); + + if (HCL_IS_NIL(hcl, obj)) + { + /* no value */ + HCL_DEBUG1 (hcl, "Syntax error - no condition specified in elif - %O\n", src); + hcl_setsynerr (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL); /* TODO: error location */ + return -1; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in elif - %O\n", src); + hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */ + return -1; + } + + cond = HCL_CONS_CAR(obj); + obj = HCL_CONS_CDR(obj); + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, cond); /* 1 */ + PUSH_SUBCFRAME (hcl, COP_POST_IF_COND, obj); /* 2 */ + cf = GET_SUBCFRAME (hcl); + cf->u.post_if.body_pos = -1; /* unknown yet */ + + return patch_nearest_post_if_body (hcl); +} + +static HCL_INLINE int subcompile_else (hcl_t* hcl) +{ + hcl_oop_t obj, src; + hcl_cframe_t* cf; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_SUBCOMPILE_ELSE); + + src = cf->operand; + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, src)); + HCL_ASSERT (hcl, HCL_CONS_CAR(src) == hcl->_else); + + obj = HCL_CONS_CDR(src); + + if (!HCL_IS_NIL(hcl, obj) && !HCL_IS_CONS(hcl, obj)) + { + HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in else - %O\n", src); + hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */ + return -1; + } + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, obj); + + return patch_nearest_post_if_body (hcl); +} + +/* ========================================================================= */ + +static HCL_INLINE int subcompile_and_expr (hcl_t* hcl) +{ + hcl_oop_t obj, expr; + hcl_cframe_t* cf; + hcl_ooi_t jump_inst_pos; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_SUBCOMPILE_AND_EXPR); + + obj = cf->operand; + +/* TODO: optimization - eat away all true expressions */ + if (HCL_IS_NIL(hcl, obj)) + { + /* no more */ + POP_CFRAME (hcl); + return 0; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in and - %O", obj); /* TODO: error location */ + return -1; + } + + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + jump_inst_pos = hcl->code.bc.len; + + 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); + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */ + + PUSH_SUBCFRAME (hcl, COP_POST_AND_EXPR, obj); /* 3 */ + cf = GET_SUBCFRAME(hcl); + cf->operand = HCL_SMOOI_TO_OOP(jump_inst_pos); + + PUSH_SUBCFRAME (hcl, COP_SUBCOMPILE_AND_EXPR, obj); /* 2 */ + + return 0; +} + +static HCL_INLINE int post_and_expr (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_ooi_t jip; + hcl_oow_t jump_offset; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_POST_AND_EXPR); + + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + jip = HCL_OOP_TO_SMOOI(cf->operand); + + /* patch the jump insruction emitted after each expression inside the 'and' expression */ + jump_offset = hcl->code.bc.len - jip - (HCL_HCL_CODE_LONG_PARAM_SIZE + 1); + patch_long_jump (hcl, jip, jump_offset); + + POP_CFRAME(hcl); + return 0; +} + +/* ========================================================================= */ + +static HCL_INLINE int subcompile_or_expr (hcl_t* hcl) +{ + hcl_oop_t obj, expr; + hcl_cframe_t* cf; + hcl_ooi_t jump_inst_pos; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_SUBCOMPILE_OR_EXPR); + + obj = cf->operand; + +/* TODO: optimization - eat away all false expressions */ + if (HCL_IS_NIL(hcl, obj)) + { + /* no more */ + POP_CFRAME (hcl); + return 0; + } + else if (!HCL_IS_CONS(hcl, obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in or - %O", obj); /* TODO: error location */ + return -1; + } + + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + jump_inst_pos = hcl->code.bc.len; + + 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); + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */ + + PUSH_SUBCFRAME (hcl, COP_POST_OR_EXPR, obj); /* 3 */ + cf = GET_SUBCFRAME(hcl); + cf->operand = HCL_SMOOI_TO_OOP(jump_inst_pos); + + PUSH_SUBCFRAME (hcl, COP_SUBCOMPILE_OR_EXPR, obj); /* 2 */ + + return 0; +} + +static HCL_INLINE int post_or_expr (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_ooi_t jip; + hcl_oow_t jump_offset; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_POST_OR_EXPR); + + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + jip = HCL_OOP_TO_SMOOI(cf->operand); + + /* patch the jump insruction emitted after each expression inside the 'and' expression */ + jump_offset = hcl->code.bc.len - jip - (HCL_HCL_CODE_LONG_PARAM_SIZE + 1); + patch_long_jump (hcl, jip, jump_offset); + + POP_CFRAME(hcl); + return 0; +} + +/* ========================================================================= */ + +static HCL_INLINE int post_if_cond (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_ooi_t jump_inst_pos; + hcl_ooi_t body_pos; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_POST_IF_COND); + + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + jump_inst_pos = hcl->code.bc.len; + + if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_FORWARD_IF_FALSE, MAX_CODE_JUMP) <= -1) return -1; + + /* to drop the result of the conditional when it is true */ + if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1; + + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + body_pos = hcl->code.bc.len; + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_IF_OBJECT_LIST, cf->operand); /* 1 */ + PUSH_SUBCFRAME (hcl, COP_POST_IF_BODY, HCL_SMOOI_TO_OOP(jump_inst_pos)); /* 2 */ + cf = GET_SUBCFRAME(hcl); + cf->u.post_if.body_pos = body_pos; + return 0; +} + +static HCL_INLINE int post_if_body (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_ooi_t jip; + hcl_oow_t jump_offset; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_POST_IF_BODY); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + jip = HCL_OOP_TO_SMOOI(cf->operand); + + if (hcl->code.bc.len <= cf->u.post_if.body_pos) + { + /* if body is empty */ + if (emit_byte_instruction (hcl, HCL_CODE_PUSH_NIL, HCL_NULL) <= -1) return -1; + } + + /* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD_IF_FALSE instruction */ + jump_offset = hcl->code.bc.len - jip - (HCL_HCL_CODE_LONG_PARAM_SIZE + 1); + + if (jump_offset > MAX_CODE_JUMP * 2) + { + HCL_DEBUG1 (hcl, "code in if-else body too big - size %zu\n", jump_offset); + hcl_setsynerr (hcl, HCL_SYNERR_IFFLOOD, HCL_NULL, HCL_NULL); /* error location */ + return -1; + } + patch_long_jump (hcl, jip, jump_offset); + + POP_CFRAME (hcl); + return 0; +} + +/* ========================================================================= */ +static HCL_INLINE int post_while_cond (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_ooi_t jump_inst_pos; + hcl_ooi_t cond_pos, body_pos; + int jump_inst, next_cop; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_POST_UNTIL_COND || cf->opcode == COP_POST_WHILE_COND); + + cond_pos = cf->u.post_while.cond_pos; + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + jump_inst_pos = hcl->code.bc.len; + + if (cf->opcode == COP_POST_UNTIL_COND) + { + jump_inst = HCL_CODE_JUMP_FORWARD_IF_TRUE; + next_cop = COP_POST_UNTIL_BODY; + } + else + { + jump_inst = HCL_CODE_JUMP_FORWARD_IF_FALSE; + next_cop = COP_POST_WHILE_BODY; + } + + if (emit_single_param_instruction (hcl, jump_inst, MAX_CODE_JUMP) <= -1) return -1; + if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1; + + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + body_pos = hcl->code.bc.len; + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, cf->operand); /* 1 */ + PUSH_SUBCFRAME (hcl, next_cop, HCL_SMOOI_TO_OOP(jump_inst_pos)); /* 2 */ + cf = GET_SUBCFRAME(hcl); + cf->u.post_while.cond_pos = cond_pos; + cf->u.post_while.body_pos = body_pos; + return 0; +} + +static HCL_INLINE int post_while_body (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_ooi_t jip; + hcl_ooi_t jump_offset; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_POST_UNTIL_BODY || cf->opcode == COP_POST_WHILE_BODY); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + HCL_ASSERT (hcl, hcl->code.bc.len >= cf->u.post_while.cond_pos); + if (hcl->code.bc.len > cf->u.post_while.body_pos) + { + /* some code exist after POP_STACKTOP after JUMP_FORWARD_IF_TRUE/FALSE. + * (until #f) => + * push_false + * jump_forward_if_true XXXX + * pop_stacktop <-- 1) emitted in post_while_cond(); + * jump_backward YYYY <-- 2) emitted below + * pop_stacktop + * this check prevents another pop_stacktop between 1) and 2) + */ + if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1; + } + + HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); + jump_offset = hcl->code.bc.len - cf->u.post_while.cond_pos + 1; + if (jump_offset > 3) jump_offset += HCL_HCL_CODE_LONG_PARAM_SIZE; + if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_BACKWARD_0, jump_offset) <= -1) return -1; + + jip = HCL_OOP_TO_SMOOI(cf->operand); + /* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD_IF_FALSE/JUMP_FORWARD_IF_TRUE instruction */ + jump_offset = hcl->code.bc.len - jip - (HCL_HCL_CODE_LONG_PARAM_SIZE + 1); + if (jump_offset > MAX_CODE_JUMP * 2) + { + HCL_DEBUG1 (hcl, "code in loop body too big - size %zu\n", jump_offset); + hcl_setsynerr (hcl, HCL_SYNERR_BLKFLOOD, HCL_NULL, HCL_NULL); /* error location */ + return -1; + } + patch_long_jump (hcl, jip, jump_offset); + + POP_CFRAME (hcl); + return 0; +} + +/* ========================================================================= */ + +static int update_break (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_ooi_t jip, jump_offset; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_UPDATE_BREAK); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + jip = HCL_OOP_TO_SMOOI(cf->operand); + + /* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD instruction */ + jump_offset = hcl->code.bc.len - jip - (HCL_HCL_CODE_LONG_PARAM_SIZE + 1); + + /* no explicit about jump_offset. because break can only place inside + * a loop, the same check in post_while_body() must assert + * this break jump_offset to be small enough */ + HCL_ASSERT (hcl, jump_offset <= MAX_CODE_JUMP * 2); + patch_long_jump (hcl, jip, jump_offset); + + POP_CFRAME (hcl); + return 0; +} + +/* ========================================================================= */ + +static HCL_INLINE int emit_call (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_CALL); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + n = emit_single_param_instruction (hcl, HCL_CODE_CALL_0, HCL_OOP_TO_SMOOI(cf->operand)); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_make_array (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_ARRAY); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + n = emit_single_param_instruction (hcl, HCL_CODE_MAKE_ARRAY, HCL_OOP_TO_SMOOI(cf->operand)); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_make_bytearray (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_BYTEARRAY); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + n = emit_single_param_instruction (hcl, HCL_CODE_MAKE_BYTEARRAY, HCL_OOP_TO_SMOOI(cf->operand)); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_make_dic (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_DIC); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + n = emit_single_param_instruction (hcl, HCL_CODE_MAKE_DIC, HCL_OOP_TO_SMOOI(cf->operand)); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_make_dlist (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_DLIST); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + n = emit_single_param_instruction (hcl, HCL_CODE_MAKE_DLIST, HCL_OOP_TO_SMOOI(cf->operand)); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_pop_into_array (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_ARRAY); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + n = emit_single_param_instruction (hcl, HCL_CODE_POP_INTO_ARRAY, HCL_OOP_TO_SMOOI(cf->operand)); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_pop_into_bytearray (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_BYTEARRAY); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + n = emit_single_param_instruction (hcl, HCL_CODE_POP_INTO_BYTEARRAY, HCL_OOP_TO_SMOOI(cf->operand)); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_pop_into_dic (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_DIC); + + n = emit_byte_instruction (hcl, HCL_CODE_POP_INTO_DIC, HCL_NULL); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_pop_into_dlist (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_DLIST); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + n = emit_single_param_instruction (hcl, HCL_CODE_POP_INTO_DLIST, HCL_OOP_TO_SMOOI(cf->operand)); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_lambda (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_oow_t block_code_size, lfsize; + hcl_ooi_t jip; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_LAMBDA); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + jip = HCL_OOP_TO_SMOOI(cf->operand); + + if (hcl->option.trait & HCL_TRAIT_INTERACTIVE) + lfsize = hcl->code.lit.len - hcl->c->blk.info[hcl->c->blk.depth].lfbase; + + hcl->c->blk.depth--; + hcl->c->tv.size = hcl->c->blk.info[hcl->c->blk.depth].tmprcnt; + + /* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD instruction */ + block_code_size = hcl->code.bc.len - jip - (HCL_HCL_CODE_LONG_PARAM_SIZE + 1); + + if (block_code_size == 0) + { + /* no body in lambda - (lambda (a b c)) */ +/* TODO: is this correct??? */ + if (emit_byte_instruction(hcl, HCL_CODE_PUSH_NIL, HCL_NULL) <= -1) return -1; + block_code_size++; + } + + if (emit_byte_instruction(hcl, HCL_CODE_RETURN_FROM_BLOCK, HCL_NULL) <= -1) return -1; + block_code_size++; + + if (block_code_size > MAX_CODE_JUMP * 2) + { + HCL_DEBUG1 (hcl, "Too big a lambda block - size %zu\n", block_code_size); + hcl_setsynerr (hcl, HCL_SYNERR_BLKFLOOD, HCL_NULL, HCL_NULL); /* error location */ + return -1; + } + patch_long_jump (hcl, jip, block_code_size); + + if (hcl->option.trait & HCL_TRAIT_INTERACTIVE) + patch_long_param (hcl, cf->u.lambda.lfsize_pos, lfsize); + + POP_CFRAME (hcl); + return 0; +} + +static HCL_INLINE int emit_pop_stacktop (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_STACKTOP); + HCL_ASSERT (hcl, HCL_IS_NIL(hcl, cf->operand)); + + n = emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_NULL); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_return (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_RETURN); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + n = emit_byte_instruction(hcl, (HCL_OOP_TO_SMOOI(cf->operand) == 0? HCL_CODE_RETURN_FROM_BLOCK: HCL_CODE_RETURN_STACKTOP), HCL_NULL); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_set (hcl_t* hcl) +{ + hcl_cframe_t* cf; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_SET); + + + if (cf->u.set.var_type == VAR_NAMED) + { + hcl_oow_t index; + hcl_oop_t cons; + + HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, cf->operand)); + + cons = (hcl_oop_t)hcl_getatsysdic(hcl, cf->operand); + if (!cons) + { + cons = (hcl_oop_t)hcl_putatsysdic(hcl, cf->operand, hcl->_nil); + if (!cons) return -1; + } + + if (add_literal(hcl, cons, &index) <= -1 || + emit_single_param_instruction(hcl, HCL_CODE_STORE_INTO_OBJECT_0, index) <= -1) return -1; + } + else + { + hcl_oow_t index; + HCL_ASSERT (hcl, cf->u.set.var_type == VAR_INDEXED); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + index = (hcl_oow_t)HCL_OOP_TO_SMOOI(cf->operand); + if (emit_indexed_variable_access(hcl, index, HCL_CODE_STORE_INTO_CTXTEMPVAR_0, HCL_CODE_STORE_INTO_TEMPVAR_0) <= -1) return -1; + } + + POP_CFRAME (hcl); + return 0; +} + +/* ========================================================================= */ + +int hcl_compile (hcl_t* hcl, hcl_oop_t obj) +{ + hcl_oow_t saved_bc_len, saved_lit_len; + hcl_bitmask_t log_default_type_mask; + + HCL_ASSERT (hcl, GET_TOP_CFRAME_INDEX(hcl) < 0); + + saved_bc_len = hcl->code.bc.len; + saved_lit_len = hcl->code.lit.len; + + log_default_type_mask = hcl->log.default_type_mask; + hcl->log.default_type_mask |= HCL_LOG_COMPILER; + + HCL_ASSERT (hcl, hcl->c->tv.size == 0); + HCL_ASSERT (hcl, hcl->c->blk.depth == -1); + +/* TODO: in case i implement all global variables as block arguments at the top level...what should i do? */ + + hcl->c->blk.depth++; /* this must be 0 here */ + + /* + * In the non-INTERACTIVE mode, the literal frame base doesn't matter. + * Only the initial function object contains the literal frame. + * No other function objects are created. All lambda defintions are + * translated to base context objects instead. + * + * In the INTERACTIVE mode, the literal frame base plays a key role. + * hcl_compile() is called for the top-level expression andthe literal + * frame base can be 0. The means it is ok for a top-level code to + * reference part of the literal frame reserved for a lambda function. + * + * (set b 1) + * (defun set-a(x) (set a x)) + * (set a 2) + * (set-a 4) + * (printf "%d\n" a) + * + * the global literal frame looks like this: + * @0 (b) + * @1 (a) + * @2 (set-a) + * @3 (printf . #) + * @4 "%d\n" + * + * @1 to @2 will be copied to a function object when defun is executed. + * The literal frame of the created function object for set-a looks + * like this + * @0 (a) + * @1 (set-a) + */ + if (store_temporary_variable_count_for_block(hcl, hcl->c->tv.size, 0) <= -1) return -1; + + PUSH_CFRAME (hcl, COP_COMPILE_OBJECT, obj); + + while (GET_TOP_CFRAME_INDEX(hcl) >= 0) + { + hcl_cframe_t* cf; + + cf = GET_TOP_CFRAME(hcl); + +/* TODO: tabulate this switch-based dispatch */ + switch (cf->opcode) + { + case COP_COMPILE_OBJECT: + if (compile_object(hcl) <= -1) goto oops; + break; + + case COP_COMPILE_OBJECT_LIST: + case COP_COMPILE_OBJECT_LIST_TAIL: + case COP_COMPILE_IF_OBJECT_LIST: + case COP_COMPILE_IF_OBJECT_LIST_TAIL: + case COP_COMPILE_ARGUMENT_LIST: + if (compile_object_list(hcl) <= -1) goto oops; + break; + + case COP_COMPILE_ARRAY_LIST: + if (compile_array_list(hcl) <= -1) goto oops; + break; + + case COP_COMPILE_BYTEARRAY_LIST: + if (compile_bytearray_list(hcl) <= -1) goto oops; + break; + + case COP_COMPILE_DIC_LIST: + if (compile_dic_list(hcl) <= -1) goto oops; + break; + + case COP_COMPILE_QLIST: + if (compile_qlist(hcl) <= -1) goto oops; + break; + + case COP_EMIT_CALL: + if (emit_call(hcl) <= -1) goto oops; + break; + + case COP_EMIT_MAKE_ARRAY: + if (emit_make_array(hcl) <= -1) goto oops; + break; + + case COP_EMIT_MAKE_BYTEARRAY: + if (emit_make_bytearray(hcl) <= -1) goto oops; + break; + + case COP_EMIT_MAKE_DIC: + if (emit_make_dic(hcl) <= -1) goto oops; + break; + + case COP_EMIT_MAKE_DLIST: + if (emit_make_dlist(hcl) <= -1) goto oops; + break; + + case COP_EMIT_POP_INTO_ARRAY: + if (emit_pop_into_array(hcl) <= -1) goto oops; + break; + + case COP_EMIT_POP_INTO_BYTEARRAY: + if (emit_pop_into_bytearray(hcl) <= -1) goto oops; + break; + + case COP_EMIT_POP_INTO_DLIST: + if (emit_pop_into_dlist(hcl) <= -1) goto oops; + break; + + case COP_EMIT_POP_INTO_DIC: + if (emit_pop_into_dic(hcl) <= -1) goto oops; + break; + + case COP_EMIT_LAMBDA: + if (emit_lambda(hcl) <= -1) goto oops; + break; + + case COP_EMIT_POP_STACKTOP: + if (emit_pop_stacktop(hcl) <= -1) goto oops; + break; + + case COP_EMIT_RETURN: + if (emit_return(hcl) <= -1) goto oops; + break; + + case COP_EMIT_SET: + if (emit_set(hcl) <= -1) goto oops; + break; + + case COP_SUBCOMPILE_AND_EXPR: + if (subcompile_and_expr(hcl) <= -1) goto oops; + break; + + case COP_SUBCOMPILE_OR_EXPR: + if (subcompile_or_expr(hcl) <= -1) goto oops; + break; + + case COP_POST_AND_EXPR: + if (post_and_expr(hcl) <= -1) goto oops; + break; + + case COP_POST_OR_EXPR: + if (post_or_expr(hcl) <= -1) goto oops; + break; + + case COP_POST_IF_COND: + if (post_if_cond(hcl) <= -1) goto oops; + break; + + case COP_POST_IF_BODY: + if (post_if_body(hcl) <= -1) goto oops; + break; + + case COP_POST_UNTIL_BODY: + case COP_POST_WHILE_BODY: + if (post_while_body(hcl) <= -1) goto oops; + break; + + case COP_POST_UNTIL_COND: + case COP_POST_WHILE_COND: + if (post_while_cond(hcl) <= -1) goto oops; + break; + + case COP_SUBCOMPILE_ELIF: + if (subcompile_elif(hcl) <= -1) goto oops; + break; + + case COP_SUBCOMPILE_ELSE: + if (subcompile_else(hcl) <= -1) goto oops; + break; + + case COP_UPDATE_BREAK: + if (update_break(hcl) <= -1) goto oops; + break; + + default: + HCL_DEBUG1 (hcl, "Internal error - invalid compiler opcode %d\n", cf->opcode); + hcl_seterrbfmt (hcl, HCL_EINTERN, "invalid compiler opcode %d", cf->opcode); + goto oops; + } + } + + /* emit the pop instruction to clear the final result */ +/* TODO: for interactive use, this value must be accessible by the executor... how to do it? */ + if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) goto oops; + + HCL_ASSERT (hcl, GET_TOP_CFRAME_INDEX(hcl) < 0); + HCL_ASSERT (hcl, hcl->c->tv.size == 0); + HCL_ASSERT (hcl, hcl->c->blk.depth == 0); + hcl->c->blk.depth--; + + hcl ->log.default_type_mask = log_default_type_mask; + return 0; + +oops: + POP_ALL_CFRAMES (hcl); + + hcl->log.default_type_mask = log_default_type_mask; + + /* rollback any bytecodes or literals emitted so far */ + hcl->code.bc.len = saved_bc_len; + hcl->code.lit.len = saved_lit_len; + + hcl->c->tv.size = 0; + hcl->c->blk.depth = -1; + return -1; +} diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 1998d8f..69635a4 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -216,7 +216,6 @@ enum hcl_cnode_type_t typedef enum hcl_cnode_type_t hcl_cnode_type_t; /* NOTE: hcl_cnode_t used by the built-in compiler is not an OOP object */ -typedef struct hcl_cnode_t hcl_cnode_t; struct hcl_cnode_t { hcl_cnode_type_t type; @@ -376,9 +375,7 @@ struct hcl_compiler_t { hcl_oop_t s; /* stack for reading */ hcl_oop_t e; /* last object read */ - hcl_rstl_t* st; - hcl_cnode_t* ecn; /* last object cnode read */ struct { diff --git a/lib/hcl.h b/lib/hcl.h index 5ef4eac..5b5ba0d 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -1368,6 +1368,7 @@ struct hcl_synerr_t #if defined(HCL_INCLUDE_COMPILER) typedef struct hcl_compiler_t hcl_compiler_t; +typedef struct hcl_cnode_t hcl_cnode_t; #endif #define HCL_ERRMSG_CAPA (2048) @@ -1977,6 +1978,10 @@ HCL_EXPORT hcl_oop_t hcl_read ( hcl_t* hcl ); +HCL_EXPORT hcl_cnode_t* hcl_read2 ( + hcl_t* hcl +); + HCL_EXPORT int hcl_print ( hcl_t* hcl, diff --git a/lib/read2.c b/lib/read2.c index 20c85ff..af19c58 100644 --- a/lib/read2.c +++ b/lib/read2.c @@ -414,7 +414,7 @@ static HCL_INLINE int add_token_char (hcl_t* hcl, hcl_ooch_t c) tmp.ptr = &c; tmp.len = 1; - return copy_string_to (hcl, &tmp, TOKEN_NAME(hcl), &TOKEN_NAME_CAPA(hcl), 1, '\0'); + return copy_string_to(hcl, &tmp, TOKEN_NAME(hcl), &TOKEN_NAME_CAPA(hcl), 1, '\0'); } static HCL_INLINE void unget_char (hcl_t* hcl, const hcl_iolxc_t* c) @@ -1438,6 +1438,7 @@ static HCL_INLINE hcl_cnode_t* leave_list (hcl_t* hcl, int* flagv, int* oldflagv if (fv & (COMMAED | COLONED)) { hcl_setsynerr (hcl, ((fv & COMMAED)? HCL_SYNERR_COMMANOVALUE: HCL_SYNERR_COLONNOVALUE), TOKEN_LOC(hcl), HCL_NULL); + if (head) hcl_freecnode (hcl, head); return HCL_NULL; } @@ -1455,12 +1456,12 @@ static HCL_INLINE hcl_cnode_t* leave_list (hcl_t* hcl, int* flagv, int* oldflagv *flagv = hcl->c->r.st->flagv; } - /* return the head of the list being left */ - /* NOTE: empty xlist will get translated to #nil. * this is useful when used in the lambda expression to express an empty argument. also in defun. * (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; @@ -1537,7 +1538,7 @@ static HCL_INLINE void clear_comma_colon_flag (hcl_t* hcl) rstl->flagv &= ~(COMMAED | COLONED); } -static hcl_cnode_t* chain_to_list (hcl_t* hcl, hcl_cnode_t* obj) +static int chain_to_list (hcl_t* hcl, hcl_cnode_t* obj) { hcl_rstl_t* rstl; int flagv; @@ -1555,7 +1556,7 @@ static hcl_cnode_t* chain_to_list (hcl_t* hcl, hcl_cnode_t* obj) * allowed. so i can safely hard-code the error code to * HCL_SYNERR_RBRACK. */ hcl_setsynerr (hcl, HCL_SYNERR_RBRACK, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return HCL_NULL; + return -1; } else if (flagv & DOTTED) { @@ -1587,11 +1588,11 @@ static hcl_cnode_t* chain_to_list (hcl_t* hcl, hcl_cnode_t* obj) /* there is no separator between array/dictionary elements * for instance, [1 2] { 10 20 } */ hcl_setsynerr (hcl, HCL_SYNERR_NOSEP, TOKEN_LOC(hcl), HCL_NULL); - return HCL_NULL; + return -1; } cons = hcl_makecnodecons(hcl, &obj->loc, obj, HCL_NULL); - if (HCL_UNLIKELY(!cons)) return HCL_NULL; + if (HCL_UNLIKELY(!cons)) return -1; if (rstl->count <= 0) { @@ -1610,7 +1611,7 @@ static hcl_cnode_t* chain_to_list (hcl_t* hcl, hcl_cnode_t* obj) * append it to the list */ tail = rstl->tail; HCL_ASSERT (hcl, tail->type == HCL_CNODE_CONS); - tail->u.cons.cdr = obj; + tail->u.cons.cdr = cons; rstl->tail = cons; } @@ -1618,7 +1619,7 @@ static hcl_cnode_t* chain_to_list (hcl_t* hcl, hcl_cnode_t* obj) rstl->count++; } - return obj; + return 0; } static hcl_cnode_t* read_vlist (hcl_t* hcl) @@ -1686,13 +1687,13 @@ oops: return HCL_NULL; } -static int read_object (hcl_t* hcl) +static hcl_cnode_t* read_object (hcl_t* hcl) { /* this function read an s-expression non-recursively * by manipulating its own stack. */ int level = 0, array_level = 0, flagv = 0; - hcl_cnode_t* obj; + hcl_cnode_t* obj = HCL_NULL; while (1) { @@ -1701,11 +1702,11 @@ static int read_object (hcl_t* hcl) { default: hcl_setsynerr (hcl, HCL_SYNERR_ILTOK, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; + goto oops; case HCL_IOTOK_EOF: hcl_setsynerr (hcl, HCL_SYNERR_EOF, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; + goto oops; case HCL_IOTOK_INCLUDE: /* TODO: should i limit where #include can be specified? @@ -1714,9 +1715,9 @@ static int read_object (hcl_t* hcl) if (TOKEN_TYPE(hcl) != HCL_IOTOK_STRLIT) { hcl_setsynerr (hcl, HCL_SYNERR_STRING, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; + goto oops; } - if (begin_include(hcl) <= -1) return -1; + if (begin_include(hcl) <= -1) goto oops; goto redo; case HCL_IOTOK_LBRACK: /* [] */ @@ -1737,7 +1738,7 @@ static int read_object (hcl_t* hcl) case HCL_IOTOK_QLPAREN: /* #() */ #if 1 hcl_setsynerr (hcl, HCL_SYNERR_ILTOK, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; + goto oops; #else flagv = 0; LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_QLIST); @@ -1752,17 +1753,17 @@ static int read_object (hcl_t* hcl) { /* the nesting level has become too deep */ hcl_setsynerr (hcl, HCL_SYNERR_NESTING, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; + goto oops; } /* push some data to simulate recursion into * a list literal or an array literal */ - if (enter_list(hcl, TOKEN_LOC(hcl), flagv) <= -1) return -1; + if (enter_list(hcl, TOKEN_LOC(hcl), flagv) <= -1) goto oops; level++; if (LIST_FLAG_GET_CONCODE(flagv) == HCL_CONCODE_ARRAY) array_level++; /* read the next token */ - GET_TOKEN (hcl); + GET_TOKEN_WITH_GOTO (hcl, oops); goto redo; case HCL_IOTOK_DOT: @@ -1773,30 +1774,30 @@ static int read_object (hcl_t* hcl) * 2. at the beginning of a list * 3. inside an #(), #[], #{}, () */ hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, TOKEN_LOC(hcl), HCL_NULL); - return -1; + goto oops; } - GET_TOKEN (hcl); + GET_TOKEN_WITH_GOTO (hcl, oops); goto redo; case HCL_IOTOK_COLON: if (level <= 0 || !can_colon_list(hcl)) { hcl_setsynerr (hcl, HCL_SYNERR_COLONBANNED, TOKEN_LOC(hcl), HCL_NULL); - return -1; + goto oops; } - GET_TOKEN (hcl); + GET_TOKEN_WITH_GOTO (hcl, oops); goto redo; case HCL_IOTOK_COMMA: if (level <= 0 || !can_comma_list(hcl)) { hcl_setsynerr (hcl, HCL_SYNERR_COMMABANNED, TOKEN_LOC(hcl), HCL_NULL); - return -1; + goto oops; } - GET_TOKEN (hcl); + GET_TOKEN_WITH_GOTO (hcl, oops); goto redo; case HCL_IOTOK_RPAREN: /* xlist (), qlist #() */ @@ -1822,7 +1823,7 @@ static int read_object (hcl_t* hcl) if (level <= 0) { hcl_setsynerr (hcl, HCL_SYNERR_UNBALPBB, TOKEN_LOC(hcl), HCL_NULL); - return -1; + goto oops; } concode = LIST_FLAG_GET_CONCODE(flagv); @@ -1830,7 +1831,7 @@ static int read_object (hcl_t* hcl) if (req[concode].closer != TOKEN_TYPE(hcl)) { hcl_setsynerr (hcl, req[concode].synerr, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; + goto oops; } #if 0 @@ -1854,7 +1855,7 @@ static int read_object (hcl_t* hcl) * indicated by level<=0. */ hcl_setsynerr (hcl, HCL_SYNERR_LPAREN, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; + goto oops; } #endif obj = leave_list(hcl, &flagv, &oldflagv); @@ -1870,7 +1871,7 @@ static int read_object (hcl_t* hcl) if (array_level > 0) /* TODO: this check is wrong... i think .. */ { hcl_setsynerr (hcl, HCL_SYNERR_VBARBANNED, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; + goto oops; } obj = read_vlist(hcl); break; @@ -1902,7 +1903,7 @@ static int read_object (hcl_t* hcl) if (!HCL_IN_SMPTR_RANGE(v)) { hcl_setsynerr (hcl, HCL_SYNERR_SMPTRLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; + goto oops; } obj = hcl_makecnodesmptrlit(hcl, TOKEN_LOC(hcl), v); @@ -1923,7 +1924,7 @@ static int read_object (hcl_t* hcl) if (v > HCL_ERROR_MAX) { hcl_setsynerr (hcl, HCL_SYNERR_ERRLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; + goto oops; } } @@ -1979,7 +1980,7 @@ static int read_object (hcl_t* hcl) if (!pfbase) { /* TODO switch to syntax error */ - return -1; + goto oops; } hcl_pushvolat (hcl, &obj); @@ -2005,13 +2006,13 @@ static int read_object (hcl_t* hcl) default: hcl_popvolat (hcl); hcl_seterrbfmt (hcl, HCL_EINVAL, "invalid pfbase type - %d\n", pfbase->type); - return -1; + goto oops; } if (!val || !hcl_putatsysdic(hcl, obj, val)) { hcl_popvolat (hcl); - return -1; + goto oops; } hcl_popvolat (hcl); @@ -2023,7 +2024,7 @@ static int read_object (hcl_t* hcl) break; } - if (!obj) return -1; + if (!obj) goto oops; #if 0 /* check if the element is read for a quoted list */ @@ -2034,11 +2035,7 @@ static int read_object (hcl_t* hcl) HCL_ASSERT (hcl, level > 0); /* if so, append the element read into the quote list */ - if (chain_to_list(hcl, obj) == HCL_NULL) - { - hcl_freecnode (hcl, obj); - return -1; - } + if (chain_to_list(hcl, obj) <= -1) goto oops; /* exit out of the quoted list. the quoted list can have * one element only. */ @@ -2056,43 +2053,38 @@ static int read_object (hcl_t* hcl) /* 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) - { - hcl_freecnode (hcl, obj); - return -1; - } + if (chain_to_list(hcl, obj) <= -1) goto oops; clear_comma_colon_flag (hcl); /* read the next token */ - GET_TOKEN (hcl); + GET_TOKEN_WITH_GOTO (hcl, oops); } /* upon exit, we must be at the top level */ HCL_ASSERT (hcl, level == 0); HCL_ASSERT (hcl, array_level == 0); - hcl->c->r.ecn = obj; - return 0; + return obj; + +oops: + if (obj) hcl_freecnode (hcl, obj); + return HCL_NULL; } -static HCL_INLINE int __read (hcl_t* hcl) +hcl_cnode_t* hcl_read2 (hcl_t* hcl) { - if (get_token(hcl) <= -1) return -1; + HCL_ASSERT (hcl, hcl->c && hcl->c->reader); + if (get_token(hcl) <= -1) return HCL_NULL; if (TOKEN_TYPE(hcl) == HCL_IOTOK_EOF) { hcl_seterrnum (hcl, HCL_EFINIS); - return -1; + return HCL_NULL; } return read_object(hcl); } -hcl_oop_t hcl_read (hcl_t* hcl) -{ - HCL_ASSERT (hcl, hcl->c && hcl->c->reader); - if (__read(hcl) <= -1) return HCL_NULL; - return hcl->c->r.e; -} +#if 0 /* ========================================================================= */ /* TODO: rename compiler to something else that can include reader, printer, and compiler @@ -2329,3 +2321,4 @@ int hcl_unreadchar (hcl_t* hcl, const hcl_iolxc_t* c) unget_char (hcl, c); return 0; } +#endif