diff --git a/lib/comp.c b/lib/comp.c index f212955..037cf21 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -1325,7 +1325,7 @@ static int compile_object (hcl_t* hcl) break; case HCL_BRAND_SYMBOL_ARRAY: - HCL_DEBUG1 (hcl, "Syntax error - variable declartion disallowed - %O\n", cf->operand); + HCL_DEBUG1 (hcl, "Syntax error - variable declaration disallowed - %O\n", cf->operand); hcl_setsynerr (hcl, HCL_SYNERR_VARDCLBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */ return -1; diff --git a/lib/decode.c b/lib/decode.c index 55b4f82..b597eb3 100644 --- a/lib/decode.c +++ b/lib/decode.c @@ -26,13 +26,21 @@ #include "hcl-prv.h" +#define DECODE_LOG_MASK (HCL_LOG_MNEMONIC | HCL_LOG_INFO) -#define DECODE_LOG_MASK (HCL_LOG_MNEMONIC) - -#define LOG_INST_0(hcl,fmt) HCL_LOG1(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer) -#define LOG_INST_1(hcl,fmt,a1) HCL_LOG2(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer, a1) -#define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG3(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2) -#define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG4(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3) +#if defined(NDEBUG) + /* get rid of instruction logging regardless of the log mask + * in the release build */ +# define LOG_INST_0(hcl,fmt) +# define LOG_INST_1(hcl,fmt,a1) +# define LOG_INST_2(hcl,fmt,a1,a2) +# define LOG_INST_3(hcl,fmt,a1,a2,a3) +#else +# define LOG_INST_0(hcl,fmt) HCL_LOG1(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer) +# define LOG_INST_1(hcl,fmt,a1) HCL_LOG2(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer, a1) +# define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG3(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer, a1, a2) +# define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG4(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3) +#endif #define FETCH_BYTE_CODE(hcl) (cdptr[ip++]) #define FETCH_BYTE_CODE_TO(hcl,v_ooi) (v_ooi = FETCH_BYTE_CODE(hcl)) diff --git a/lib/exec.c b/lib/exec.c index 8bf478b..a817bc3 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -108,7 +108,7 @@ #if defined(HCL_DEBUG_VM_EXEC) -# define LOG_MASK_INST (HCL_LOG_IC | HCL_LOG_MNEMONIC) +# define LOG_MASK_INST (HCL_LOG_IC | HCL_LOG_MNEMONIC | HCL_LOG_INFO) # define LOG_INST_0(hcl,fmt) HCL_LOG1(hcl, LOG_MASK_INST, "%010zd " fmt "\n", fetched_instruction_pointer) # define LOG_INST_1(hcl,fmt,a1) HCL_LOG2(hcl, LOG_MASK_INST, "%010zd " fmt "\n",fetched_instruction_pointer, a1) @@ -903,7 +903,7 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi HCL_ASSERT (hcl, HCL_OBJ_GET_SIZE(rcv_blkctx) > HCL_CONTEXT_NAMED_INSTVARS); HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, "Error - re-valuing of a block context - %O\n", rcv_blkctx); - hcl_seterrnum (hcl, HCL_ERECALL); + hcl_seterrbfmt (hcl, HCL_ERECALL, "cannot recall %O", rcv_blkctx); return -1; } HCL_ASSERT (hcl, HCL_OBJ_GET_SIZE(rcv_blkctx) == HCL_CONTEXT_NAMED_INSTVARS); @@ -1560,16 +1560,16 @@ static int execute (hcl_t* hcl) handle_call: LOG_INST_1 (hcl, "call %zu", b1); - rcv = HCL_STACK_GETRCV (hcl, b1); + rcv = HCL_STACK_GETRCV(hcl, b1); if (HCL_OOP_IS_POINTER(rcv)) { switch (HCL_OBJ_GET_FLAGS_BRAND(rcv)) { case HCL_BRAND_CONTEXT: - if (activate_context (hcl, b1) <= -1) return -1; + if (activate_context(hcl, b1) <= -1) return -1; break; case HCL_BRAND_PRIM: - if (call_primitive (hcl, b1) <= -1) return -1; + if (call_primitive(hcl, b1) <= -1) return -1; break; default: goto cannot_call; diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 32b1b95..615cda9 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -73,7 +73,6 @@ #include /* TODO: delete these header inclusion lines */ #include -#include #if defined(__has_builtin) # if __has_builtin(__builtin_memset) @@ -235,6 +234,8 @@ #endif +typedef hcl_ooi_t (*hcl_outbfmt_t) (hcl_t* hcl, hcl_oow_t mask, const hcl_bch_t* fmt, ...); + #if defined(HCL_INCLUDE_COMPILER) /* ========================================================================= */ @@ -1091,6 +1092,32 @@ int hcl_addbuiltinprims ( hcl_t* hcl ); +/* ========================================================================= */ +/* logfmt.c */ +/* ========================================================================= */ +hcl_ooi_t hcl_proutbfmt ( + hcl_t* hcl, + hcl_oow_t mask, + const hcl_bch_t* fmt, + ... +); + +hcl_ooi_t hcl_proutufmt ( + hcl_t* hcl, + hcl_oow_t mask, + const hcl_uch_t* fmt, + ... +); + +int hcl_outfmtobj ( + hcl_t* hcl, + hcl_oow_t mask, + hcl_oop_t obj, + hcl_outbfmt_t outbfmt +); + + + /* TODO: remove debugging functions */ /* ========================================================================= */ /* debug.c */ diff --git a/lib/hcl.h b/lib/hcl.h index 6d4eee3..395bf18 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -474,6 +474,12 @@ struct hcl_obj_word_t hcl_oow_t slot[1]; }; +#define HCL_OBJ_GET_OOP_SLOT(oop) (((hcl_oop_oop_t)(oop))->slot) +#define HCL_OBJ_GET_CHAR_SLOT(oop) (((hcl_oop_char_t)(oop))->slot) +#define HCL_OBJ_GET_BYTE_SLOT(oop) (((hcl_oop_byte_t)(oop))->slot) +#define HCL_OBJ_GET_HALFWORD_SLOT(oop) (((hcl_oop_halfword_t)(oop))->slot) +#define HCL_OBJ_GET_WORD_SLOT(oop) (((hcl_oop_word_t)(oop))->slot) + typedef struct hcl_trailer_t hcl_trailer_t; struct hcl_trailer_t { diff --git a/lib/logfmt.c b/lib/logfmt.c index 370a7f3..62ce309 100644 --- a/lib/logfmt.c +++ b/lib/logfmt.c @@ -158,7 +158,6 @@ struct hcl_fmtout_t * written in the buffer (i.e., the first character of the string). * The buffer pointed to by `nbuf' must have length >= MAXNBUF. */ - static hcl_bch_t* sprintn_lower (hcl_bch_t* nbuf, hcl_uintmax_t num, int base, hcl_ooi_t* lenp) { hcl_bch_t* p; @@ -372,220 +371,6 @@ redo: /* ------------------------------------------------------------------------- */ -typedef hcl_ooi_t (*outbfmt_t) (hcl_t* hcl, hcl_oow_t mask, const hcl_bch_t* fmt, ...); - - -static hcl_ooi_t log_object (hcl_t* hcl, hcl_iocmd_t cmd, void* arg) -{ - hcl_iooutarg_t* outarg = (hcl_iooutarg_t*)arg; - put_oocs (hcl, (hcl_oow_t)outarg->handle, outarg->ptr, outarg->len); - return outarg->len; /* don't really care about failure as it's for logging */ -} - -static int print_object (hcl_t* hcl, hcl_oow_t mask, hcl_oop_t obj) -{ - hcl_iooutarg_t outarg; - outarg.handle = (void*)mask; - return hcl_printobj (hcl, obj, log_object, &outarg); -} - -#if 0 -static void print_object (hcl_t* hcl, hcl_oow_t mask, hcl_oop_t oop, outbfmt_t outbfmt) -{ - - - if (oop == hcl->_nil) - { - outbfmt (hcl, mask, "nil"); - } - else if (oop == hcl->_true) - { - outbfmt (hcl, mask, "true"); - } - else if (oop == hcl->_false) - { - outbfmt (hcl, mask, "false"); - } - else if (HCL_OOP_IS_SMOOI(oop)) - { - outbfmt (hcl, mask, "%zd", HCL_OOP_TO_SMOOI(oop)); - } - else if (HCL_OOP_IS_SMPTR(oop)) - { - outbfmt (hcl, mask, "%p", HCL_OOP_TO_SMPTR(oop)); - } - else if (HCL_OOP_IS_CHAR(oop)) - { - outbfmt (hcl, mask, "$%.1C", HCL_OOP_TO_CHAR(oop)); - } - else if (HCL_OOP_IS_ERROR(oop)) - { - outbfmt (hcl, mask, "error(%zd)", HCL_OOP_TO_ERROR(oop)); - } - else - { - hcl_oop_class_t c; - hcl_oow_t i; - - HCL_ASSERT (hcl, HCL_OOP_IS_POINTER(oop)); - c = (hcl_oop_class_t)HCL_OBJ_GET_CLASS(oop); /*HCL_CLASSOF(hcl, oop);*/ - - if (c == hcl->_large_negative_integer) - { - hcl_oow_t i; - outbfmt (hcl, mask, "-16r"); - for (i = HCL_OBJ_GET_SIZE(oop); i > 0;) - { - outbfmt (hcl, mask, "%0*lX", (int)(HCL_SIZEOF(hcl_liw_t) * 2), (unsigned long)((hcl_oop_liword_t)oop)->slot[--i]); - } - } - else if (c == hcl->_large_positive_integer) - { - hcl_oow_t i; - outbfmt (hcl, mask, "16r"); - for (i = HCL_OBJ_GET_SIZE(oop); i > 0;) - { - outbfmt (hcl, mask, "%0*lX", (int)(HCL_SIZEOF(hcl_liw_t) * 2), (unsigned long)((hcl_oop_liword_t)oop)->slot[--i]); - } - } - else if (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_CHAR) - { - if (c == hcl->_symbol) - { - outbfmt (hcl, mask, "#%.*js", HCL_OBJ_GET_SIZE(oop), ((hcl_oop_char_t)oop)->slot); - } - else /*if ((hcl_oop_t)c == hcl->_string)*/ - { - hcl_ooch_t ch; - int escape = 0; - - for (i = 0; i < HCL_OBJ_GET_SIZE(oop); i++) - { - ch = ((hcl_oop_char_t)oop)->slot[i]; - if (ch < ' ') - { - escape = 1; - break; - } - } - - if (escape) - { - hcl_ooch_t escaped; - - outbfmt (hcl, mask, "S'"); - for (i = 0; i < HCL_OBJ_GET_SIZE(oop); i++) - { - ch = ((hcl_oop_char_t)oop)->slot[i]; - if (ch < ' ') - { - switch (ch) - { - case '\0': - escaped = '0'; - break; - case '\n': - escaped = 'n'; - break; - case '\r': - escaped = 'r'; - break; - case '\t': - escaped = 't'; - break; - case '\f': - escaped = 'f'; - break; - case '\b': - escaped = 'b'; - break; - case '\v': - escaped = 'v'; - break; - case '\a': - escaped = 'a'; - break; - default: - escaped = ch; - break; - } - - if (escaped == ch) - outbfmt (hcl, mask, "\\x%X", ch); - else - outbfmt (hcl, mask, "\\%jc", escaped); - } - else - { - outbfmt (hcl, mask, "%jc", ch); - } - } - - outbfmt (hcl, mask, "'"); - } - else - { - outbfmt (hcl, mask, "'%.*js'", HCL_OBJ_GET_SIZE(oop), ((hcl_oop_char_t)oop)->slot); - } - } - } - else if (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_BYTE) - { - outbfmt (hcl, mask, "#["); - for (i = 0; i < HCL_OBJ_GET_SIZE(oop); i++) - { - outbfmt (hcl, mask, " %d", ((hcl_oop_byte_t)oop)->slot[i]); - } - outbfmt (hcl, mask, "]"); - } - - else if (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_HALFWORD) - { - outbfmt (hcl, mask, "#[["); /* TODO: fix this symbol/notation */ - for (i = 0; i < HCL_OBJ_GET_SIZE(oop); i++) - { - outbfmt (hcl, mask, " %zX", (hcl_oow_t)((hcl_oop_halfword_t)oop)->slot[i]); - } - outbfmt (hcl, mask, "]]"); - } - else if (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_WORD) - { - outbfmt (hcl, mask, "#[[["); /* TODO: fix this symbol/notation */ - for (i = 0; i < HCL_OBJ_GET_SIZE(oop); i++) - { - outbfmt (hcl, mask, " %zX", ((hcl_oop_word_t)oop)->slot[i]); - } - outbfmt (hcl, mask, "]]]"); - } - else if (c == hcl->_array) - { - outbfmt (hcl, mask, "#("); - for (i = 0; i < HCL_OBJ_GET_SIZE(oop); i++) - { - outbfmt (hcl, mask, " "); - print_object (hcl, mask, ((hcl_oop_oop_t)oop)->slot[i], outbfmt); - } - outbfmt (hcl, mask, ")"); - } - else if (c == hcl->_class) - { - /* print the class name */ - outbfmt (hcl, mask, "%.*js", HCL_OBJ_GET_SIZE(((hcl_oop_class_t)oop)->name), ((hcl_oop_class_t)oop)->name->slot); - } - else if (c == hcl->_association) - { - outbfmt (hcl, mask, "%O -> %O", ((hcl_oop_association_t)oop)->key, ((hcl_oop_association_t)oop)->value); - } - else - { - outbfmt (hcl, mask, "<<%.*js>>", HCL_OBJ_GET_SIZE(c->name), ((hcl_oop_char_t)c->name)->slot); - } - } -} -#endif - -/* ------------------------------------------------------------------------- */ - #undef FMTCHAR_IS_BCH #undef FMTCHAR_IS_UCH #undef FMTCHAR_IS_OOCH @@ -685,7 +470,90 @@ hcl_ooi_t hcl_logufmt (hcl_t* hcl, hcl_oow_t mask, const hcl_uch_t* fmt, ...) return (x <= -1)? -1: fo.count; } +/* -------------------------------------------------------------------------- + * HELPER FOR PRINTING + * -------------------------------------------------------------------------- */ +static int put_prch (hcl_t* hcl, hcl_oow_t mask, hcl_ooch_t ch, hcl_oow_t len) +{ +/* TODO: error handling, buffering */ + hcl->c->outarg.ptr = &ch; + hcl->c->outarg.len = 1; + hcl->c->printer (hcl, HCL_IO_WRITE, &hcl->c->outarg); + return 1; /* success */ +} + +static int put_prcs (hcl_t* hcl, hcl_oow_t mask, const hcl_ooch_t* ptr, hcl_oow_t len) +{ + /* TODO: error handling, buffering */ + hcl->c->outarg.ptr = (hcl_ooch_t*)ptr; + hcl->c->outarg.len = len; + hcl->c->printer (hcl, HCL_IO_WRITE, &hcl->c->outarg); + return 1; /* success */ +} + +static hcl_ooi_t __prbfmtv (hcl_t* hcl, hcl_oow_t mask, const hcl_bch_t* fmt, ...); + +static int _prbfmtv (hcl_t* hcl, const hcl_bch_t* fmt, hcl_fmtout_t* data, va_list ap) +{ + return __logbfmtv (hcl, fmt, data, ap, __prbfmtv); +} + +static int _prufmtv (hcl_t* hcl, const hcl_uch_t* fmt, hcl_fmtout_t* data, va_list ap) +{ + return __logufmtv (hcl, fmt, data, ap, __prbfmtv); +} + +static hcl_ooi_t __prbfmtv (hcl_t* hcl, hcl_oow_t mask, const hcl_bch_t* fmt, ...) +{ + va_list ap; + hcl_fmtout_t fo; + + fo.mask = 0; /* not used */ + fo.putch = put_prch; + fo.putcs = put_prcs; + + va_start (ap, fmt); + _prbfmtv (hcl, fmt, &fo, ap); + va_end (ap); + + return fo.count; +} + +hcl_ooi_t hcl_proutbfmt (hcl_t* hcl, hcl_oow_t mask, const hcl_bch_t* fmt, ...) +{ + int x; + va_list ap; + hcl_fmtout_t fo; + + fo.mask = 0; /* not used */ + fo.putch = put_prch; + fo.putcs = put_prcs; + + va_start (ap, fmt); + x = _prbfmtv (hcl, fmt, &fo, ap); + va_end (ap); + + return (x <= -1)? -1: fo.count; +} + +hcl_ooi_t hcl_proutufmt (hcl_t* hcl, hcl_oow_t mask, const hcl_uch_t* fmt, ...) +{ + int x; + va_list ap; + hcl_fmtout_t fo; + + fo.mask = 0; /* not used */ + fo.putch = put_prch; + fo.putcs = put_prcs; + + va_start (ap, fmt); + x = _prufmtv (hcl, fmt, &fo, ap); + va_end (ap); + + return (x <= -1)? -1: fo.count; +} + /* -------------------------------------------------------------------------- * ERROR MESSAGE FORMATTING * -------------------------------------------------------------------------- */ @@ -816,3 +684,4 @@ void hcl_seterrufmtv (hcl_t* hcl, hcl_errnum_t errnum, const hcl_uch_t* fmt, va_ _errufmtv (hcl, fmt, &fo, ap); } + diff --git a/lib/logfmtv.h b/lib/logfmtv.h index af1fae3..c920018 100644 --- a/lib/logfmtv.h +++ b/lib/logfmtv.h @@ -85,7 +85,7 @@ data->count += len; \ } while (0) -static int logfmtv (hcl_t* hcl, const fmtchar_t* fmt, hcl_fmtout_t* data, va_list ap, outbfmt_t outbfmt) +static int logfmtv (hcl_t* hcl, const fmtchar_t* fmt, hcl_fmtout_t* data, va_list ap, hcl_outbfmt_t outbfmt) { const fmtchar_t* percent; #if defined(FMTCHAR_IS_OOCH) @@ -554,7 +554,7 @@ reswitch: } case 'O': /* object - ignore precision, width, adjustment */ - //print_object (hcl, data->mask, va_arg(ap, hcl_oop_t), outbfmt); + if (hcl_outfmtobj(hcl, data->mask, va_arg(ap, hcl_oop_t), outbfmt) <= -1) goto oops; break; #if 0 diff --git a/lib/main.c b/lib/main.c index 50897d7..17b8b8a 100644 --- a/lib/main.c +++ b/lib/main.c @@ -1027,14 +1027,14 @@ int main (int argc, char* argv[]) if (hcl_ignite(hcl) <= -1) { - printf ("cannot ignite hcl - %d\n", hcl_geterrnum(hcl)); + hcl_logbfmt (hcl, HCL_LOG_STDERR, "cannot ignite hcl - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); hcl_close (hcl); return -1; } if (hcl_addbuiltinprims(hcl) <= -1) { - printf ("cannot add builtin primitives - %d\n", hcl_geterrnum(hcl)); + hcl_logbfmt (hcl, HCL_LOG_STDERR, "cannot add builtin primitives - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); hcl_close (hcl); return -1; } @@ -1044,7 +1044,7 @@ int main (int argc, char* argv[]) if (hcl_attachio (hcl, read_handler, print_handler) <= -1) { - printf ("ERROR: cannot attache input stream - %d\n", hcl_geterrnum(hcl)); + hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot attache input stream - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); hcl_close (hcl); return -1; } @@ -1067,7 +1067,7 @@ int main (int argc, char* argv[]) } else { - printf ("ERROR: cannot read object - %d\n", hcl_geterrnum(hcl)); + hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot read object - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); } break; @@ -1076,11 +1076,11 @@ int main (int argc, char* argv[]) if (hcl_print(hcl, obj) <= -1) { - printf ("ERROR: cannot print object - %d\n", hcl_geterrnum(hcl)); + hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot print object - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); } else { - hcl_print (hcl, HCL_CHAR_TO_OOP('\n')); + hcl_proutbfmt (hcl, 0, "\n"); if (hcl_compile(hcl, obj) <= -1) { if (hcl->errnum == HCL_ESYNERR) @@ -1089,7 +1089,7 @@ int main (int argc, char* argv[]) } else { - printf ("ERROR: cannot compile object - %d\n", hcl_geterrnum(hcl)); + hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot compile object - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); } /* carry on? */ @@ -1100,13 +1100,13 @@ int main (int argc, char* argv[]) hcl_decode (hcl, 0, hcl->code.bc.len); HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n"); g_hcl = hcl; -setup_tick (); +//setup_tick (); if (hcl_execute(hcl) <= -1) { hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot execute - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); } -cancel_tick(); +//cancel_tick(); g_hcl = HCL_NULL; diff --git a/lib/print.c b/lib/print.c index 01b7821..6c634a5 100644 --- a/lib/print.c +++ b/lib/print.c @@ -26,33 +26,9 @@ #include "hcl-prv.h" + #define PRINT_STACK_ALIGN 128 -struct printer_t -{ - hcl_t* hcl; - hcl_ioimpl_t printer; - hcl_iooutarg_t* outarg; -}; -typedef struct printer_t printer_t; - -#define OUTPUT_STRX(pr,p,l) \ -do { \ - (pr)->outarg->ptr = p; \ - (pr)->outarg->len = l; \ - if ((pr)->printer((pr)->hcl, HCL_IO_WRITE, (pr)->outarg) <= -1) \ - { \ - hcl_seterrnum ((pr)->hcl, HCL_EIOERR); \ - return -1; \ - } \ -} while(0) - -#define OUTPUT_STR(pr,p) OUTPUT_STRX(pr,p,hcl_countoocstr(p)) - -#define OUTPUT_CHAR(pr,ch) do { \ - hcl_ooch_t tmp = ch; \ - OUTPUT_STRX (pr, &tmp, 1); \ -} while(0) #define PRINT_STACK_ARRAY_END 0 #define PRINT_STACK_CONS 1 @@ -94,107 +70,13 @@ static HCL_INLINE void pop (hcl_t* hcl, print_stack_t* info) *info = ((print_stack_t*)hcl->p.s.ptr)[hcl->p.s.size]; } -static hcl_oow_t long_to_str ( - hcl_ooi_t value, int radix, - const hcl_ooch_t* prefix, hcl_ooch_t* buf, hcl_oow_t size) -{ - hcl_ooi_t t, rem; - hcl_oow_t len, ret, i; - hcl_oow_t prefix_len; - - prefix_len = (prefix != HCL_NULL)? hcl_countoocstr(prefix): 0; - - t = value; - if (t == 0) - { - /* zero */ - if (buf == HCL_NULL) - { - /* if buf is not given, - * return the number of bytes required */ - return prefix_len + 1; - } - - if (size < prefix_len + 1) - { - /* buffer too small */ - return (hcl_oow_t)-1; - } - - for (i = 0; i < prefix_len; i++) buf[i] = prefix[i]; - buf[prefix_len] = '0'; - if (size > prefix_len+1) buf[prefix_len+1] = '\0'; - return prefix_len+1; - } - - /* non-zero values */ - len = prefix_len; - if (t < 0) { t = -t; len++; } - while (t > 0) { len++; t /= radix; } - - if (buf == HCL_NULL) - { - /* if buf is not given, return the number of bytes required */ - return len; - } - - if (size < len) return (hcl_oow_t)-1; /* buffer too small */ - if (size > len) buf[len] = '\0'; - ret = len; - - t = value; - if (t < 0) t = -t; - - while (t > 0) - { - rem = t % radix; - if (rem >= 10) - buf[--len] = (hcl_ooch_t)rem + 'a' - 10; - else - buf[--len] = (hcl_ooch_t)rem + '0'; - t /= radix; - } - - if (value < 0) - { - for (i = 1; i <= prefix_len; i++) - { - buf[i] = prefix[i-1]; - len--; - } - buf[--len] = '-'; - } - else - { - for (i = 0; i < prefix_len; i++) buf[i] = prefix[i]; - } - - return ret; -} - -static HCL_INLINE int print_ooi (printer_t* pr, hcl_ooi_t nval) -{ - hcl_ooch_t tmp[HCL_SIZEOF(hcl_ooi_t)*8+2]; - hcl_oow_t len; - - len = long_to_str (nval, 10, HCL_NULL, tmp, HCL_COUNTOF(tmp)); - OUTPUT_STRX (pr, tmp, len); - return 0; -} - -static HCL_INLINE int print_char (printer_t* pr, hcl_ooch_t ch) -{ - OUTPUT_CHAR (pr, ch); - return 0; -} - enum { WORD_NIL, WORD_TRUE, WORD_FALSE, - WORD_SET, + WORD_SET, WORD_CFRAME, WORD_PRIM, @@ -217,50 +99,52 @@ static struct { 6, { '#','<','S','E','T','>' } }, { 9, { '#','<','C','F','R','A','M','E','>' } }, { 7, { '#','<','P','R','I','M','>' } }, + { 10, { '#','<','C','O','N','T','E','X','T','>' } }, { 10, { '#','<','P','R','O','C','E','S','S','>' } }, { 20, { '#','<','P','R','O','C','E','S','S','-','S','C','H','E','D','U','L','E','R','>' } }, { 12, { '#','<','S','E','M','A','P','H','O','R','E','>' } } }; -static int print_object (printer_t* pr, hcl_oop_t obj) + +int hcl_outfmtobj (hcl_t* hcl, hcl_oow_t mask, hcl_oop_t obj, hcl_outbfmt_t outbfmt) { - hcl_t* hcl; hcl_oop_t cur; print_stack_t ps; int brand; - - hcl = pr->hcl; + int word_index; next: if (HCL_OOP_IS_SMOOI(obj)) { - if (print_ooi (pr, HCL_OOP_TO_SMOOI(obj)) <= -1) return -1; + if (outbfmt(hcl, mask, "%zd", HCL_OOP_TO_SMOOI(obj)) <= -1) return -1; goto done; } else if (HCL_OOP_IS_CHAR(obj)) { - if (print_char (pr, HCL_OOP_TO_CHAR(obj)) <= -1) return -1; + if (outbfmt(hcl, mask, "$%.1jc", HCL_OOP_TO_CHAR(obj)) <= -1) return -1; goto done; } switch ((brand = HCL_OBJ_GET_FLAGS_BRAND(obj))) { case HCL_BRAND_NIL: - OUTPUT_STRX (pr, word[WORD_NIL].ptr, word[WORD_NIL].len); - break; + word_index = WORD_NIL; + goto print_word; case HCL_BRAND_TRUE: - OUTPUT_STRX (pr, word[WORD_TRUE].ptr, word[WORD_TRUE].len); - break; + word_index = WORD_TRUE; + goto print_word; case HCL_BRAND_FALSE: - OUTPUT_STRX (pr, word[WORD_FALSE].ptr, word[WORD_FALSE].len); - break; + word_index = WORD_FALSE; + goto print_word; + case HCL_BRAND_INTEGER: +/* TODO: print properly... print big int */ HCL_ASSERT (hcl, HCL_OBJ_GET_SIZE(obj) == 1); - if (print_ooi (pr, ((hcl_oop_word_t)obj)->slot[0]) <= -1) return -1; + if (outbfmt(hcl, mask, "%zu", ((hcl_oop_word_t)obj)->slot[0]) <= -1) return -1; break; #if 0 @@ -287,19 +171,93 @@ next: /* Any needs for special action if SYNT(obj) is true? * I simply treat the syntax symbol as a normal symbol * for printing currently. */ - OUTPUT_STRX (pr, ((hcl_oop_char_t)obj)->slot, HCL_OBJ_GET_SIZE(obj)); + if (outbfmt(hcl, mask, "%.*js", HCL_OBJ_GET_SIZE(obj), HCL_OBJ_GET_CHAR_SLOT(obj)) <= -1) return -1; break; case HCL_BRAND_STRING: - OUTPUT_CHAR (pr, '\"'); - /* TODO: deescaping */ - OUTPUT_STRX (pr, ((hcl_oop_char_t)obj)->slot, HCL_OBJ_GET_SIZE(obj)); - OUTPUT_CHAR (pr, '\"'); + { + hcl_ooch_t ch; + hcl_oow_t i; + int escape = 0; + + for (i = 0; i < HCL_OBJ_GET_SIZE(obj); i++) + { + ch = ((hcl_oop_char_t)obj)->slot[i]; + if (ch < ' ') + { + escape = 1; + break; + } + } + + if (escape) + { + hcl_ooch_t escaped; + + if (outbfmt(hcl, mask, "\"") <= -1) return -1; + for (i = 0; i < HCL_OBJ_GET_SIZE(obj); i++) + { + ch = ((hcl_oop_char_t)obj)->slot[i]; + if (ch < ' ') + { + switch (ch) + { + case '\0': + escaped = '0'; + break; + case '\n': + escaped = 'n'; + break; + case '\r': + escaped = 'r'; + break; + case '\t': + escaped = 't'; + break; + case '\f': + escaped = 'f'; + break; + case '\b': + escaped = 'b'; + break; + case '\v': + escaped = 'v'; + break; + case '\a': + escaped = 'a'; + break; + default: + escaped = ch; + break; + } + + if (escaped == ch) + { + if (outbfmt(hcl, mask, "\\x%X", ch) <= -1) return -1; + } + else + { + if (outbfmt(hcl, mask, "\\%jc", escaped) <= -1) return -1; + } + } + else + { + if (outbfmt(hcl, mask, "%jc", ch) <= -1) return -1; + } + } + + if (outbfmt(hcl, mask, "\"") <= -1) return -1; + } + else + { + if (outbfmt(hcl, mask, "\"%.*js\"", HCL_OBJ_GET_SIZE(obj), HCL_OBJ_GET_CHAR_SLOT(obj)) <= -1) return -1; + } break; + } case HCL_BRAND_CONS: { - OUTPUT_CHAR (pr, '('); + if (outbfmt(hcl, mask, "(") <= -1) return -1; cur = obj; do @@ -332,9 +290,7 @@ next: if (!HCL_OOP_IS_POINTER(cur) || HCL_OBJ_GET_FLAGS_BRAND(cur) != HCL_BRAND_CONS) { /* The CDR part does not point to a pair. */ - OUTPUT_CHAR (pr, ' '); - OUTPUT_CHAR (pr, '.'); - OUTPUT_CHAR (pr, ' '); + if (outbfmt(hcl, mask, " . ") <= -1) return -1; /* Push NIL so that the HCL_IS_NIL(hcl,p) test in * the 'if' statement above breaks the loop @@ -351,10 +307,10 @@ next: } /* The CDR part points to a pair. proceed to it */ - OUTPUT_CHAR (pr, ' '); + if (outbfmt(hcl, mask, " ") <= -1) return -1; } while (1); - OUTPUT_CHAR (pr, ')'); + if (outbfmt(hcl, mask, ")") <= -1) return -1; break; } @@ -364,20 +320,23 @@ next: if (brand == HCL_BRAND_ARRAY) { - OUTPUT_CHAR (pr, '#'); - OUTPUT_CHAR (pr, '('); + if (outbfmt(hcl, mask, "#(") <= -1) return -1; } else { - OUTPUT_CHAR (pr, '|'); + if (outbfmt(hcl, mask, "|") <= -1) return -1; } if (HCL_OBJ_GET_SIZE(obj) <= 0) { if (brand == HCL_BRAND_ARRAY) - OUTPUT_CHAR (pr, ')'); + { + if (outbfmt(hcl, mask, ")") <= -1) return -1; + } else - OUTPUT_CHAR (pr, '|'); + { + if (outbfmt(hcl, mask, "|") <= -1) return -1; + } break; } arridx = 0; @@ -403,7 +362,10 @@ next: if (x <= -1) return -1; obj = ((hcl_oop_oop_t)obj)->slot[arridx]; - if (arridx > 0) OUTPUT_CHAR (pr, ' '); + if (arridx > 0) + { + if (outbfmt(hcl, mask, " ") <= -1) return -1; + } /* Jump to the 'next' label so that the object * pointed to by 'obj' is printed. Once it * ends, a jump back to the 'resume' label @@ -423,15 +385,13 @@ next: { hcl_oow_t i; - OUTPUT_CHAR (pr, '#'); - OUTPUT_CHAR (pr, '['); + if (outbfmt(hcl, mask, "#[") <= -1) return -1; for (i = 0; i < HCL_OBJ_GET_SIZE(obj); i++) { - if (i > 0) OUTPUT_CHAR (pr, ' '); - if (print_ooi (pr, ((hcl_oop_byte_t)obj)->slot[i]) <= -1) return -1; + if (outbfmt(hcl, mask, "%hs%d", ((i > 0)? " ": ""), ((hcl_oop_byte_t)obj)->slot[i]) <= -1) return -1; } - OUTPUT_CHAR (pr, ']'); + if (outbfmt(hcl, mask, "]") <= -1) return -1; break; } @@ -439,53 +399,56 @@ next: { hcl_oow_t i; - OUTPUT_CHAR (pr, '|'); + if (outbfmt(hcl, mask, "|") <= -1) return -1; for (i = 0; i < HCL_OBJ_GET_SIZE(obj); i++) { hcl_oop_t s; s = ((hcl_oop_oop_t)obj)->slot[i]; - OUTPUT_CHAR (pr, ' '); - OUTPUT_STRX (pr, ((hcl_oop_char_t)s)->slot, HCL_OBJ_GET_SIZE(s)); + if (outbfmt(hcl, mask, " %.*js", HCL_OBJ_GET_SIZE(s), HCL_OBJ_GET_CHAR_SLOT(s)) <= -1) return -1; } - OUTPUT_CHAR (pr, ' '); - OUTPUT_CHAR (pr, '|'); + if (outbfmt(hcl, mask, " |") <= -1) return -1; break; } case HCL_BRAND_SET: - OUTPUT_STRX (pr, word[WORD_SET].ptr, word[WORD_SET].len); - break; + word_index = WORD_SET; + goto print_word; case HCL_BRAND_CFRAME: - OUTPUT_STRX (pr, word[WORD_CFRAME].ptr, word[WORD_CFRAME].len); - break; + word_index = WORD_CFRAME; + goto print_word; case HCL_BRAND_PRIM: - OUTPUT_STRX (pr, word[WORD_PRIM].ptr, word[WORD_PRIM].len); - break; + word_index = WORD_PRIM; + goto print_word; + case HCL_BRAND_CONTEXT: - OUTPUT_STRX (pr, word[WORD_CONTEXT].ptr, word[WORD_CONTEXT].len); - break; + word_index = WORD_CONTEXT; + goto print_word; case HCL_BRAND_PROCESS: - OUTPUT_STRX (pr, word[WORD_PROCESS].ptr, word[WORD_PROCESS].len); - break; + word_index = WORD_PROCESS; + goto print_word; case HCL_BRAND_PROCESS_SCHEDULER: - OUTPUT_STRX (pr, word[WORD_PROCESS_SCHEDULER].ptr, word[WORD_PROCESS_SCHEDULER].len); - break; + word_index = WORD_PROCESS_SCHEDULER; + goto print_word; case HCL_BRAND_SEMAPHORE: - OUTPUT_STRX (pr, word[WORD_SEMAPHORE].ptr, word[WORD_SEMAPHORE].len); - break; + word_index = WORD_SEMAPHORE; + goto print_word; default: HCL_DEBUG3 (hcl, "Internal error - unknown object type %d at %s:%d\n", (int)brand, __FILE__, __LINE__); HCL_ASSERT (hcl, "Unknown object type" == HCL_NULL); - hcl_seterrnum (hcl, HCL_EINTERN); + hcl_seterrbfmt (hcl, HCL_EINTERN, "unknown object type %d", (int)brand); return -1; + + print_word: + if (outbfmt(hcl, mask, "%.*js", word[word_index].len, word[word_index].ptr) <= -1) return -1; + break; } done: @@ -502,24 +465,21 @@ done: goto resume_array; case PRINT_STACK_ARRAY_END: - OUTPUT_CHAR (pr, ')'); + if (outbfmt(hcl, mask, ")") <= -1) return -1; break; default: HCL_DEBUG3 (hcl, "Internal error - unknown print stack type %d at %s:%d\n", (int)ps.type, __FILE__, __LINE__); - hcl_seterrnum (hcl, HCL_EINTERN); + hcl_seterrbfmt (hcl, HCL_EINTERN, "unknown print stack type %d", (int)ps.type); return -1; } } - return 0; } -/* hcl_printobj() is for internal use only. it's called by hcl_print() and a logger. */ -HCL_INLINE int hcl_printobj (hcl_t* hcl, hcl_oop_t obj, hcl_ioimpl_t printer, hcl_iooutarg_t* outarg) +int hcl_print (hcl_t* hcl, hcl_oop_t obj) { int n; - printer_t pr; HCL_ASSERT (hcl, hcl->c->printer != HCL_NULL); @@ -527,10 +487,7 @@ HCL_INLINE int hcl_printobj (hcl_t* hcl, hcl_oop_t obj, hcl_ioimpl_t printer, hc HCL_ASSERT (hcl, hcl->p.s.size == 0); hcl->p.e = obj; /* remember the head of the object to print */ - pr.hcl = hcl; - pr.printer = printer; - pr.outarg = outarg; - n = print_object (&pr, obj); /* call the actual printing routine */ + n = hcl_outfmtobj (hcl, HCL_LOG_APP | HCL_LOG_FATAL, obj, hcl_proutbfmt); hcl->p.e = hcl->_nil; /* reset what's remembered */ /* clear the printing stack if an error has occurred for GC not to keep @@ -542,8 +499,3 @@ HCL_INLINE int hcl_printobj (hcl_t* hcl, hcl_oop_t obj, hcl_ioimpl_t printer, hc return n; } - -int hcl_print (hcl_t* hcl, hcl_oop_t obj) -{ - return hcl_printobj (hcl, obj, hcl->c->printer, &hcl->c->outarg); -}