From d4fbd0a298da688fb14ff403e22887a892bd2634 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Fri, 29 Jan 2021 08:35:31 +0000 Subject: [PATCH] removed hcl_read() and hcl_compile(). in the next commit(), hcl_read2() and hcl_compile2() will get renamed to hcl_read() and hcl_compile() respectively --- bin/main.c | 111 +- lib/Makefile.am | 2 - lib/Makefile.in | 46 +- lib/comp.c | 3000 ----------------------------------------------- lib/comp2.c | 1 - lib/hcl-s.c | 16 +- lib/hcl.h | 8 +- lib/read.c | 2456 -------------------------------------- lib/read2.c | 22 +- 9 files changed, 45 insertions(+), 5617 deletions(-) delete mode 100644 lib/comp.c delete mode 100644 lib/read.c diff --git a/bin/main.c b/bin/main.c index cac769a..0ebb184 100644 --- a/bin/main.c +++ b/bin/main.c @@ -1173,12 +1173,16 @@ hcl_logufmt (hcl, HCL_LOG_WARN, fmt, ustr, 0x6789); } #endif -#if 1 while (1) { hcl_cnode_t* obj; int n; +/* +static int count = 0; +if (count %5 == 0) hcl_reset (hcl); +count++; +*/ obj = hcl_read2(hcl); if (!obj) { @@ -1269,111 +1273,6 @@ hcl_logufmt (hcl, HCL_LOG_WARN, fmt, ustr, 0x6789); g_hcl = HCL_NULL; } } -#else - - while (1) - { - hcl_oop_t obj; -/* -static int count = 0; -if (count %5 == 0) hcl_reset (hcl); -count++; -*/ - obj = hcl_read(hcl); - if (!obj) - { - 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; - } - - if (verbose && hcl_print(hcl, obj) <= -1) - { - hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot print object - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); - } - else - { - if (xtn->reader_istty) - { - /* clear the byte code buffer */ - /* TODO: create a proper function for this and call it */ - hcl->code.bc.len = 0; - hcl->code.lit.len = 0; - } - - if (verbose) hcl_prbfmt (hcl, "\n"); /* flush the output buffer by hcl_print above */ - - if (hcl_compile(hcl, obj) <= -1) - { - if (hcl->errnum == HCL_ESYNERR) - { - print_synerr (hcl); - } - else - { - hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot compile object - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); - } - /* carry on? */ - - if (!xtn->reader_istty) goto oops; - } - else if (xtn->reader_istty) - { - /* interactive mode */ - hcl_oop_t retv; - - hcl_decode (hcl, 0, hcl_getbclen(hcl)); - HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n"); - g_hcl = hcl; - //setup_tick (); - - retv = hcl_execute(hcl); - - /* flush pending output data in the interactive mode(e.g. printf without a newline) */ - hcl_flushio (hcl); - - if (!retv) - { - hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot execute - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); - } - else - { - /* print the result in the interactive mode regardless 'verbose' */ - hcl_logbfmt (hcl, HCL_LOG_STDOUT, "%O\n", retv); - - /* - * print the value of ERRSTR. - hcl_oop_cons_t cons = hcl_getatsysdic(hcl, xtn->sym_errstr); - if (cons) - { - HCL_ASSERT (hcl, HCL_IS_CONS(hcl, cons)); - HCL_ASSERT (hcl, HCL_CONS_CAR(cons) == xtn->sym_errstr); - hcl_print (hcl, HCL_CONS_CDR(cons)); - } - */ - } - //cancel_tick(); - g_hcl = HCL_NULL; - } - } - } -#endif if (!xtn->reader_istty && hcl_getbclen(hcl) > 0) { diff --git a/lib/Makefile.am b/lib/Makefile.am index 2b84be5..3b8ad46 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -65,7 +65,6 @@ libhcl_la_SOURCES = \ hcl-prv.h \ bigint.c \ cnode.c \ - comp.c \ comp2.c \ debug.c \ decode.c \ @@ -84,7 +83,6 @@ 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 9765a1e..ca99f16 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -151,14 +151,13 @@ 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-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-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-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,7 +196,7 @@ DEFAULT_INCLUDES = 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-cnode.Plo \ ./$(DEPDIR)/libhcl_la-comp2.Plo \ ./$(DEPDIR)/libhcl_la-debug.Plo \ ./$(DEPDIR)/libhcl_la-decode.Plo ./$(DEPDIR)/libhcl_la-dic.Plo \ @@ -207,9 +206,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-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)/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 \ @@ -394,7 +393,6 @@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ -runstatedir = @runstatedir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ @@ -440,7 +438,6 @@ libhcl_la_SOURCES = \ hcl-prv.h \ bigint.c \ cnode.c \ - comp.c \ comp2.c \ debug.c \ decode.c \ @@ -459,7 +456,6 @@ libhcl_la_SOURCES = \ prim.c \ print.c \ rbt.c \ - read.c \ read2.c \ sym.c \ utf8.c \ @@ -579,7 +575,6 @@ 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 @@ -596,7 +591,6 @@ 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,13 +647,6 @@ libhcl_la-cnode.lo: cnode.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-cnode.lo `test -f 'cnode.c' || echo '$(srcdir)/'`cnode.c -libhcl_la-comp.lo: comp.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-comp.lo -MD -MP -MF $(DEPDIR)/libhcl_la-comp.Tpo -c -o libhcl_la-comp.lo `test -f 'comp.c' || echo '$(srcdir)/'`comp.c -@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libhcl_la-comp.Tpo $(DEPDIR)/libhcl_la-comp.Plo -@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='comp.c' object='libhcl_la-comp.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-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 @@ -772,13 +759,6 @@ 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 @@ -1013,7 +993,6 @@ clean-am: clean-generic clean-libtool clean-pkglibLTLIBRARIES \ 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 @@ -1030,7 +1009,6 @@ 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 @@ -1090,7 +1068,6 @@ installcheck-am: 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 @@ -1107,7 +1084,6 @@ 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/comp.c b/lib/comp.c deleted file mode 100644 index 5a73ae6..0000000 --- a/lib/comp.c +++ /dev/null @@ -1,3000 +0,0 @@ -/* - * $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_dbgl_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_dbgl_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].fname = srcloc->file; - hcl->code.locptr[hcl->code.bc.len].sline = 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_JUMP_BACKWARD_IF_TRUE: - case HCL_CODE_JUMP_BACKWARD_IF_FALSE: - case HCL_CODE_JUMP2_BACKWARD_IF_TRUE: - case HCL_CODE_JUMP2_BACKWARD_IF_FALSE: - 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_FORWARD_IF_TRUE || - hcl->code.bc.ptr[jip] == HCL_CODE_JUMP_FORWARD_IF_FALSE || - hcl->code.bc.ptr[jip] == HCL_CODE_JUMP_BACKWARD_X || - hcl->code.bc.ptr[jip] == HCL_CODE_JUMP_BACKWARD_IF_TRUE || - hcl->code.bc.ptr[jip] == HCL_CODE_JUMP_BACKWARD_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_CONS, - COP_EMIT_POP_INTO_ARRAY, - COP_EMIT_POP_INTO_BYTEARRAY, - COP_EMIT_POP_INTO_DIC, - COP_EMIT_POP_INTO_CONS, - - 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; - } - - 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_CONS, 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_CONS); - 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_CONS, 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_cons (hcl_t* hcl) -{ - hcl_cframe_t* cf; - int n; - - cf = GET_TOP_CFRAME(hcl); - HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_CONS); - HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); - - n = emit_single_param_instruction (hcl, HCL_CODE_MAKE_CONS, 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_cons (hcl_t* hcl) -{ - hcl_cframe_t* cf; - int n; - - cf = GET_TOP_CFRAME(hcl); - HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_CONS); - 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_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_CONS: - if (emit_make_cons(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_CONS: - if (emit_pop_into_cons(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/comp2.c b/lib/comp2.c index dfa4c41..535f5a5 100644 --- a/lib/comp2.c +++ b/lib/comp2.c @@ -994,7 +994,6 @@ static int compile_continue (hcl_t* hcl, hcl_cnode_t* src) 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, HCL_CNODE_GET_LOC(cmd)) <= -1) return -1; - POP_CFRAME (hcl); return 0; } diff --git a/lib/hcl-s.c b/lib/hcl-s.c index fbca76f..eae881e 100644 --- a/lib/hcl-s.c +++ b/lib/hcl-s.c @@ -1437,8 +1437,9 @@ int hcl_server_proto_handle_request (hcl_server_proto_t* proto) case HCL_SERVER_PROTO_TOKEN_SCRIPT: { - hcl_oop_t obj; + hcl_cnode_t* obj; hcl_ooci_t c; + int n; hcl_setinloc (proto->hcl, 1, 1); @@ -1456,22 +1457,29 @@ int hcl_server_proto_handle_request (hcl_server_proto_t* proto) if (proto->req.state == HCL_SERVER_PROTO_REQ_IN_TOP_LEVEL) hcl_reset(proto->hcl); proto->worker->opstate = HCL_SERVER_WORKER_OPSTATE_READ; - obj = hcl_read(proto->hcl); + obj = hcl_read2(proto->hcl); if (!obj) { if (hcl_geterrnum(proto->hcl) == HCL_ESYNERR) reformat_synerr (proto->hcl); goto fail_with_errmsg; } - if (get_token(proto) <= -1) goto fail_with_errmsg; + if (get_token(proto) <= -1) + { + hcl_freecnode (proto->hcl, obj); + goto fail_with_errmsg; + } if (proto->tok.type != HCL_SERVER_PROTO_TOKEN_NL) { hcl_seterrbfmt (proto->hcl, HCL_EINVAL, "No new line after .SCRIPT contents"); + hcl_freecnode (proto->hcl, obj); goto fail_with_errmsg; } proto->worker->opstate = HCL_SERVER_WORKER_OPSTATE_COMPILE; - if (hcl_compile(proto->hcl, obj) <= -1) + n = hcl_compile2(proto->hcl, obj); + hcl_freecnode (proto->hcl, obj); + if (n <= -1) { if (hcl_geterrnum(proto->hcl) == HCL_ESYNERR) reformat_synerr (proto->hcl); goto fail_with_errmsg; diff --git a/lib/hcl.h b/lib/hcl.h index f1abd04..024e6bc 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -1992,10 +1992,6 @@ HCL_EXPORT void hcl_flushio ( hcl_t* hcl ); -HCL_EXPORT hcl_oop_t hcl_read ( - hcl_t* hcl -); - HCL_EXPORT hcl_cnode_t* hcl_read2 ( hcl_t* hcl ); @@ -2020,9 +2016,9 @@ HCL_EXPORT hcl_ooi_t hcl_proutufmt ( ... ); -HCL_EXPORT int hcl_compile ( +HCL_EXPORT int hcl_compile2 ( hcl_t* hcl, - hcl_oop_t obj + hcl_cnode_t* obj ); /** diff --git a/lib/read.c b/lib/read.c deleted file mode 100644 index fb473d8..0000000 --- a/lib/read.c +++ /dev/null @@ -1,2456 +0,0 @@ -/* - * $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 WAfRRANTIES - 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" - -static int begin_include (hcl_t* hcl); -static int end_include (hcl_t* hcl); - -#define BUFFER_ALIGN 128 -#define BALIT_BUFFER_ALIGN 128 -#define SALIT_BUFFER_ALIGN 128 -#define ARLIT_BUFFER_ALIGN 128 - -#define CHAR_TO_NUM(c,base) \ - ((c >= '0' && c <= '9')? ((c - '0' < base)? (c - '0'): base): \ - (c >= 'A' && c <= 'Z')? ((c - 'A' + 10 < base)? (c - 'A' + 10): base): \ - (c >= 'a' && c <= 'z')? ((c - 'a' + 10 < base)? (c - 'a' + 10): base): base) - -static struct voca_t -{ - hcl_oow_t len; - hcl_ooch_t str[11]; -} vocas[] = -{ - { 8, { '#','i','n','c','l','u','d','e' } }, - { 11, { '#','\\','b','a','c','k','s','p','a','c','e' } }, - { 10, { '#','\\','l','i','n','e','f','e','e','d' } }, - { 9, { '#','\\','n','e','w','l','i','n','e' } }, - { 5, { '#','\\','n','u','l' } }, - { 6, { '#','\\','p','a','g','e' } }, - { 8, { '#','\\','r','e','t','u','r','n' } }, - { 8, { '#','\\','r','u','b','o','u','t' } }, - { 7, { '#','\\','s','p','a','c','e' } }, - { 5, { '#','\\','t','a','b' } }, - { 6, { '#','\\','v','t','a','b' } }, - { 5, { '<','E','O','L','>' } }, - { 5, { '<','E','O','F','>' } } -}; - -enum voca_id_t -{ - VOCA_INCLUDE, - VOCA_BACKSPACE, - VOCA_LINEFEED, - VOCA_NEWLINE, - VOCA_NUL, - VOCA_PAGE, - VOCA_RETURN, - VOCA_RUBOUT, - VOCA_SPACE, - VOCA_TAB, - VOCA_VTAB, - - VOCA_EOL, - VOCA_EOF -}; -typedef enum voca_id_t voca_id_t; - - -enum list_flag_t -{ - QUOTED = (1 << 0), - DOTTED = (1 << 1), - COMMAED = (1 << 2), - COLONED = (1 << 3), - CLOSED = (1 << 4), - JSON = (1 << 5) -}; - -#define LIST_FLAG_GET_CONCODE(x) (((x) >> 8) & 0xFF) -#define LIST_FLAG_SET_CONCODE(x,type) ((x) = ((x) & ~0xFF00) | ((type) << 8)) - - -static int string_to_ooi (hcl_t* hcl, hcl_oocs_t* str, int radixed, hcl_ooi_t* num) -{ - /* it is not a generic conversion function. - * it assumes a certain pre-sanity check on the string - * done by the lexical analyzer */ - - int v, negsign, base; - const hcl_ooch_t* ptr, * end; - hcl_oow_t value, old_value; - - negsign = 0; - ptr = str->ptr, - end = str->ptr + str->len; - - HCL_ASSERT (hcl, ptr < end); - - if (*ptr == '+' || *ptr == '-') - { - negsign = *ptr - '+'; - ptr++; - } - - if (radixed) - { - HCL_ASSERT (hcl, ptr < end); - - if (*ptr != '#') - { - hcl_seterrbfmt (hcl, HCL_EINVAL, "radixed number not starting with # - %*.js", str->len, str->ptr); - return -1; - } - ptr++; /* skip '#' */ - - if (*ptr == 'x') base = 16; - else if (*ptr == 'o') base = 8; - else if (*ptr == 'b') base = 2; - else - { - hcl_seterrbfmt (hcl, HCL_EINVAL, "invalid radix specifier - %c", *ptr); - return -1; - } - ptr++; - } - else base = 10; - - HCL_ASSERT (hcl, ptr < end); - - value = old_value = 0; - while (ptr < end && (v = CHAR_TO_NUM(*ptr, base)) < base) - { - value = value * base + v; - if (value < old_value) - { - /* overflow must have occurred */ - hcl_seterrbfmt (hcl, HCL_ERANGE, "number too big - %.*js", str->len, str->ptr); - return -1; - } - old_value = value; - ptr++; - } - - if (ptr < end) - { - /* trailing garbage? */ - hcl_seterrbfmt (hcl, HCL_EINVAL, "trailing garbage after numeric literal - %.*js", str->len, str->ptr); - return -1; - } - - if (value > HCL_TYPE_MAX(hcl_ooi_t) + (negsign? 1: 0)) /* assume 2's complement */ - { - hcl_seterrbfmt (hcl, HCL_ERANGE, "number too big - %.*js", str->len, str->ptr); - return -1; - } - - *num = value; - if (negsign) *num *= -1; - - return 0; -} - -static hcl_oop_t string_to_num (hcl_t* hcl, hcl_oocs_t* str, int radixed) -{ - int negsign, base; - const hcl_ooch_t* ptr, * end; - - negsign = 0; - ptr = str->ptr, - end = str->ptr + str->len; - - HCL_ASSERT (hcl, ptr < end); - - if (*ptr == '+' || *ptr == '-') - { - negsign = *ptr - '+'; - ptr++; - } - -#if 0 - if (radixed) - { - HCL_ASSERT (hcl, ptr < end); - - base = 0; - do - { - base = base * 10 + CHAR_TO_NUM(*ptr, 10); - ptr++; - } - while (*ptr != 'r'); - - ptr++; - } - else base = 10; -#else - if (radixed) - { - HCL_ASSERT (hcl, ptr < end); - - if (*ptr != '#') - { - hcl_seterrbfmt(hcl, HCL_EINVAL, "radixed number not starting with # - %.*js", str->len, str->ptr); - return HCL_NULL; - } - ptr++; /* skip '#' */ - - if (*ptr == 'x') base = 16; - else if (*ptr == 'o') base = 8; - else if (*ptr == 'b') base = 2; - else - { - hcl_seterrbfmt (hcl, HCL_EINVAL, "invalid radix specifier - %c", *ptr); - return HCL_NULL; - } - ptr++; - } - else base = 10; -#endif - -/* TODO: handle floating point numbers ... etc */ - if (negsign) base = -base; - return hcl_strtoint(hcl, ptr, end - ptr, base); -} - -static hcl_oop_t string_to_fpdec (hcl_t* hcl, hcl_oocs_t* str, const hcl_ioloc_t* loc) -{ - hcl_oow_t pos; - hcl_oow_t scale = 0; - hcl_oop_t v; - - pos = str->len; - while (pos > 0) - { - pos--; - if (str->ptr[pos] == '.') - { - scale = str->len - pos - 1; - if (scale > HCL_SMOOI_MAX) - { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_NUMRANGE, loc, str, "too many digits after decimal point"); - return HCL_NULL; - } - - HCL_ASSERT (hcl, scale > 0); - /*if (scale > 0)*/ HCL_MEMMOVE (&str->ptr[pos], &str->ptr[pos + 1], scale * HCL_SIZEOF(str->ptr[0])); /* remove the decimal point */ - break; - } - } - - /* if no decimal point is included or no digit after the point , you must not call this function */ - HCL_ASSERT (hcl, scale > 0); - - v = hcl_strtoint(hcl, str->ptr, str->len - 1, 10); - if (!v) return HCL_NULL; - - return hcl_makefpdec(hcl, v, scale); -} - -static HCL_INLINE int is_spacechar (hcl_ooci_t c) -{ - /* TODO: handle other space unicode characters */ - switch (c) - { - case ' ': - case '\f': /* formfeed */ - case '\n': /* linefeed */ - case '\r': /* carriage return */ - case '\t': /* horizon tab */ - case '\v': /* vertical tab */ - return 1; - - default: - return 0; - } -} - -static HCL_INLINE int is_alphachar (hcl_ooci_t c) -{ -/* TODO: support full unicode */ - return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'); -} - -static HCL_INLINE int is_digitchar (hcl_ooci_t c) -{ -/* TODO: support full unicode */ - return (c >= '0' && c <= '9'); -} - -static HCL_INLINE int is_xdigitchar (hcl_ooci_t c) -{ -/* TODO: support full unicode */ - return (c >= '0' && c <= '9') || (c >= 'A' && c <= 'F') || (c >= 'a' && c <= 'f'); -} - -static HCL_INLINE int is_alnumchar (hcl_ooci_t c) -{ -/* TODO: support full unicode */ - return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9'); -} - -static HCL_INLINE int is_delimiter (hcl_ooci_t c) -{ - return c == '(' || c == ')' || c == '[' || c == ']' || c == '{' || c == '}' || - c == '\"' || c == '\'' || c == '#' || c == ';' || c == '|' || c == '.' || - c == ',' || c == ':' || is_spacechar(c) || c == HCL_UCI_EOF; -} - -static int copy_string_to (hcl_t* hcl, const hcl_oocs_t* src, hcl_oocs_t* dst, hcl_oow_t* dst_capa, int append, hcl_ooch_t add_delim) -{ - hcl_oow_t len, pos; - - if (append) - { - pos = dst->len; - len = dst->len + src->len; - if (add_delim != '\0') len++; - } - else - { - pos = 0; - len = src->len; - } - - if (len > *dst_capa) - { - hcl_ooch_t* tmp; - hcl_oow_t capa; - - capa = HCL_ALIGN(len, BUFFER_ALIGN); - - tmp = (hcl_ooch_t*)hcl_reallocmem (hcl, dst->ptr, HCL_SIZEOF(*tmp) * capa); - if (!tmp) return -1; - - dst->ptr = tmp; - *dst_capa = capa; - } - - if (append && add_delim) dst->ptr[pos++] = add_delim; - hcl_copy_oochars (&dst->ptr[pos], src->ptr, src->len); - dst->len = len; - return 0; -} - - -#define GET_CHAR(hcl) \ - do { if (get_char(hcl) <= -1) return -1; } while (0) - -#define GET_CHAR_TO(hcl,c) \ - do { \ - if (get_char(hcl) <= -1) return -1; \ - c = (hcl)->c->lxc.c; \ - } while(0) - - -#define GET_TOKEN(hcl) \ - do { if (get_token(hcl) <= -1) return -1; } while (0) - -#define GET_TOKEN_WITH_ERRRET(hcl, v_ret) \ - do { if (get_token(hcl) <= -1) return v_ret; } while (0) - -#define GET_TOKEN_WITH_GOTO(hcl, goto_label) \ - do { if (get_token(hcl) <= -1) goto goto_label; } while (0) - -#define ADD_TOKEN_STR(hcl,s,l) \ - do { if (add_token_str(hcl, s, l) <= -1) return -1; } while (0) - -#define ADD_TOKEN_CHAR(hcl,c) \ - do { if (add_token_char(hcl, c) <= -1) return -1; } while (0) - -#define CLEAR_TOKEN_NAME(hcl) ((hcl)->c->tok.name.len = 0) -#define SET_TOKEN_TYPE(hcl,tv) ((hcl)->c->tok.type = (tv)) - -#define TOKEN_TYPE(hcl) ((hcl)->c->tok.type) -#define TOKEN_NAME(hcl) (&(hcl)->c->tok.name) -#define TOKEN_NAME_CAPA(hcl) ((hcl)->c->tok.name_capa) -#define TOKEN_NAME_LEN(hcl) ((hcl)->c->tok.name.len) -#define TOKEN_NAME_PTR(hcl) ((hcl)->c->tok.name.ptr) -#define TOKEN_NAME_CHAR(hcl,index) ((hcl)->c->tok.name.ptr[index]) -#define TOKEN_LOC(hcl) (&(hcl)->c->tok.loc) -#define LEXER_LOC(hcl) (&(hcl)->c->lxc.l) - -static HCL_INLINE int add_token_str (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len) -{ - hcl_oocs_t tmp; - - tmp.ptr = (hcl_ooch_t*)ptr; - tmp.len = len; - return copy_string_to (hcl, &tmp, TOKEN_NAME(hcl), &TOKEN_NAME_CAPA(hcl), 1, '\0'); -} - -static HCL_INLINE int does_token_name_match (hcl_t* hcl, voca_id_t id) -{ - return hcl->c->tok.name.len == vocas[id].len && - hcl_equal_oochars(hcl->c->tok.name.ptr, vocas[id].str, vocas[id].len); -} - -static HCL_INLINE int add_token_char (hcl_t* hcl, hcl_ooch_t c) -{ - hcl_oocs_t tmp; - - tmp.ptr = &c; - tmp.len = 1; - 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) -{ - /* Make sure that the unget buffer is large enough */ - HCL_ASSERT (hcl, hcl->c->nungots < HCL_COUNTOF(hcl->c->ungot)); - hcl->c->ungot[hcl->c->nungots++] = *c; -} - -static int get_char (hcl_t* hcl) -{ - hcl_ooci_t lc; - - if (hcl->c->nungots > 0) - { - /* something in the unget buffer */ - hcl->c->lxc = hcl->c->ungot[--hcl->c->nungots]; - return 0; - } - - if (hcl->c->curinp->b.state == -1) - { - hcl->c->curinp->b.state = 0; - return -1; - } - else if (hcl->c->curinp->b.state == 1) - { - hcl->c->curinp->b.state = 0; - goto return_eof; - } - - if (hcl->c->curinp->b.pos >= hcl->c->curinp->b.len) - { - if (hcl->c->reader(hcl, HCL_IO_READ, hcl->c->curinp) <= -1) return -1; - - if (hcl->c->curinp->xlen <= 0) - { - return_eof: - hcl->c->curinp->lxc.c = HCL_OOCI_EOF; - hcl->c->curinp->lxc.l.line = hcl->c->curinp->line; - hcl->c->curinp->lxc.l.colm = hcl->c->curinp->colm; - hcl->c->curinp->lxc.l.file = hcl->c->curinp->name; - hcl->c->lxc = hcl->c->curinp->lxc; - - /* indicate that EOF has been read. lxc.c is also set to EOF. */ - return 0; - } - - hcl->c->curinp->b.pos = 0; - hcl->c->curinp->b.len = hcl->c->curinp->xlen; - } - - if (hcl->c->curinp->lxc.c == '\n' || hcl->c->curinp->lxc.c == '\r') - { - /* hcl->c->curinp->lxc.c is a previous character. the new character - * to be read is still in the buffer (hcl->c->curinp->buf). - * hcl->cu->curinp->colm has been incremented when the previous - * character has been read. */ - if (hcl->c->curinp->line > 1 && hcl->c->curinp->colm == 2 && hcl->c->curinp->nl != hcl->c->curinp->lxc.c) - { - /* most likely, it's the second character in '\r\n' or '\n\r' - * sequence. let's not update the line and column number. */ - /*hcl->c->curinp->colm = 1;*/ - } - else - { - /* if the previous charater was a newline, - * increment the line counter and reset column to 1. - * incrementing the line number here instead of - * updating inp->lxc causes the line number for - * TOK_EOF to be the same line as the lxc newline. */ - hcl->c->curinp->line++; - hcl->c->curinp->colm = 1; - hcl->c->curinp->nl = hcl->c->curinp->lxc.c; - } - } - - lc = hcl->c->curinp->buf[hcl->c->curinp->b.pos++]; - - hcl->c->curinp->lxc.c = lc; - hcl->c->curinp->lxc.l.line = hcl->c->curinp->line; - hcl->c->curinp->lxc.l.colm = hcl->c->curinp->colm++; - hcl->c->curinp->lxc.l.file = hcl->c->curinp->name; - hcl->c->lxc = hcl->c->curinp->lxc; - - return 1; /* indicate that a normal character has been read */ -} - -static int skip_comment (hcl_t* hcl) -{ - hcl_ooci_t c = hcl->c->lxc.c; - hcl_iolxc_t lc; - - if (c == ';') goto single_line_comment; - if (c != '#') return 0; /* not a comment */ - - /* attempt to handle #! or ## */ - - lc = hcl->c->lxc; /* save the last character */ - GET_CHAR_TO (hcl, c); /* read a following character */ - - if (c == '!' || c == '#') - { - single_line_comment: - do - { - GET_CHAR_TO (hcl, c); - if (c == HCL_OOCI_EOF) - { - break; - } - else if (c == '\r' || c == '\n') - { - GET_CHAR (hcl); /* keep the first meaningful character in lxc */ - break; - } - } - while (1); - - return 1; /* single line comment led by ## or #! or ; */ - } - - /* unget the leading '#' */ - unget_char (hcl, &hcl->c->lxc); - /* restore the previous state */ - hcl->c->lxc = lc; - - return 0; -} - -static int get_string (hcl_t* hcl, hcl_ooch_t end_char, hcl_ooch_t esc_char, int regex, hcl_oow_t preescaped) -{ - hcl_ooci_t c; - hcl_oow_t escaped = preescaped; - hcl_oow_t digit_count = 0; - hcl_ooci_t c_acc = 0; - - SET_TOKEN_TYPE (hcl, HCL_IOTOK_STRLIT); - - while (1) - { - GET_CHAR_TO (hcl, c); - - if (c == HCL_OOCI_EOF) - { - hcl_setsynerr (hcl, HCL_SYNERR_STRCHRNC, TOKEN_LOC(hcl) /*LEXER_LOC(hcl)*/, HCL_NULL); - return -1; - } - - if (escaped == 3) - { - if (c >= '0' && c <= '7') - { - /* more octal digits */ - c_acc = c_acc * 8 + c - '0'; - digit_count++; - if (digit_count >= escaped) - { - /* should i limit the max to 0xFF/0377? - * if (c_acc > 0377) c_acc = 0377;*/ - ADD_TOKEN_CHAR (hcl, c_acc); - escaped = 0; - } - continue; - } - else - { - ADD_TOKEN_CHAR (hcl, c_acc); - escaped = 0; - } - } - else if (escaped == 2 || escaped == 4 || escaped == 8) - { - if (c >= '0' && c <= '9') - { - c_acc = c_acc * 16 + c - '0'; - digit_count++; - if (digit_count >= escaped) - { - ADD_TOKEN_CHAR (hcl, c_acc); - escaped = 0; - } - continue; - } - else if (c >= 'A' && c <= 'F') - { - c_acc = c_acc * 16 + c - 'A' + 10; - digit_count++; - if (digit_count >= escaped) - { - ADD_TOKEN_CHAR (hcl, c_acc); - escaped = 0; - } - continue; - } - else if (c >= 'a' && c <= 'f') - { - c_acc = c_acc * 16 + c - 'a' + 10; - digit_count++; - if (digit_count >= escaped) - { - ADD_TOKEN_CHAR (hcl, c_acc); - escaped = 0; - } - continue; - } - else - { - hcl_ooch_t rc; - - rc = (escaped == 2)? 'x': - (escaped == 4)? 'u': 'U'; - if (digit_count == 0) - ADD_TOKEN_CHAR (hcl, rc); - else ADD_TOKEN_CHAR (hcl, c_acc); - - escaped = 0; - } - } - - if (escaped == 0 && c == end_char) - { - /* terminating quote */ - /* GET_CHAR (hcl); */ - break; - } - - if (escaped == 0 && c == esc_char) - { - escaped = 1; - continue; - } - - if (escaped == 1) - { - if (c == 'a') c = '\a'; - else if (c == 'b') c = '\b'; - else if (c == 'f') c = '\f'; - else if (c == 'n') c = '\n'; - else if (c == 'r') c = '\r'; - else if (c == 't') c = '\t'; - else if (c == 'v') c = '\v'; - else if (c >= '0' && c <= '7' && !regex) - { - /* i don't support the octal notation for a regular expression. - * it conflicts with the backreference notation between \1 and \7 inclusive. */ - escaped = 3; - digit_count = 1; - c_acc = c - '0'; - continue; - } - else if (c == 'x') - { - escaped = 2; - digit_count = 0; - c_acc = 0; - continue; - } - #if (HCL_SIZEOF_OOCH_T >= 2) - else if (c == 'u') - { - escaped = 4; - digit_count = 0; - c_acc = 0; - continue; - } - #endif - #if (HCL_SIZEOF_OOCH_T >= 4) - else if (c == 'U') - { - escaped = 8; - digit_count = 0; - c_acc = 0; - continue; - } - #endif - else if (regex) - { - /* if the following character doesn't compose a proper - * escape sequence, keep the escape character. - * an unhandled escape sequence can be handled - * outside this function since the escape character - * is preserved.*/ - ADD_TOKEN_CHAR (hcl, esc_char); - } - - escaped = 0; - } - - ADD_TOKEN_CHAR (hcl, c); - } - - return 0; -} - -static int get_radix_number (hcl_t* hcl, hcl_ooci_t rc, int radix) -{ - hcl_ooci_t c; - - ADD_TOKEN_CHAR (hcl, '#'); - ADD_TOKEN_CHAR (hcl, rc); - - GET_CHAR_TO (hcl, c); - - if (CHAR_TO_NUM(c, radix) >= radix) - { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_NUMLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), - "no digit after radix specifier in %.*js", hcl->c->tok.name.len, hcl->c->tok.name.ptr); - return -1; - } - - do - { - ADD_TOKEN_CHAR(hcl, c); - GET_CHAR_TO (hcl, c); - } - while (CHAR_TO_NUM(c, radix) < radix); - - if (!is_delimiter(c)) - { - do - { - ADD_TOKEN_CHAR(hcl, c); - GET_CHAR_TO (hcl, c); - } - while (!is_delimiter(c)); - - hcl_setsynerrbfmt (hcl, HCL_SYNERR_NUMLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), - "invalid digit in radixed number in %.*js", hcl->c->tok.name.len, hcl->c->tok.name.ptr); - return -1; - } - - unget_char (hcl, &hcl->c->lxc); - SET_TOKEN_TYPE (hcl, HCL_IOTOK_RADNUMLIT); - - return 0; -} - -static int get_sharp_token (hcl_t* hcl) -{ - hcl_ooci_t c; - int radix; - - HCL_ASSERT (hcl, hcl->c->lxc.c == '#'); - - GET_CHAR_TO (hcl, c); - - /* - * #bBBBB binary - * #oOOOO octal - * #xXXXX hexadecimal - * #eDDD error - * #pHHH smptr - * #nil - * #true - * #false - * #include - * #\C character - * #\xHHHH unicode character - * #\UHHHH unicode character - * #\uHHHH unicode character - * #[ ] byte array - * #( ) qlist - */ - - switch (c) - { - case 'x': - radix = 16; - goto radixnum; - case 'o': - radix = 8; - goto radixnum; - case 'b': - radix = 2; - radixnum: - if (get_radix_number (hcl, c, radix) <= -1) return -1; - break; - - case 'e': - if (get_radix_number(hcl, c, 10) <= -1) return -1; - SET_TOKEN_TYPE (hcl, HCL_IOTOK_ERRLIT); - break; - - case 'p': - if (get_radix_number(hcl, c, 16) <= -1) return -1; - SET_TOKEN_TYPE (hcl, HCL_IOTOK_SMPTRLIT); - break; - - case '\\': /* character literal */ - ADD_TOKEN_CHAR (hcl, '#'); - ADD_TOKEN_CHAR (hcl, '\\'); - - GET_CHAR_TO (hcl, c); - if (is_delimiter(c)) - { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_CHARLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), - "no valid character after #\\ in %.*js", hcl->c->tok.name.len, hcl->c->tok.name.ptr); - return -1; - } - - SET_TOKEN_TYPE (hcl, HCL_IOTOK_CHARLIT); - do - { - ADD_TOKEN_CHAR (hcl, c); - GET_CHAR_TO (hcl, c); - } - while (!is_delimiter(c)); - - if (TOKEN_NAME_LEN(hcl) >= 4) - { - int max_digit_count = 0; - - if (TOKEN_NAME_CHAR(hcl, 2) == 'x') - { - hcl_oow_t i; - max_digit_count = 2; - - hexcharlit: - if (TOKEN_NAME_LEN(hcl) - 3 > max_digit_count) - { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_CHARLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), - "invalid hexadecimal character in %.*js", TOKEN_NAME_LEN(hcl), TOKEN_NAME_PTR(hcl)); - return -1; - } - c = 0; - for (i = 3; i < TOKEN_NAME_LEN(hcl); i++) - { - if (!is_xdigitchar(TOKEN_NAME_CHAR(hcl, i))) - { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_CHARLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), - "invalid hexadecimal character in %.*js", TOKEN_NAME_LEN(hcl), TOKEN_NAME_PTR(hcl)); - return -1; - } - - c = c * 16 + CHAR_TO_NUM(hcl->c->tok.name.ptr[i], 16); /* don't care if it is for 'p' */ - } - - } - #if (HCL_SIZEOF_OOCH_T >= 2) - else if (TOKEN_NAME_CHAR(hcl, 2) == 'u') - { - max_digit_count = 4; - goto hexcharlit; - } - #endif - #if (HCL_SIZEOF_OOCH_T >= 4) - else if (TOKEN_NAME_CHAR(hcl, 2) == 'U') - { - max_digit_count = 8; - goto hexcharlit; - } - #endif - else if (does_token_name_match(hcl, VOCA_SPACE)) - { - c = ' '; - } - else if (does_token_name_match(hcl, VOCA_NEWLINE)) - { - /* TODO: convert it to host newline convention. how to handle if it's composed of 2 letters like \r\n? */ - c = '\n'; - } - else if (does_token_name_match(hcl, VOCA_BACKSPACE)) - { - c = '\b'; - } - else if (does_token_name_match(hcl, VOCA_TAB)) - { - c = '\t'; - } - else if (does_token_name_match(hcl, VOCA_LINEFEED)) - { - c = '\n'; - } - else if (does_token_name_match(hcl, VOCA_PAGE)) - { - c = '\f'; - } - else if (does_token_name_match(hcl, VOCA_RETURN)) - { - c = '\r'; - } - else if (does_token_name_match(hcl, VOCA_NUL)) /* null character. not #nil */ - { - c = '\0'; - } - else if (does_token_name_match(hcl, VOCA_VTAB)) - { - c = '\v'; - } - else if (does_token_name_match(hcl, VOCA_RUBOUT)) - { - c = '\x7F'; /* DEL */ - } - else - { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_CHARLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), - "invalid character literal %.*js", hcl->c->tok.name.len, hcl->c->tok.name.ptr); - return -1; - } - } - else - { - HCL_ASSERT (hcl, TOKEN_NAME_LEN(hcl) == 3); - c = TOKEN_NAME_CHAR(hcl, 2); - } - - /* reset the token name to the converted character */ - if (hcl->c->tok.type == HCL_IOTOK_CHARLIT) - { - CLEAR_TOKEN_NAME (hcl); - ADD_TOKEN_CHAR (hcl, c); - } - - unget_char (hcl, &hcl->c->lxc); - break; - - case '[': /* #[ - byte array opener */ - ADD_TOKEN_CHAR (hcl, '#'); - ADD_TOKEN_CHAR(hcl, c); - SET_TOKEN_TYPE (hcl, HCL_IOTOK_BAPAREN); - break; - - case '(': /* #( - qlist opener */ - ADD_TOKEN_CHAR (hcl, '#'); - ADD_TOKEN_CHAR(hcl, c); - SET_TOKEN_TYPE (hcl, HCL_IOTOK_QLPAREN); - break; - - default: - if (is_delimiter(c)) - { - /* EOF, whitespace, etc */ - hcl_setsynerrbfmt (hcl, HCL_SYNERR_HASHLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), - "invalid hashed literal #%jc", c); - return -1; - } - - ADD_TOKEN_CHAR (hcl, '#'); - long_name: - do - { - ADD_TOKEN_CHAR (hcl, c); - GET_CHAR_TO (hcl, c); - } - while (!is_delimiter(c)); - - if (does_token_name_match (hcl, VOCA_INCLUDE)) - { - SET_TOKEN_TYPE (hcl, HCL_IOTOK_INCLUDE); - } - else - { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_HASHLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), - "invalid hashed literal %.*js", hcl->c->tok.name.len, hcl->c->tok.name.ptr); - return -1; - } - - unget_char (hcl, &hcl->c->lxc); - break; - } - - return 0; -} - -static hcl_iotok_type_t classify_ident_token (hcl_t* hcl, const hcl_oocs_t* v) -{ - hcl_oow_t i; - struct - { - hcl_oow_t len; - hcl_ooch_t name[10]; - hcl_iotok_type_t type; - } tab[] = - { - { 4, { 'n','u','l','l' }, HCL_IOTOK_NIL }, - { 4, { 't','r','u','e' }, HCL_IOTOK_TRUE }, - { 5, { 'f','a','l','s','e' }, HCL_IOTOK_FALSE } - }; - - for (i = 0; i < HCL_COUNTOF(tab); i++) - { - if (hcl_comp_oochars(v->ptr, v->len, tab[i].name, tab[i].len) == 0) return tab[i].type; - } - - return HCL_IOTOK_IDENT; -} - -static int get_token (hcl_t* hcl) -{ - hcl_ooci_t c, oldc; - int n; - -retry: - GET_CHAR (hcl); - - do - { - /* skip spaces */ - while (is_spacechar(hcl->c->lxc.c)) GET_CHAR (hcl); - /* the first character after the last space is in hcl->c->lxc */ - if ((n = skip_comment(hcl)) <= -1) return -1; - } - while (n >= 1); - - /* clear the token name, reset its location */ - SET_TOKEN_TYPE (hcl, HCL_IOTOK_EOF); /* is it correct? */ - CLEAR_TOKEN_NAME (hcl); - hcl->c->tok.loc = hcl->c->lxc.l; /* set token location */ - - c = hcl->c->lxc.c; - - switch (c) - { - case HCL_OOCI_EOF: - { - int n; - - n = end_include (hcl); - if (n <= -1) return -1; - if (n >= 1) goto retry; - - SET_TOKEN_TYPE (hcl, HCL_IOTOK_EOF); - ADD_TOKEN_STR(hcl, vocas[VOCA_EOF].str, vocas[VOCA_EOF].len); - break; - } - - case '(': - ADD_TOKEN_CHAR(hcl, c); - SET_TOKEN_TYPE (hcl, HCL_IOTOK_LPAREN); - break; - - case ')': - ADD_TOKEN_CHAR(hcl, c); - SET_TOKEN_TYPE (hcl, HCL_IOTOK_RPAREN); - break; - - case '[': - ADD_TOKEN_CHAR(hcl, c); - SET_TOKEN_TYPE (hcl, HCL_IOTOK_LBRACK); - break; - - case ']': - ADD_TOKEN_CHAR(hcl, c); - SET_TOKEN_TYPE (hcl, HCL_IOTOK_RBRACK); - break; - - case '{': - ADD_TOKEN_CHAR(hcl, c); - SET_TOKEN_TYPE (hcl, HCL_IOTOK_LBRACE); - break; - - case '}': - ADD_TOKEN_CHAR (hcl, c); - SET_TOKEN_TYPE (hcl, HCL_IOTOK_RBRACE); - break; - - case '|': - ADD_TOKEN_CHAR (hcl, c); - SET_TOKEN_TYPE (hcl, HCL_IOTOK_VBAR); - break; - - case '.': - SET_TOKEN_TYPE (hcl, HCL_IOTOK_DOT); - ADD_TOKEN_CHAR (hcl, c); - break; - - case ',': - SET_TOKEN_TYPE (hcl, HCL_IOTOK_COMMA); - ADD_TOKEN_CHAR (hcl, c); - break; - - case ':': - SET_TOKEN_TYPE (hcl, HCL_IOTOK_COLON); - ADD_TOKEN_CHAR (hcl, c); - break; - - case '\"': - if (get_string(hcl, '\"', '\\', 0, 0) <= -1) return -1; - break; - - case '\'': - if (get_string(hcl, '\'', '\\', 0, 0) <= -1) return -1; - if (hcl->c->tok.name.len != 1) - { - hcl_setsynerr (hcl, HCL_SYNERR_CHARLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; - } - SET_TOKEN_TYPE (hcl, HCL_IOTOK_CHARLIT); - break; - - case '#': - if (get_sharp_token(hcl) <= -1) return -1; - break; - - case '+': - case '-': - oldc = c; - GET_CHAR_TO (hcl, c); - if(is_digitchar(c)) - { - unget_char (hcl, &hcl->c->lxc); - c = oldc; - goto numlit; - } - else if (c == '#') - { - int radix; - hcl_iolxc_t sharp; - - sharp = hcl->c->lxc; /* back up '#' */ - - GET_CHAR_TO (hcl, c); - switch (c) - { - case 'b': - radix = 2; - goto radnumlit; - case 'o': - radix = 8; - goto radnumlit; - case 'x': - radix = 16; - radnumlit: - ADD_TOKEN_CHAR (hcl, oldc); - if (get_radix_number (hcl, c, radix) <= -1) return -1; - break; - - default: - unget_char (hcl, &hcl->c->lxc); - unget_char (hcl, &sharp); - c = oldc; - goto ident; - } - } - else - { - unget_char (hcl, &hcl->c->lxc); - c = oldc; - goto ident; - } - break; - - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - numlit: - SET_TOKEN_TYPE (hcl, HCL_IOTOK_NUMLIT); - while (1) - { - ADD_TOKEN_CHAR (hcl, c); - GET_CHAR_TO (hcl, c); - if (TOKEN_TYPE(hcl) == HCL_IOTOK_NUMLIT && c == '.') - { - SET_TOKEN_TYPE (hcl, HCL_IOTOK_FPDECLIT); - ADD_TOKEN_CHAR (hcl, c); - GET_CHAR_TO (hcl, c); - if (!is_digitchar(c)) - { - /* the first character after the decimal point is not a decimal digit */ - hcl_setsynerrbfmt (hcl, HCL_SYNERR_NUMLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), "invalid numeric literal with no digit after decimal point"); - return -1; - } - } - - if (!is_digitchar(c)) - { - unget_char (hcl, &hcl->c->lxc); - break; - } - } - - break; - - default: - ident: - if (is_delimiter(c)) - { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ILCHR, TOKEN_LOC(hcl), HCL_NULL, "illegal character %jc encountered", c); - return -1; - } - - SET_TOKEN_TYPE (hcl, HCL_IOTOK_IDENT); - while (1) - { - ADD_TOKEN_CHAR (hcl, c); - GET_CHAR_TO (hcl, c); - - if (c == '.') - { - hcl_iolxc_t period; - hcl_iotok_type_t type; - - type = classify_ident_token(hcl, TOKEN_NAME(hcl)); - if (type != HCL_IOTOK_IDENT) - { - SET_TOKEN_TYPE (hcl, type); - unget_char (hcl, &hcl->c->lxc); - break; - } - - period = hcl->c->lxc; - - read_more_seg: - GET_CHAR_TO (hcl, c); - if (!is_delimiter(c)) - { - hcl_oow_t start; - hcl_oocs_t seg; - - SET_TOKEN_TYPE (hcl, HCL_IOTOK_IDENT_DOTTED); - ADD_TOKEN_CHAR (hcl, '.'); - - start = TOKEN_NAME_LEN(hcl); - do - { - ADD_TOKEN_CHAR (hcl, c); - GET_CHAR_TO (hcl, c); - } - while (!is_delimiter(c)); - - seg.ptr = &TOKEN_NAME_CHAR(hcl,start); - seg.len = TOKEN_NAME_LEN(hcl) - start; - if (classify_ident_token(hcl, &seg) != HCL_IOTOK_IDENT) - { - hcl_setsynerr (hcl, HCL_SYNERR_MSEGIDENT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; - } - - if (c == '.') goto read_more_seg; - - unget_char (hcl, &hcl->c->lxc); - break; - } - else - { - unget_char (hcl, &hcl->c->lxc); - unget_char (hcl, &period); - } - break; - } - else if (is_delimiter(c)) - { - unget_char (hcl, &hcl->c->lxc); - break; - } - } - - if (TOKEN_TYPE(hcl) == HCL_IOTOK_IDENT) - { - hcl_iotok_type_t type; - type = classify_ident_token(hcl, TOKEN_NAME(hcl)); - SET_TOKEN_TYPE (hcl, type); - } - break; - } - -done: -#if defined(HCL_DEBUG_LEXER) - HCL_DEBUG2 (hcl, "TOKEN: [%.*js]\n", (hcl_ooi_t)TOKEN_NAME_LEN(hcl), TOKEN_NAME_PTR(hcl)); -#endif - - return 0; -} - -static void clear_io_names (hcl_t* hcl) -{ - hcl_iolink_t* cur; - - HCL_ASSERT (hcl, hcl->c != HCL_NULL); - - while (hcl->c->io_names) - { - cur = hcl->c->io_names; - hcl->c->io_names = cur->link; - hcl_freemem (hcl, cur); - } -} - -static const hcl_ooch_t* add_io_name (hcl_t* hcl, const hcl_oocs_t* name) -{ - hcl_iolink_t* link; - hcl_ooch_t* ptr; - - link = (hcl_iolink_t*)hcl_callocmem(hcl, HCL_SIZEOF(*link) + HCL_SIZEOF(hcl_ooch_t) * (name->len + 1)); - if (HCL_UNLIKELY(!link)) return HCL_NULL; - - ptr = (hcl_ooch_t*)(link + 1); - - hcl_copy_oochars (ptr, name->ptr, name->len); - ptr[name->len] = '\0'; - - link->link = hcl->c->io_names; - hcl->c->io_names = link; - - return ptr; -} - -/* -------------------------------------------------------------------------- */ - -static int begin_include (hcl_t* hcl) -{ - hcl_ioinarg_t* arg; - const hcl_ooch_t* io_name; - - io_name = add_io_name (hcl, TOKEN_NAME(hcl)); - if (!io_name) return -1; - - arg = (hcl_ioinarg_t*)hcl_callocmem (hcl, HCL_SIZEOF(*arg)); - if (HCL_UNLIKELY(!arg)) goto oops; - - arg->name = io_name; - arg->line = 1; - arg->colm = 1; - /*arg->nl = '\0';*/ - arg->includer = hcl->c->curinp; - - if (hcl->c->reader(hcl, HCL_IO_OPEN, arg) <= -1) - { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_INCLUDE, TOKEN_LOC(hcl), TOKEN_NAME(hcl), "unable to include %js", io_name); - goto oops; - } - -#if 0 - GET_TOKEN_WITH_GOTO (hcl, oops); - if (TOKEN_TYPE(hcl) != HCL_IOTOK_DOT) - { - /* check if a period is following the includee name */ - hcl_setsynerr (hcl, HCL_SYNERR_PERIOD, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - goto oops; - } -#endif - - /* switch to the includee's stream */ - hcl->c->curinp = arg; - /* hcl->c->depth.incl++; */ - - /* read in the first character in the included file. - * so the next call to get_token() sees the character read - * from this file. */ - if (get_token(hcl) <= -1) - { - end_include (hcl); - /* i don't jump to oops since i've called - * end_include() which frees hcl->c->curinp/arg */ - return -1; - } - - return 0; - -oops: - if (arg) hcl_freemem (hcl, arg); - return -1; -} - -static int end_include (hcl_t* hcl) -{ - int x; - hcl_ioinarg_t* cur; - - if (hcl->c->curinp == &hcl->c->inarg) return 0; /* no include */ - - /* if it is an included file, close it and - * retry to read a character from an outer file */ - - x = hcl->c->reader(hcl, HCL_IO_CLOSE, hcl->c->curinp); - - /* if closing has failed, still destroy the - * sio structure first as normal and return - * the failure below. this way, the caller - * does not call HCL_IO_CLOSE on - * hcl->c->curinp again. */ - - cur = hcl->c->curinp; - hcl->c->curinp = hcl->c->curinp->includer; - - HCL_ASSERT (hcl, cur->name != HCL_NULL); - hcl_freemem (hcl, cur); - /* hcl->parse.depth.incl--; */ - - if (x != 0) - { - /* the failure mentioned above is returned here */ - return -1; - } - - hcl->c->lxc = hcl->c->curinp->lxc; - return 1; /* ended the included file successfully */ -} - - -static HCL_INLINE hcl_oop_t enter_list (hcl_t* hcl, int flagv) -{ - hcl_oop_oop_t rsa; - - /* upon entering a list, it pushes a frame of 4 slots. - * rsa[0] stores the first element in the list. - * rsa[1] stores the last element in the list. - * both are updated in chain_to_list() as items are added. - * rsa[2] stores the flag value. - * rsa[3] stores the pointer to the previous top frame. - * rsa[4] stores the number of elements in the list */ - rsa = (hcl_oop_oop_t)hcl_makearray(hcl, 5, 0); - if (!rsa) return HCL_NULL; - - rsa->slot[2] = HCL_SMOOI_TO_OOP(flagv); - rsa->slot[3] = hcl->c->r.s; /* push */ - hcl->c->r.s = (hcl_oop_t)rsa; - - rsa->slot[4] = HCL_SMOOI_TO_OOP(0); - - return hcl->c->r.s; -} - -static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv) -{ - hcl_oop_oop_t rsa; - hcl_oop_t head; - int fv, concode; - - /* the stack must not be empty - cannot leave a list without entering it */ - HCL_ASSERT (hcl, !HCL_IS_NIL(hcl,hcl->c->r.s)); - - rsa = (hcl_oop_oop_t)hcl->c->r.s; - - head = rsa->slot[0]; - HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(rsa->slot[2])); - fv = HCL_OOP_TO_SMOOI(rsa->slot[2]); - concode = LIST_FLAG_GET_CONCODE(fv); - - hcl->c->r.s = rsa->slot[3]; /* pop off */ - rsa->slot[3] = hcl->_nil; - - if (fv & (COMMAED | COLONED)) - { - hcl_setsynerr (hcl, ((fv & COMMAED)? HCL_SYNERR_COMMANOVALUE: HCL_SYNERR_COLONNOVALUE), TOKEN_LOC(hcl), HCL_NULL); - return HCL_NULL; - } - -#if 0 - /* TODO: literalize the list if all the elements are all literals */ - if (concode == HCL_CONCODE_ARRAY || concode == HCL_CONCODE_BYTEARRAY /*|| concode == HCL_CONCODE_DIC*/) - { - /* convert a list to an array */ - hcl_oop_oop_t arr; - hcl_oop_t ptr; - hcl_oow_t count; - - ptr = head; - count = 0; - while (ptr != hcl->_nil) - { - hcl_oop_t car; - HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_BRAND(ptr) == HCL_BRAND_CONS); - car = HCL_CONS_CAR(ptr); - - if (!HCL_OOP_IS_NUMERIC(car)) goto done; /* TODO: check if the element is a literal properly here */ - - ptr = HCL_CONS_CDR(ptr); - count++; - } - - hcl_pushvolat (hcl, &head); - arr = (hcl_oop_oop_t)hcl_makearray(hcl, count, 0); - hcl_popvolat (hcl); - if (!arr) return HCL_NULL; - - ptr = head; - count = 0; - while (ptr != hcl->_nil) - { - arr->slot[count++] = HCL_CONS_CAR(ptr); - ptr = HCL_CONS_CDR(ptr); - } - - head = (hcl_oop_t)arr; - } -done: -#endif - - *oldflagv = fv; - if (HCL_IS_NIL(hcl,hcl->c->r.s)) - { - /* the stack is empty after popping. - * it is back to the top level. - * the top level can never be quoted. */ - *flagv = 0; - } - else - { - /* restore the flag for the outer returning level */ - rsa = (hcl_oop_oop_t)hcl->c->r.s; - HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(rsa->slot[2])); - *flagv = HCL_OOP_TO_SMOOI(rsa->slot[2]); - } - - /* return the head of the list being left */ - if (HCL_IS_NIL(hcl,head)) - { - /* the list is empty. literalize the empty list according to - * the list opener. for a list, it is same as #nil. */ - switch (concode) - { - case HCL_CONCODE_ARRAY: - return (hcl_oop_t)hcl_makearray(hcl, 0, 0); - case HCL_CONCODE_BYTEARRAY: - return (hcl_oop_t)hcl_makebytearray(hcl, HCL_NULL, 0); - case HCL_CONCODE_DIC: - return (hcl_oop_t)hcl_makedic(hcl, 100); /* TODO: default dictionary size for empty definition? */ - - /* 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() ...) */ - } - } - - if (HCL_IS_CONS(hcl,head)) HCL_OBJ_SET_FLAGS_SYNCODE(head, concode); - return head; -} - -static HCL_INLINE int can_dot_list (hcl_t* hcl) -{ - hcl_oop_oop_t rsa; - int flagv; - hcl_ooi_t count; - - HCL_ASSERT (hcl, !HCL_IS_NIL(hcl,hcl->c->r.s)); - - /* mark the state that a dot has appeared in the list */ - rsa = (hcl_oop_oop_t)hcl->c->r.s; - HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(rsa->slot[2])); - flagv = HCL_OOP_TO_SMOOI(rsa->slot[2]); - count = HCL_OOP_TO_SMOOI(rsa->slot[4]); - - if (count <= 0) return 0; - if (LIST_FLAG_GET_CONCODE(flagv) != HCL_CONCODE_QLIST) return 0; - - flagv |= DOTTED; - rsa->slot[2] = HCL_SMOOI_TO_OOP(flagv); - return 1; -} - -static HCL_INLINE int can_comma_list (hcl_t* hcl) -{ - hcl_oop_oop_t rsa; - int flagv; - hcl_ooi_t count; - - HCL_ASSERT (hcl, !HCL_IS_NIL(hcl,hcl->c->r.s)); - - rsa = (hcl_oop_oop_t)hcl->c->r.s; - HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(rsa->slot[2])); - flagv = HCL_OOP_TO_SMOOI(rsa->slot[2]); - count = HCL_OOP_TO_SMOOI(rsa->slot[4]); - - if (count <= 0) return 0; - if (count == 1) flagv |= JSON; - else if (!(flagv & JSON)) return 0; - if (flagv & (COMMAED | COLONED)) return 0; - - if (LIST_FLAG_GET_CONCODE(flagv) == HCL_CONCODE_DIC) - { - if (count & 1) return 0; - } - else if (LIST_FLAG_GET_CONCODE(flagv) != HCL_CONCODE_ARRAY && - LIST_FLAG_GET_CONCODE(flagv) != HCL_CONCODE_BYTEARRAY) - { - return 0; - } - - flagv |= COMMAED; - rsa->slot[2] = HCL_SMOOI_TO_OOP(flagv); - return 1; -} - -static HCL_INLINE int can_colon_list (hcl_t* hcl) -{ - hcl_oop_oop_t rsa; - int flagv; - hcl_ooi_t count; - - HCL_ASSERT (hcl, !HCL_IS_NIL(hcl,hcl->c->r.s)); - - /* mark the state that a colon has appeared in the list */ - rsa = (hcl_oop_oop_t)hcl->c->r.s; - HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(rsa->slot[2])); - flagv = HCL_OOP_TO_SMOOI(rsa->slot[2]); - count = HCL_OOP_TO_SMOOI(rsa->slot[4]); - - if (count <= 0) return 0; - if (count == 1) flagv |= JSON; - else if (!(flagv & JSON)) return 0; - - if (flagv & (COMMAED | COLONED)) return 0; - - if (LIST_FLAG_GET_CONCODE(flagv) != HCL_CONCODE_DIC) return 0; - - count = HCL_OOP_TO_SMOOI(rsa->slot[4]); - if (!(count & 1)) return 0; - - flagv |= COLONED; - rsa->slot[2] = HCL_SMOOI_TO_OOP(flagv); - return 1; -} - -static HCL_INLINE void clear_comma_colon_flag (hcl_t* hcl) -{ - hcl_oop_oop_t rsa; - int flagv; - - HCL_ASSERT (hcl, !HCL_IS_NIL(hcl,hcl->c->r.s)); - - rsa = (hcl_oop_oop_t)hcl->c->r.s; - HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(rsa->slot[2])); - flagv = HCL_OOP_TO_SMOOI(rsa->slot[2]); - - flagv &= ~(COMMAED | COLONED); - rsa->slot[2] = HCL_SMOOI_TO_OOP(flagv); -} - -static hcl_oop_t chain_to_list (hcl_t* hcl, hcl_oop_t obj) -{ - hcl_oop_oop_t rsa; - int flagv; - - HCL_ASSERT (hcl, !HCL_IS_NIL(hcl,hcl->c->r.s)); - rsa = (hcl_oop_oop_t)hcl->c->r.s; - HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(rsa->slot[2])); - flagv = (int)HCL_OOP_TO_SMOOI(rsa->slot[2]); - - if (flagv & CLOSED) - { - /* the list has already been closed and cannot add more items - * for instance, see this faulty expression [1 2 . 3 4 ]. - * you can have only 1 item after the period. this condition - * can only be triggered by a wrong qlist where a period is - * 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; - } - else if (flagv & DOTTED) - { - hcl_ooi_t count; - - /* the list must not be empty to have reached the dotted state */ - HCL_ASSERT (hcl, !HCL_IS_NIL(hcl,rsa->slot[1])); - - /* chain the object via 'cdr' of the tail cell */ - HCL_CONS_CDR(rsa->slot[1]) = obj; - - /* update the flag to CLOSED so that you can have more than - * one item after the dot. */ - flagv |= CLOSED; - rsa->slot[2] = HCL_SMOOI_TO_OOP(flagv); - - count = HCL_OOP_TO_SMOOI(rsa->slot[4]) + 1; - rsa->slot[4] = HCL_SMOOI_TO_OOP(count); - } - else - { - hcl_oop_t cons; - hcl_ooi_t count; - - count = HCL_OOP_TO_SMOOI(rsa->slot[4]); - - if ((flagv & JSON) && count > 0 && !(flagv & (COMMAED | COLONED))) - { - /* 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; - } - - hcl_pushvolat (hcl, (hcl_oop_t*)&rsa); - cons = hcl_makecons(hcl, obj, hcl->_nil); - hcl_popvolat (hcl); - if (HCL_UNLIKELY(!cons)) return HCL_NULL; - - if (HCL_IS_NIL(hcl, rsa->slot[0])) - { - /* the list head is not set yet. it is the first - * element added to the list. let both head and tail - * point to the new cons cell */ - HCL_ASSERT (hcl, HCL_IS_NIL(hcl, rsa->slot[1])); - rsa->slot[0] = cons; - rsa->slot[1] = cons; - } - else - { - /* the new cons cell is not the first element. - * append it to the list */ - HCL_CONS_CDR(rsa->slot[1]) = cons; - rsa->slot[1] = cons; - } - - count++; - rsa->slot[4] = HCL_SMOOI_TO_OOP(count); - } - - return obj; -} - -#if 0 -static HCL_INLINE int is_list_empty (hcl_t* hcl) -{ - hcl_oop_oop_t rsa; - /* the stack must not be empty */ - HCL_ASSERT (hcl, !HCL_IS_NIL(hcl,hcl->c->r.s)); - rsa = (hcl_oop_oop_t)hcl->c->r.s; - /* if the tail pointer is pointing to nil, the list is empty */ - return HCL_IS_NIL(hcl, rsa->slot[1]); -} -#endif - - -static int add_to_symbol_array_literal_buffer (hcl_t* hcl, hcl_oop_t b) -{ - if (hcl->c->r.salit.size >= hcl->c->r.salit.capa) - { - hcl_oop_t* tmp; - hcl_oow_t new_capa; - - new_capa = HCL_ALIGN (hcl->c->r.salit.size + 1, SALIT_BUFFER_ALIGN); - tmp = (hcl_oop_t*)hcl_reallocmem (hcl, hcl->c->r.salit.ptr, new_capa * HCL_SIZEOF(*tmp)); - if (!tmp) return -1; - - hcl->c->r.salit.capa = new_capa; - hcl->c->r.salit.ptr = tmp; - } - -/* TODO: overflow check of hcl->c->r.tvlit_count itself */ - hcl->c->r.salit.ptr[hcl->c->r.salit.size++] = b; - return 0; -} - -static int get_symbol_array_literal (hcl_t* hcl, hcl_oop_t* xlit) -{ - hcl_oop_t sa, sym; - hcl_oow_t i; - - /* if the program is not buggy, salit.size must be 0 here. */ - HCL_ASSERT (hcl, hcl->c->r.salit.size == 0); - hcl->c->r.salit.size = 0; /* i want to set it to 0 in case it's buggy */ - - HCL_ASSERT (hcl, TOKEN_TYPE(hcl) == HCL_IOTOK_VBAR); - GET_TOKEN_WITH_GOTO(hcl, oops); - - while (TOKEN_TYPE(hcl) == HCL_IOTOK_IDENT /* || TOKEN_TYPE(hcl) == HCL_IOTOK_IDENT_DOTTED */) - { - sym = hcl_makesymbol(hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl)); - if (!sym) goto oops; - - if (HCL_OBJ_GET_FLAGS_SYNCODE(sym) || HCL_OBJ_GET_FLAGS_KERNEL(sym)) - { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL, - "special symbol not to be declared as a variable - %O", sym); /* TOOD: error location */ - goto oops; - } - - if (add_to_symbol_array_literal_buffer(hcl, sym) <= -1) goto oops; - GET_TOKEN_WITH_GOTO (hcl, oops); - } - - if (TOKEN_TYPE(hcl) != HCL_IOTOK_VBAR) - { - hcl_setsynerr (hcl, HCL_SYNERR_VBAR, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - goto oops; - } - - sa = hcl_makearray(hcl, hcl->c->r.salit.size, 0); - if (!sa) goto oops; - - for (i = 0; i < hcl->c->r.salit.size; i++) - ((hcl_oop_oop_t)sa)->slot[i] = hcl->c->r.salit.ptr[i]; - - /* switch array to symbol array. this is special-purpose. */ - HCL_OBJ_SET_FLAGS_BRAND (sa, HCL_BRAND_SYMBOL_ARRAY); - - *xlit = sa; - - hcl->c->r.salit.size = 0; /* reset literal count... */ - return 0; - -oops: - hcl->c->r.salit.size = 0; /* reset literal count... */ - return -1; -} - -static int 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_oop_t obj; - - while (1) - { - redo: - switch (TOKEN_TYPE(hcl)) - { - default: - hcl_setsynerr (hcl, HCL_SYNERR_ILTOK, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; - - case HCL_IOTOK_EOF: - hcl_setsynerr (hcl, HCL_SYNERR_EOF, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; - - case HCL_IOTOK_INCLUDE: - /* TODO: should i limit where #include can be specified? - * disallow it inside a list literal or an array literal? */ - GET_TOKEN (hcl); - if (TOKEN_TYPE(hcl) != HCL_IOTOK_STRLIT) - { - hcl_setsynerr (hcl, HCL_SYNERR_STRING, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; - } - if (begin_include(hcl) <= -1) return -1; - goto redo; - - case HCL_IOTOK_LBRACK: /* [] */ - flagv = 0; - LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_ARRAY); - goto start_list; - - case HCL_IOTOK_BAPAREN: /* #[] */ - flagv = 0; - LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_BYTEARRAY); - goto start_list; - - case HCL_IOTOK_LBRACE: /* {} */ - flagv = 0; - LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_DIC); - goto start_list; - - case HCL_IOTOK_QLPAREN: /* #() */ -#if 1 - hcl_setsynerr (hcl, HCL_SYNERR_ILTOK, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; -#else - flagv = 0; - LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_QLIST); - goto start_list; -#endif - - case HCL_IOTOK_LPAREN: /* () */ - flagv = 0; - LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_XLIST); - start_list: - if (level >= HCL_TYPE_MAX(int)) - { - /* the nesting level has become too deep */ - hcl_setsynerr (hcl, HCL_SYNERR_NESTING, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; - } - - /* push some data to simulate recursion into - * a list literal or an array literal */ - if (enter_list(hcl, flagv) == HCL_NULL) return -1; - level++; - if (LIST_FLAG_GET_CONCODE(flagv) == HCL_CONCODE_ARRAY) array_level++; - - /* read the next token */ - GET_TOKEN (hcl); - goto redo; - - case HCL_IOTOK_DOT: - if (level <= 0 || !can_dot_list(hcl)) - { - /* cannot have a period: - * 1. at the top level - not inside () - * 2. at the beginning of a list - * 3. inside an #(), #[], #{}, () */ - hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, TOKEN_LOC(hcl), HCL_NULL); - return -1; - } - - GET_TOKEN (hcl); - 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; - } - - GET_TOKEN (hcl); - 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; - } - - GET_TOKEN (hcl); - goto redo; - - case HCL_IOTOK_RPAREN: /* xlist (), qlist #() */ - case HCL_IOTOK_RBRACK: /* bytearray #[], array[] */ - case HCL_IOTOK_RBRACE: /* dictionary {} */ - { - static struct - { - int closer; - hcl_synerrnum_t synerr; - } req[] = - { - { HCL_IOTOK_RPAREN, HCL_SYNERR_RPAREN }, /* XLIST () */ - { HCL_IOTOK_RBRACK, HCL_SYNERR_RBRACK }, /* ARRAY [] */ - { HCL_IOTOK_RBRACK, HCL_SYNERR_RBRACK }, /* BYTEARRAY #[] */ - { HCL_IOTOK_RBRACE, HCL_SYNERR_RBRACE }, /* DIC {} */ - { HCL_IOTOK_RPAREN, HCL_SYNERR_RPAREN } /* QLIST #() */ - }; - - int oldflagv; - int concode; - - if (level <= 0) - { - hcl_setsynerr (hcl, HCL_SYNERR_UNBALPBB, TOKEN_LOC(hcl), HCL_NULL); - return -1; - } - - concode = LIST_FLAG_GET_CONCODE(flagv); - - if (req[concode].closer != TOKEN_TYPE(hcl)) - { - hcl_setsynerr (hcl, req[concode].synerr, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; - } - -#if 0 - if ((flagv & QUOTED) || level <= 0) - { - /* the right parenthesis can never appear while - * 'quoted' is true. 'quoted' is set to false when - * entering a normal list. 'quoted' is set to true - * when entering a quoted list. a quoted list does - * not have an explicit right parenthesis. - * so the right parenthesis can only pair up with - * the left parenthesis for the normal list. - * - * For example, '(1 2 3 ') 5 6) - * - * this condition is triggerred when the first ) is - * met after the second quote. - * - * also it is illegal to have the right parenthesis - * with no opening(left) parenthesis, which is - * indicated by level<=0. - */ - hcl_setsynerr (hcl, HCL_SYNERR_LPAREN, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; - } -#endif - obj = leave_list(hcl, &flagv, &oldflagv); - - level--; - if (LIST_FLAG_GET_CONCODE(oldflagv) == HCL_CONCODE_ARRAY) array_level--; - break; - } - - case HCL_IOTOK_VBAR: -/* TODO: think wheter to allow | | inside a quoted list... */ -/* TODO: revise this part ... */ - if (array_level > 0) - { - hcl_setsynerr (hcl, HCL_SYNERR_VBARBANNED, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; - } - if (get_symbol_array_literal(hcl, &obj) <= -1) return -1; - break; - - case HCL_IOTOK_NIL: - obj = hcl->_nil; - break; - - case HCL_IOTOK_TRUE: - obj = hcl->_true; - break; - - case HCL_IOTOK_FALSE: - obj = hcl->_false; - break; - - case HCL_IOTOK_SMPTRLIT: - { - hcl_oow_t i; - hcl_oow_t v = 0; - - HCL_ASSERT (hcl, TOKEN_NAME_LEN(hcl) >= 3); - for (i = 2; i < TOKEN_NAME_LEN(hcl); i++) - { - HCL_ASSERT (hcl, is_xdigitchar(TOKEN_NAME_CHAR(hcl, i))); - v = v * 16 + CHAR_TO_NUM(TOKEN_NAME_CHAR(hcl, i), 16); - } - - if (!HCL_IN_SMPTR_RANGE(v)) - { - hcl_setsynerr (hcl, HCL_SYNERR_SMPTRLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; - } - - obj = HCL_SMPTR_TO_OOP(v); - break; - } - - case HCL_IOTOK_ERRLIT: - { - hcl_oow_t i; - hcl_ooi_t v = 0; - - HCL_ASSERT (hcl, TOKEN_NAME_LEN(hcl) >= 3); - for (i = 2; i < TOKEN_NAME_LEN(hcl); i++) - { - HCL_ASSERT (hcl, is_digitchar(TOKEN_NAME_CHAR(hcl, i))); - v = v * 10 + CHAR_TO_NUM(TOKEN_NAME_CHAR(hcl, i), 10); - - if (v > HCL_ERROR_MAX) - { - hcl_setsynerr (hcl, HCL_SYNERR_ERRLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; - } - } - - obj = HCL_ERROR_TO_OOP(v); - break; - } - - case HCL_IOTOK_CHARLIT: - obj = HCL_CHAR_TO_OOP(TOKEN_NAME_CHAR(hcl, 0)); - break; - - case HCL_IOTOK_NUMLIT: - case HCL_IOTOK_RADNUMLIT: - obj = string_to_num(hcl, TOKEN_NAME(hcl), TOKEN_TYPE(hcl) == HCL_IOTOK_RADNUMLIT); - break; - - case HCL_IOTOK_FPDECLIT: - obj = string_to_fpdec(hcl, TOKEN_NAME(hcl), TOKEN_LOC(hcl)); - break; - - /* - case HCL_IOTOK_REAL: - obj = hcl_makerealnum(hcl, HCL_IOTOK_RVAL(hcl)); - break; - */ - - case HCL_IOTOK_STRLIT: - obj = hcl_makestring(hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl), 0); - break; - - case HCL_IOTOK_IDENT: - obj = hcl_makesymbol(hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl)); - break; - - case HCL_IOTOK_IDENT_DOTTED: - obj = hcl_makesymbol(hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl)); - if (obj && !hcl_getatsysdic(hcl, obj)) - { - /* query the module for information if it is the first time - * when the dotted symbol is seen */ - - hcl_pfbase_t* pfbase; - hcl_mod_t* mod; - hcl_oop_t val; - unsigned int kernel_bits; - - pfbase = hcl_querymod(hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl), &mod); - if (!pfbase) - { - /* TODO switch to syntax error */ - return -1; - } - - hcl_pushvolat (hcl, &obj); - switch (pfbase->type) - { - case HCL_PFBASE_FUNC: - kernel_bits = 2; - val = hcl_makeprim(hcl, pfbase->handler, pfbase->minargs, pfbase->maxargs, mod); - break; - - case HCL_PFBASE_VAR: - kernel_bits = 1; - val = hcl->_nil; - break; - - case HCL_PFBASE_CONST: - /* TODO: create a value from the pfbase information. it needs to get extended first - * can i make use of pfbase->handler type-cast to a differnt type? */ - kernel_bits = 2; - val = hcl->_nil; - break; - - default: - hcl_popvolat (hcl); - hcl_seterrbfmt (hcl, HCL_EINVAL, "invalid pfbase type - %d\n", pfbase->type); - return -1; - } - - if (!val || !hcl_putatsysdic(hcl, obj, val)) - { - hcl_popvolat (hcl); - return -1; - } - hcl_popvolat (hcl); - - /* make this dotted symbol special that it can't get changed - * to a different value */ - HCL_OBJ_SET_FLAGS_KERNEL (obj, kernel_bits); - } - break; - } - - if (!obj) return -1; - -#if 0 - /* check if the element is read for a quoted list */ - while (flagv & QUOTED) - { - int oldflagv; - - HCL_ASSERT (hcl, level > 0); - - /* if so, append the element read into the quote list */ - if (chain_to_list(hcl, obj) == HCL_NULL) return -1; - - /* exit out of the quoted list. the quoted list can have - * one element only. */ - obj = leave_list(hcl, &flagv, &oldflagv); - - /* one level up toward the top */ - level--; - - if (LIST_FLAG_GET_CONCODE(oldflagv) == HCL_CONCODE_ARRAY) array_level--; - } -#endif - - /* check if we are at the top level */ - if (level <= 0) break; /* yes */ - - /* if not, append the element read into the current list. - * if we are not at the top level, we must be in a list */ - if (chain_to_list(hcl, obj) == HCL_NULL) return -1; - clear_comma_colon_flag (hcl); - - /* read the next token */ - GET_TOKEN (hcl); - } - - /* upon exit, we must be at the top level */ - HCL_ASSERT (hcl, level == 0); - HCL_ASSERT (hcl, array_level == 0); - - hcl->c->r.e = obj; - return 0; -} - -static HCL_INLINE int __read (hcl_t* hcl) -{ - if (get_token(hcl) <= -1) return -1; - if (TOKEN_TYPE(hcl) == HCL_IOTOK_EOF) - { - hcl_seterrnum (hcl, HCL_EFINIS); - return -1; - } - 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; -} - -/* ========================================================================= */ - -/* TODO: rename compiler to something else that can include reader, printer, and compiler - * move compiler intialization/finalization here to more common place */ - -static void gc_compiler (hcl_t* hcl) -{ - hcl_ooi_t i; - - hcl->c->r.s = hcl_moveoop (hcl, hcl->c->r.s); - hcl->c->r.e = hcl_moveoop (hcl, hcl->c->r.e); - - - for (i = 0; i <= hcl->c->cfs.top; i++) - { - hcl->c->cfs.ptr[i].operand = hcl_moveoop(hcl, hcl->c->cfs.ptr[i].operand); - } - - for (i = 0; i < hcl->c->tv.size; i++) - { - hcl->c->tv.ptr[i] = hcl_moveoop (hcl, hcl->c->tv.ptr[i]); - } - - for (i = 0; i < hcl->c->r.salit.size; i++) - { - hcl->c->r.salit.ptr[i] = hcl_moveoop (hcl, hcl->c->r.salit.ptr[i]); - } -} - -static void fini_compiler (hcl_t* hcl) -{ - /* called before the hcl object is closed */ - if (hcl->c) - { - if (hcl->c->r.balit.ptr) - { - hcl_freemem (hcl, hcl->c->r.balit.ptr); - hcl->c->r.balit.ptr = HCL_NULL; - hcl->c->r.balit.size = 0; - hcl->c->r.balit.capa = 0; - } - - if (hcl->c->r.salit.ptr) - { - hcl_freemem (hcl, hcl->c->r.salit.ptr); - hcl->c->r.salit.ptr = HCL_NULL; - hcl->c->r.salit.size = 0; - hcl->c->r.salit.capa = 0; - } - - if (hcl->c->cfs.ptr) - { - hcl_freemem (hcl, hcl->c->cfs.ptr); - hcl->c->cfs.ptr = HCL_NULL; - hcl->c->cfs.top = -1; - hcl->c->cfs.capa = 0; - } - - if (hcl->c->cfs2.ptr) - { - hcl_freemem (hcl, hcl->c->cfs2.ptr); - hcl->c->cfs2.ptr = HCL_NULL; - hcl->c->cfs2.top = -1; - hcl->c->cfs2.capa = 0; - } - - if (hcl->c->tv.ptr) - { - hcl_freemem (hcl, hcl->c->tv.ptr); - hcl->c->tv.ptr = HCL_NULL; - hcl->c->tv.size = 0; - hcl->c->tv.capa = 0; - } - - if (hcl->c->tv2.s.ptr) - { - hcl_freemem (hcl, hcl->c->tv2.s.ptr); - hcl->c->tv2.s.ptr = HCL_NULL; - hcl->c->tv2.s.len = 0; - hcl->c->tv2.capa = 0; - hcl->c->tv2.wcount = 0; - } - HCL_ASSERT (hcl, hcl->c->tv2.capa == 0); - HCL_ASSERT (hcl, hcl->c->tv2.wcount == 0); - - if (hcl->c->blk.info) - { - hcl_freemem (hcl, hcl->c->blk.info); - hcl->c->blk.info = HCL_NULL; - hcl->c->blk.info_capa = 0; - hcl->c->blk.depth = -1; - } - - clear_io_names (hcl); - if (hcl->c->tok.name.ptr) hcl_freemem (hcl, hcl->c->tok.name.ptr); - - hcl_detachio (hcl); - - hcl_freemem (hcl, hcl->c); - hcl->c = HCL_NULL; - } -} - -int hcl_attachio (hcl_t* hcl, hcl_ioimpl_t reader, hcl_ioimpl_t printer) -{ - int n; - hcl_cb_t* cbp = HCL_NULL; - - if (!reader || !printer) - { - hcl_seterrbfmt (hcl, HCL_EINVAL, "reader and/or printer not supplied"); - return -1; - } - - if (!hcl->c) - { - hcl_cb_t cb; - - HCL_MEMSET (&cb, 0, HCL_SIZEOF(cb)); - cb.gc = gc_compiler; - cb.fini = fini_compiler; - cbp = hcl_regcb(hcl, &cb); - if (!cbp) return -1; - - hcl->c = (hcl_compiler_t*)hcl_callocmem(hcl, HCL_SIZEOF(*hcl->c)); - if (!hcl->c) - { - hcl_deregcb (hcl, cbp); - return -1; - } - - hcl->c->ilchr_ucs.ptr = &hcl->c->ilchr; - hcl->c->ilchr_ucs.len = 1; - - hcl->c->r.s = hcl->_nil; - hcl->c->r.e = hcl->_nil; - - hcl->c->cfs.top = -1; - hcl->c->cfs2.top = -1; - hcl->c->blk.depth = -1; - } - else if (hcl->c->reader || hcl->c->printer) - { - hcl_seterrnum (hcl, HCL_EPERM); /* TODO: change this error code */ - return -1; - } - - /* Some IO names could have been stored in earlier calls to this function. - * I clear such names before i begin this function. i don't clear it - * at the end of this function because i may be referenced as an error - * location */ - clear_io_names (hcl); - - /* initialize some key fields */ - hcl->c->printer = printer; - hcl->c->reader = reader; - hcl->c->nungots = 0; - - /* The name field and the includer field are HCL_NULL - * for the main stream */ - HCL_MEMSET (&hcl->c->inarg, 0, HCL_SIZEOF(hcl->c->inarg)); - hcl->c->inarg.line = 1; - hcl->c->inarg.colm = 1; - - /* open the top-level stream */ - n = hcl->c->reader(hcl, HCL_IO_OPEN, &hcl->c->inarg); - if (n <= -1) goto oops; - - HCL_MEMSET (&hcl->c->outarg, 0, HCL_SIZEOF(hcl->c->outarg)); - n = hcl->c->printer(hcl, HCL_IO_OPEN, &hcl->c->outarg); - if (n <= -1) - { - hcl->c->reader (hcl, HCL_IO_CLOSE, &hcl->c->inarg); - goto oops; - } - - /* the stream is open. set it as the current input stream */ - hcl->c->curinp = &hcl->c->inarg; - return 0; - -oops: - if (cbp) - { - hcl_deregcb (hcl, cbp); - hcl_freemem (hcl, hcl->c); - hcl->c = HCL_NULL; - } - else - { - hcl->c->printer = HCL_NULL; - hcl->c->reader = HCL_NULL; - } - return -1; -} - -void hcl_flushio (hcl_t* hcl) -{ - if (hcl->c) - { - if (hcl->c->printer) hcl->c->printer (hcl, HCL_IO_FLUSH, &hcl->c->outarg); - } -} - -void hcl_detachio (hcl_t* hcl) -{ - /* an error occurred and control has reached here - * probably, some included files might not have been - * closed. close them */ - - if (hcl->c) - { - if (hcl->c->reader) - { - while (hcl->c->curinp != &hcl->c->inarg) - { - hcl_ioinarg_t* prev; - - /* nothing much to do about a close error */ - hcl->c->reader (hcl, HCL_IO_CLOSE, hcl->c->curinp); - - prev = hcl->c->curinp->includer; - HCL_ASSERT (hcl, hcl->c->curinp->name != HCL_NULL); - hcl_freemem (hcl, hcl->c->curinp); - hcl->c->curinp = prev; - } - - hcl->c->reader (hcl, HCL_IO_CLOSE, hcl->c->curinp); - hcl->c->reader = HCL_NULL; /* ready for another attachment */ - } - - if (hcl->c->printer) - { - hcl->c->printer (hcl, HCL_IO_CLOSE, &hcl->c->outarg); - hcl->c->printer = HCL_NULL; /* ready for another attachment */ - } - } -} - -hcl_iolxc_t* hcl_readchar (hcl_t* hcl) -{ - int n = get_char(hcl); - if (n <= -1) return HCL_NULL; - return &hcl->c->lxc; -} - -int hcl_unreadchar (hcl_t* hcl, const hcl_iolxc_t* c) -{ - if (hcl->c->nungots >= HCL_COUNTOF(hcl->c->ungot)) - { - hcl_seterrbfmt (hcl, HCL_EBUFFULL, "character unread buffer full"); - return -1; - } - - unget_char (hcl, c); - return 0; -} diff --git a/lib/read2.c b/lib/read2.c index 45a1e79..ecc5fc1 100644 --- a/lib/read2.c +++ b/lib/read2.c @@ -2075,8 +2075,6 @@ hcl_cnodetoobj (hcl_t* hcl, hcl_cnode_t* x) } */ -#if 0 -/* ========================================================================= */ /* TODO: rename compiler to something else that can include reader, printer, and compiler * move compiler intialization/finalization here to more common place */ @@ -2134,6 +2132,14 @@ static void fini_compiler (hcl_t* hcl) hcl->c->cfs.capa = 0; } + if (hcl->c->cfs2.ptr) + { + hcl_freemem (hcl, hcl->c->cfs2.ptr); + hcl->c->cfs2.ptr = HCL_NULL; + hcl->c->cfs2.top = -1; + hcl->c->cfs2.capa = 0; + } + if (hcl->c->tv.ptr) { hcl_freemem (hcl, hcl->c->tv.ptr); @@ -2142,14 +2148,16 @@ static void fini_compiler (hcl_t* hcl) hcl->c->tv.capa = 0; } - if (hcl->c->tv2.ptr) + if (hcl->c->tv2.s.ptr) { - hcl_freemem (hcl, hcl->c->tv2.ptr); - hcl->c->tv2.ptr = HCL_NULL; - hcl->c->tv2.len = 0; + hcl_freemem (hcl, hcl->c->tv2.s.ptr); + hcl->c->tv2.s.ptr = HCL_NULL; + hcl->c->tv2.s.len = 0; hcl->c->tv2.capa = 0; hcl->c->tv2.wcount = 0; } + HCL_ASSERT (hcl, hcl->c->tv2.capa == 0); + HCL_ASSERT (hcl, hcl->c->tv2.wcount == 0); if (hcl->c->blk.info) { @@ -2204,6 +2212,7 @@ int hcl_attachio (hcl_t* hcl, hcl_ioimpl_t reader, hcl_ioimpl_t printer) hcl->c->r.e = hcl->_nil; hcl->c->cfs.top = -1; + hcl->c->cfs2.top = -1; hcl->c->blk.depth = -1; } else if (hcl->c->reader || hcl->c->printer) @@ -2321,4 +2330,3 @@ int hcl_unreadchar (hcl_t* hcl, const hcl_iolxc_t* c) unget_char (hcl, c); return 0; } -#endif