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

added printing routines

Browse Source
This commit is contained in:
hyung-hwan
2018-02-05 15:59:32 +00:00
parent 71a10e09c6
commit 0adbd2291e
9 changed files with 291 additions and 429 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
hcl/lib/comp.c
View File

@ -1325,7 +1325,7 @@ static int compile_object (hcl_t* hcl)
break; break;
case HCL_BRAND_SYMBOL_ARRAY: 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 */ hcl_setsynerr (hcl, HCL_SYNERR_VARDCLBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */
return -1; return -1;

20
hcl/lib/decode.c
View File

@ -26,13 +26,21 @@
#include "hcl-prv.h" #include "hcl-prv.h"
#define DECODE_LOG_MASK (HCL_LOG_MNEMONIC | HCL_LOG_INFO)
#define DECODE_LOG_MASK (HCL_LOG_MNEMONIC) #if defined(NDEBUG)
/* get rid of instruction logging regardless of the log mask
#define LOG_INST_0(hcl,fmt) HCL_LOG1(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer) * in the release build */
#define LOG_INST_1(hcl,fmt,a1) HCL_LOG2(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer, a1) # define LOG_INST_0(hcl,fmt)
#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_1(hcl,fmt,a1)
#define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG4(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3) # 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(hcl) (cdptr[ip++])
#define FETCH_BYTE_CODE_TO(hcl,v_ooi) (v_ooi = FETCH_BYTE_CODE(hcl)) #define FETCH_BYTE_CODE_TO(hcl,v_ooi) (v_ooi = FETCH_BYTE_CODE(hcl))

4
hcl/lib/exec.c
View File

@ -108,7 +108,7 @@
#if defined(HCL_DEBUG_VM_EXEC) #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_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) # 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_ASSERT (hcl, HCL_OBJ_GET_SIZE(rcv_blkctx) > HCL_CONTEXT_NAMED_INSTVARS);
HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_ERROR,
"Error - re-valuing of a block context - %O\n", rcv_blkctx); "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; return -1;
} }
HCL_ASSERT (hcl, HCL_OBJ_GET_SIZE(rcv_blkctx) == HCL_CONTEXT_NAMED_INSTVARS); HCL_ASSERT (hcl, HCL_OBJ_GET_SIZE(rcv_blkctx) == HCL_CONTEXT_NAMED_INSTVARS);

29
hcl/lib/hcl-prv.h
View File

@ -73,7 +73,6 @@
#include <stdio.h> /* TODO: delete these header inclusion lines */ #include <stdio.h> /* TODO: delete these header inclusion lines */
#include <string.h> #include <string.h>
#include <assert.h>
#if defined(__has_builtin) #if defined(__has_builtin)
# if __has_builtin(__builtin_memset) # if __has_builtin(__builtin_memset)
@ -235,6 +234,8 @@
#endif #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) #if defined(HCL_INCLUDE_COMPILER)
/* ========================================================================= */ /* ========================================================================= */
@ -1091,6 +1092,32 @@ int hcl_addbuiltinprims (
hcl_t* hcl 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 */ /* TODO: remove debugging functions */
/* ========================================================================= */ /* ========================================================================= */
/* debug.c */ /* debug.c */

6
hcl/lib/hcl.h
View File

@ -474,6 +474,12 @@ struct hcl_obj_word_t
hcl_oow_t slot[1]; 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; typedef struct hcl_trailer_t hcl_trailer_t;
struct hcl_trailer_t struct hcl_trailer_t
{ {

299
hcl/lib/logfmt.c
View File

@ -158,7 +158,6 @@ struct hcl_fmtout_t
* written in the buffer (i.e., the first character of the string). * written in the buffer (i.e., the first character of the string).
* The buffer pointed to by `nbuf' must have length >= MAXNBUF. * 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) static hcl_bch_t* sprintn_lower (hcl_bch_t* nbuf, hcl_uintmax_t num, int base, hcl_ooi_t* lenp)
{ {
hcl_bch_t* p; 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_BCH
#undef FMTCHAR_IS_UCH #undef FMTCHAR_IS_UCH
#undef FMTCHAR_IS_OOCH #undef FMTCHAR_IS_OOCH
@ -685,6 +470,89 @@ hcl_ooi_t hcl_logufmt (hcl_t* hcl, hcl_oow_t mask, const hcl_uch_t* fmt, ...)
return (x <= -1)? -1: fo.count; 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 * 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); _errufmtv (hcl, fmt, &fo, ap);
} }

4
hcl/lib/logfmtv.h
View File

@ -85,7 +85,7 @@
data->count += len; \ data->count += len; \
} while (0) } 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; const fmtchar_t* percent;
#if defined(FMTCHAR_IS_OOCH) #if defined(FMTCHAR_IS_OOCH)
@ -554,7 +554,7 @@ reswitch:
} }
case 'O': /* object - ignore precision, width, adjustment */ 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; break;
#if 0 #if 0

18
hcl/lib/main.c
View File

@ -1027,14 +1027,14 @@ int main (int argc, char* argv[])
if (hcl_ignite(hcl) <= -1) 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); hcl_close (hcl);
return -1; return -1;
} }
if (hcl_addbuiltinprims(hcl) <= -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); hcl_close (hcl);
return -1; return -1;
} }
@ -1044,7 +1044,7 @@ int main (int argc, char* argv[])
if (hcl_attachio (hcl, read_handler, print_handler) <= -1) 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); hcl_close (hcl);
return -1; return -1;
} }
@ -1067,7 +1067,7 @@ int main (int argc, char* argv[])
} }
else 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; break;
@ -1076,11 +1076,11 @@ int main (int argc, char* argv[])
if (hcl_print(hcl, obj) <= -1) 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 else
{ {
hcl_print (hcl, HCL_CHAR_TO_OOP('\n')); hcl_proutbfmt (hcl, 0, "\n");
if (hcl_compile(hcl, obj) <= -1) if (hcl_compile(hcl, obj) <= -1)
{ {
if (hcl->errnum == HCL_ESYNERR) if (hcl->errnum == HCL_ESYNERR)
@ -1089,7 +1089,7 @@ int main (int argc, char* argv[])
} }
else 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? */ /* carry on? */
@ -1100,13 +1100,13 @@ int main (int argc, char* argv[])
hcl_decode (hcl, 0, hcl->code.bc.len); hcl_decode (hcl, 0, hcl->code.bc.len);
HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n"); HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n");
g_hcl = hcl; g_hcl = hcl;
setup_tick (); //setup_tick ();
if (hcl_execute(hcl) <= -1) if (hcl_execute(hcl) <= -1)
{ {
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot execute - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl)); 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; g_hcl = HCL_NULL;

332
hcl/lib/print.c
View File

@ -26,33 +26,9 @@
#include "hcl-prv.h" #include "hcl-prv.h"
#define PRINT_STACK_ALIGN 128 #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_ARRAY_END 0
#define PRINT_STACK_CONS 1 #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]; *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 enum
{ {
WORD_NIL, WORD_NIL,
WORD_TRUE, WORD_TRUE,
WORD_FALSE, WORD_FALSE,
WORD_SET,
WORD_SET,
WORD_CFRAME, WORD_CFRAME,
WORD_PRIM, WORD_PRIM,
@ -217,50 +99,52 @@ static struct
{ 6, { '#','<','S','E','T','>' } }, { 6, { '#','<','S','E','T','>' } },
{ 9, { '#','<','C','F','R','A','M','E','>' } }, { 9, { '#','<','C','F','R','A','M','E','>' } },
{ 7, { '#','<','P','R','I','M','>' } }, { 7, { '#','<','P','R','I','M','>' } },
{ 10, { '#','<','C','O','N','T','E','X','T','>' } }, { 10, { '#','<','C','O','N','T','E','X','T','>' } },
{ 10, { '#','<','P','R','O','C','E','S','S','>' } }, { 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','>' } }, { 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','>' } } { 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; hcl_oop_t cur;
print_stack_t ps; print_stack_t ps;
int brand; int brand;
int word_index;
hcl = pr->hcl;
next: next:
if (HCL_OOP_IS_SMOOI(obj)) 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; goto done;
} }
else if (HCL_OOP_IS_CHAR(obj)) 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; goto done;
} }
switch ((brand = HCL_OBJ_GET_FLAGS_BRAND(obj))) switch ((brand = HCL_OBJ_GET_FLAGS_BRAND(obj)))
{ {
case HCL_BRAND_NIL: case HCL_BRAND_NIL:
OUTPUT_STRX (pr, word[WORD_NIL].ptr, word[WORD_NIL].len); word_index = WORD_NIL;
break; goto print_word;
case HCL_BRAND_TRUE: case HCL_BRAND_TRUE:
OUTPUT_STRX (pr, word[WORD_TRUE].ptr, word[WORD_TRUE].len); word_index = WORD_TRUE;
break; goto print_word;
case HCL_BRAND_FALSE: case HCL_BRAND_FALSE:
OUTPUT_STRX (pr, word[WORD_FALSE].ptr, word[WORD_FALSE].len); word_index = WORD_FALSE;
break; goto print_word;
case HCL_BRAND_INTEGER: case HCL_BRAND_INTEGER:
/* TODO: print properly... print big int */
HCL_ASSERT (hcl, HCL_OBJ_GET_SIZE(obj) == 1); 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; break;
#if 0 #if 0
@ -287,19 +171,93 @@ next:
/* Any needs for special action if SYNT(obj) is true? /* Any needs for special action if SYNT(obj) is true?
* I simply treat the syntax symbol as a normal symbol * I simply treat the syntax symbol as a normal symbol
* for printing currently. */ * 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; break;
case HCL_BRAND_STRING: case HCL_BRAND_STRING:
OUTPUT_CHAR (pr, '\"'); {
/* TODO: deescaping */ hcl_ooch_t ch;
OUTPUT_STRX (pr, ((hcl_oop_char_t)obj)->slot, HCL_OBJ_GET_SIZE(obj)); hcl_oow_t i;
OUTPUT_CHAR (pr, '\"'); 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; 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: case HCL_BRAND_CONS:
{ {
OUTPUT_CHAR (pr, '('); if (outbfmt(hcl, mask, "(") <= -1) return -1;
cur = obj; cur = obj;
do do
@ -332,9 +290,7 @@ next:
if (!HCL_OOP_IS_POINTER(cur) || HCL_OBJ_GET_FLAGS_BRAND(cur) != HCL_BRAND_CONS) if (!HCL_OOP_IS_POINTER(cur) || HCL_OBJ_GET_FLAGS_BRAND(cur) != HCL_BRAND_CONS)
{ {
/* The CDR part does not point to a pair. */ /* The CDR part does not point to a pair. */
OUTPUT_CHAR (pr, ' '); if (outbfmt(hcl, mask, " . ") <= -1) return -1;
OUTPUT_CHAR (pr, '.');
OUTPUT_CHAR (pr, ' ');
/* Push NIL so that the HCL_IS_NIL(hcl,p) test in /* Push NIL so that the HCL_IS_NIL(hcl,p) test in
* the 'if' statement above breaks the loop * the 'if' statement above breaks the loop
@ -351,10 +307,10 @@ next:
} }
/* The CDR part points to a pair. proceed to it */ /* The CDR part points to a pair. proceed to it */
OUTPUT_CHAR (pr, ' '); if (outbfmt(hcl, mask, " ") <= -1) return -1;
} }
while (1); while (1);
OUTPUT_CHAR (pr, ')'); if (outbfmt(hcl, mask, ")") <= -1) return -1;
break; break;
} }
@ -364,20 +320,23 @@ next:
if (brand == HCL_BRAND_ARRAY) if (brand == HCL_BRAND_ARRAY)
{ {
OUTPUT_CHAR (pr, '#'); if (outbfmt(hcl, mask, "#(") <= -1) return -1;
OUTPUT_CHAR (pr, '(');
} }
else else
{ {
OUTPUT_CHAR (pr, '|'); if (outbfmt(hcl, mask, "|") <= -1) return -1;
} }
if (HCL_OBJ_GET_SIZE(obj) <= 0) if (HCL_OBJ_GET_SIZE(obj) <= 0)
{ {
if (brand == HCL_BRAND_ARRAY) if (brand == HCL_BRAND_ARRAY)
OUTPUT_CHAR (pr, ')'); {
if (outbfmt(hcl, mask, ")") <= -1) return -1;
}
else else
OUTPUT_CHAR (pr, '|'); {
if (outbfmt(hcl, mask, "|") <= -1) return -1;
}
break; break;
} }
arridx = 0; arridx = 0;
@ -403,7 +362,10 @@ next:
if (x <= -1) return -1; if (x <= -1) return -1;
obj = ((hcl_oop_oop_t)obj)->slot[arridx]; 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 /* Jump to the 'next' label so that the object
* pointed to by 'obj' is printed. Once it * pointed to by 'obj' is printed. Once it
* ends, a jump back to the 'resume' label * ends, a jump back to the 'resume' label
@ -423,15 +385,13 @@ next:
{ {
hcl_oow_t i; hcl_oow_t i;
OUTPUT_CHAR (pr, '#'); if (outbfmt(hcl, mask, "#[") <= -1) return -1;
OUTPUT_CHAR (pr, '[');
for (i = 0; i < HCL_OBJ_GET_SIZE(obj); i++) for (i = 0; i < HCL_OBJ_GET_SIZE(obj); i++)
{ {
if (i > 0) OUTPUT_CHAR (pr, ' '); if (outbfmt(hcl, mask, "%hs%d", ((i > 0)? " ": ""), ((hcl_oop_byte_t)obj)->slot[i]) <= -1) return -1;
if (print_ooi (pr, ((hcl_oop_byte_t)obj)->slot[i]) <= -1) return -1;
} }
OUTPUT_CHAR (pr, ']'); if (outbfmt(hcl, mask, "]") <= -1) return -1;
break; break;
} }
@ -439,53 +399,56 @@ next:
{ {
hcl_oow_t i; hcl_oow_t i;
OUTPUT_CHAR (pr, '|'); if (outbfmt(hcl, mask, "|") <= -1) return -1;
for (i = 0; i < HCL_OBJ_GET_SIZE(obj); i++) for (i = 0; i < HCL_OBJ_GET_SIZE(obj); i++)
{ {
hcl_oop_t s; hcl_oop_t s;
s = ((hcl_oop_oop_t)obj)->slot[i]; s = ((hcl_oop_oop_t)obj)->slot[i];
OUTPUT_CHAR (pr, ' '); if (outbfmt(hcl, mask, " %.*js", HCL_OBJ_GET_SIZE(s), HCL_OBJ_GET_CHAR_SLOT(s)) <= -1) return -1;
OUTPUT_STRX (pr, ((hcl_oop_char_t)s)->slot, HCL_OBJ_GET_SIZE(s));
} }
OUTPUT_CHAR (pr, ' '); if (outbfmt(hcl, mask, " |") <= -1) return -1;
OUTPUT_CHAR (pr, '|');
break; break;
} }
case HCL_BRAND_SET: case HCL_BRAND_SET:
OUTPUT_STRX (pr, word[WORD_SET].ptr, word[WORD_SET].len); word_index = WORD_SET;
break; goto print_word;
case HCL_BRAND_CFRAME: case HCL_BRAND_CFRAME:
OUTPUT_STRX (pr, word[WORD_CFRAME].ptr, word[WORD_CFRAME].len); word_index = WORD_CFRAME;
break; goto print_word;
case HCL_BRAND_PRIM: case HCL_BRAND_PRIM:
OUTPUT_STRX (pr, word[WORD_PRIM].ptr, word[WORD_PRIM].len); word_index = WORD_PRIM;
break; goto print_word;
case HCL_BRAND_CONTEXT: case HCL_BRAND_CONTEXT:
OUTPUT_STRX (pr, word[WORD_CONTEXT].ptr, word[WORD_CONTEXT].len); word_index = WORD_CONTEXT;
break; goto print_word;
case HCL_BRAND_PROCESS: case HCL_BRAND_PROCESS:
OUTPUT_STRX (pr, word[WORD_PROCESS].ptr, word[WORD_PROCESS].len); word_index = WORD_PROCESS;
break; goto print_word;
case HCL_BRAND_PROCESS_SCHEDULER: case HCL_BRAND_PROCESS_SCHEDULER:
OUTPUT_STRX (pr, word[WORD_PROCESS_SCHEDULER].ptr, word[WORD_PROCESS_SCHEDULER].len); word_index = WORD_PROCESS_SCHEDULER;
break; goto print_word;
case HCL_BRAND_SEMAPHORE: case HCL_BRAND_SEMAPHORE:
OUTPUT_STRX (pr, word[WORD_SEMAPHORE].ptr, word[WORD_SEMAPHORE].len); word_index = WORD_SEMAPHORE;
break; goto print_word;
default: default:
HCL_DEBUG3 (hcl, "Internal error - unknown object type %d at %s:%d\n", (int)brand, __FILE__, __LINE__); 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_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; return -1;
print_word:
if (outbfmt(hcl, mask, "%.*js", word[word_index].len, word[word_index].ptr) <= -1) return -1;
break;
} }
done: done:
@ -502,24 +465,21 @@ done:
goto resume_array; goto resume_array;
case PRINT_STACK_ARRAY_END: case PRINT_STACK_ARRAY_END:
OUTPUT_CHAR (pr, ')'); if (outbfmt(hcl, mask, ")") <= -1) return -1;
break; break;
default: default:
HCL_DEBUG3 (hcl, "Internal error - unknown print stack type %d at %s:%d\n", (int)ps.type, __FILE__, __LINE__); 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 -1;
} }
} }
return 0; return 0;
} }
/* hcl_printobj() is for internal use only. it's called by hcl_print() and a logger. */ int hcl_print (hcl_t* hcl, hcl_oop_t obj)
HCL_INLINE int hcl_printobj (hcl_t* hcl, hcl_oop_t obj, hcl_ioimpl_t printer, hcl_iooutarg_t* outarg)
{ {
int n; int n;
printer_t pr;
HCL_ASSERT (hcl, hcl->c->printer != HCL_NULL); 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_ASSERT (hcl, hcl->p.s.size == 0);
hcl->p.e = obj; /* remember the head of the object to print */ hcl->p.e = obj; /* remember the head of the object to print */
pr.hcl = hcl; n = hcl_outfmtobj (hcl, HCL_LOG_APP | HCL_LOG_FATAL, obj, hcl_proutbfmt);
pr.printer = printer;
pr.outarg = outarg;
n = print_object (&pr, obj); /* call the actual printing routine */
hcl->p.e = hcl->_nil; /* reset what's remembered */ hcl->p.e = hcl->_nil; /* reset what's remembered */
/* clear the printing stack if an error has occurred for GC not to keep /* 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; return n;
} }
int hcl_print (hcl_t* hcl, hcl_oop_t obj)
{
return hcl_printobj (hcl, obj, hcl->c->printer, &hcl->c->outarg);
}