added initial hcl files
This commit is contained in:
467
lib/print.c
Normal file
467
lib/print.c
Normal file
@ -0,0 +1,467 @@
|
||||
/*
|
||||
* $Id$
|
||||
*
|
||||
Copyright (c) 2014-2016 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"
|
||||
|
||||
#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) \
|
||||
{ \
|
||||
(pr)->hcl->errnum = 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
|
||||
#define PRINT_STACK_ARRAY 2
|
||||
|
||||
typedef struct print_stack_t print_stack_t;
|
||||
struct print_stack_t
|
||||
{
|
||||
int type;
|
||||
hcl_oop_t obj;
|
||||
hcl_oow_t idx;
|
||||
};
|
||||
|
||||
static HCL_INLINE int push (hcl_t* hcl, print_stack_t* info)
|
||||
{
|
||||
if (hcl->p.s.size >= hcl->p.s.capa)
|
||||
{
|
||||
print_stack_t* tmp;
|
||||
hcl_oow_t new_capa;
|
||||
|
||||
new_capa = HCL_ALIGN (hcl->p.s.capa + 1, PRINT_STACK_ALIGN);
|
||||
tmp = hcl_reallocmem (hcl, hcl->p.s.ptr, new_capa * HCL_SIZEOF(*info));
|
||||
if (!tmp) return -1;
|
||||
|
||||
hcl->p.s.ptr = tmp;
|
||||
hcl->p.s.capa = new_capa;
|
||||
}
|
||||
|
||||
((print_stack_t*)hcl->p.s.ptr)[hcl->p.s.size] = *info;
|
||||
hcl->p.s.size++;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
static HCL_INLINE void pop (hcl_t* hcl, print_stack_t* info)
|
||||
{
|
||||
HCL_ASSERT (hcl->p.s.size > 0);
|
||||
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;
|
||||
}
|
||||
|
||||
static int print_object (printer_t* pr, hcl_oop_t obj)
|
||||
{
|
||||
hcl_t* hcl;
|
||||
hcl_oop_t cur;
|
||||
print_stack_t ps;
|
||||
|
||||
static struct
|
||||
{
|
||||
hcl_oow_t len;
|
||||
hcl_ooch_t ptr[10];
|
||||
} word[] =
|
||||
{
|
||||
{ 4, { '#','n', 'i', 'l' } },
|
||||
{ 5, { '#','t', 'r', 'u', 'e' } },
|
||||
{ 6, { '#','f', 'a', 'l', 's', 'e' } }
|
||||
};
|
||||
|
||||
hcl = pr->hcl;
|
||||
|
||||
next:
|
||||
if (HCL_OOP_IS_SMOOI(obj))
|
||||
{
|
||||
if (print_ooi (pr, 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;
|
||||
goto done;
|
||||
}
|
||||
|
||||
switch (HCL_OBJ_GET_FLAGS_BRAND(obj))
|
||||
{
|
||||
case HCL_BRAND_NIL:
|
||||
OUTPUT_STRX (pr, word[0].ptr, word[0].len);
|
||||
break;
|
||||
|
||||
case HCL_BRAND_TRUE:
|
||||
OUTPUT_STRX (pr, word[1].ptr, word[1].len);
|
||||
break;
|
||||
|
||||
case HCL_BRAND_FALSE:
|
||||
OUTPUT_STRX (pr, word[2].ptr, word[2].len);
|
||||
break;
|
||||
|
||||
case HCL_BRAND_INTEGER:
|
||||
HCL_ASSERT (HCL_OBJ_GET_SIZE(obj) == 1);
|
||||
if (print_ooi (pr, ((hcl_oop_word_t)obj)->slot[0]) <= -1) return -1;
|
||||
break;
|
||||
|
||||
#if 0
|
||||
case HCL_BRAND_REAL:
|
||||
{
|
||||
qse_char_t buf[256];
|
||||
hcl->prm.sprintf (
|
||||
hcl->prm.ctx,
|
||||
buf, HCL_COUNTOF(buf),
|
||||
HCL_T("%Lf"),
|
||||
#ifdef __MINGW32__
|
||||
(double)HCL_RVAL(obj)
|
||||
#else
|
||||
(long double)HCL_RVAL(obj)
|
||||
#endif
|
||||
);
|
||||
|
||||
OUTPUT_STR (hcl, buf);
|
||||
break;
|
||||
}
|
||||
#endif
|
||||
|
||||
case HCL_BRAND_SYMBOL:
|
||||
/* 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));
|
||||
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, '\"');
|
||||
break;
|
||||
|
||||
case HCL_BRAND_CONS:
|
||||
{
|
||||
OUTPUT_CHAR (pr, '(');
|
||||
cur = obj;
|
||||
|
||||
do
|
||||
{
|
||||
int x;
|
||||
|
||||
/* Push what to print next on to the stack
|
||||
* the variable p is */
|
||||
ps.type = PRINT_STACK_CONS;
|
||||
ps.obj = HCL_CONS_CDR(cur);
|
||||
x = push (hcl, &ps);
|
||||
if (x <= -1) return -1;
|
||||
|
||||
obj = HCL_CONS_CAR(cur);
|
||||
/* 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
|
||||
* is made at the at of this function. */
|
||||
goto next;
|
||||
|
||||
resume_cons:
|
||||
HCL_ASSERT (ps.type == PRINT_STACK_CONS);
|
||||
cur = ps.obj; /* Get back the CDR pushed */
|
||||
if (HCL_IS_NIL(hcl,cur))
|
||||
{
|
||||
/* The CDR part points to a NIL object, which
|
||||
* indicates the end of a list. break the loop */
|
||||
break;
|
||||
}
|
||||
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, ' ');
|
||||
|
||||
/* Push NIL so that the HCL_IS_NIL(hcl,p) test in
|
||||
* the 'if' statement above breaks the loop
|
||||
* after the jump is maded back to the 'resume'
|
||||
* label. */
|
||||
ps.type = PRINT_STACK_CONS;
|
||||
ps.obj = hcl->_nil;
|
||||
x = push (hcl, &ps);
|
||||
if (x <= -1) return -1;
|
||||
|
||||
/* Make a jump to 'next' to print the CDR part */
|
||||
obj = cur;
|
||||
goto next;
|
||||
}
|
||||
|
||||
/* The CDR part points to a pair. proceed to it */
|
||||
OUTPUT_CHAR (pr, ' ');
|
||||
}
|
||||
while (1);
|
||||
OUTPUT_CHAR (pr, ')');
|
||||
break;
|
||||
}
|
||||
|
||||
case HCL_BRAND_ARRAY:
|
||||
{
|
||||
hcl_oow_t arridx;
|
||||
|
||||
OUTPUT_CHAR (pr, '#');
|
||||
OUTPUT_CHAR (pr, '(');
|
||||
|
||||
if (HCL_OBJ_GET_SIZE(obj) <= 0) goto done_array;
|
||||
arridx = 0;
|
||||
|
||||
do
|
||||
{
|
||||
int x;
|
||||
|
||||
/* Push what to print next on to the stack
|
||||
* the variable p is */
|
||||
ps.idx = arridx + 1;
|
||||
if (ps.idx >= HCL_OBJ_GET_SIZE(obj))
|
||||
{
|
||||
ps.type = PRINT_STACK_ARRAY_END;
|
||||
}
|
||||
else
|
||||
{
|
||||
ps.type = PRINT_STACK_ARRAY;
|
||||
ps.obj = obj;
|
||||
}
|
||||
|
||||
x = push (hcl, &ps);
|
||||
if (x <= -1) return -1;
|
||||
|
||||
obj = ((hcl_oop_oop_t)obj)->slot[arridx];
|
||||
if (arridx > 0) OUTPUT_CHAR (pr, ' ');
|
||||
/* 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
|
||||
* is made at the at of this function. */
|
||||
goto next;
|
||||
|
||||
resume_array:
|
||||
HCL_ASSERT (ps.type == PRINT_STACK_ARRAY);
|
||||
arridx = ps.idx;
|
||||
obj = ps.obj;
|
||||
}
|
||||
while (1);
|
||||
|
||||
done_array:
|
||||
OUTPUT_CHAR (pr, ')');
|
||||
break;
|
||||
}
|
||||
|
||||
case HCL_BRAND_BYTE_ARRAY:
|
||||
{
|
||||
hcl_oow_t i;
|
||||
|
||||
OUTPUT_CHAR (pr, '#');
|
||||
OUTPUT_CHAR (pr, '[');
|
||||
|
||||
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;
|
||||
}
|
||||
OUTPUT_CHAR (pr, ']');
|
||||
break;
|
||||
}
|
||||
|
||||
#if 0
|
||||
case HCL_BRAND_PROCEDURE:
|
||||
OUTPUT_STR (pr, "#<PROCEDURE>");
|
||||
break;
|
||||
|
||||
case HCL_BRAND_CLOSURE:
|
||||
OUTPUT_STR (pr, "#<CLOSURE>");
|
||||
break;
|
||||
#endif
|
||||
|
||||
default:
|
||||
HCL_ASSERT ("Unknown object type" == HCL_NULL);
|
||||
HCL_DEBUG2 (hcl, "Internal error - unknown object type at %s:%d\n", __FILE__, __LINE__);
|
||||
hcl->errnum = HCL_EINTERN;
|
||||
return -1;
|
||||
}
|
||||
|
||||
done:
|
||||
/* if the printing stack is not empty, we still got more to print */
|
||||
while (hcl->p.s.size > 0)
|
||||
{
|
||||
pop (hcl, &ps);
|
||||
if (ps.type == PRINT_STACK_CONS) goto resume_cons;
|
||||
else if (ps.type == PRINT_STACK_ARRAY) goto resume_array;
|
||||
else
|
||||
{
|
||||
HCL_ASSERT (ps.type == PRINT_STACK_ARRAY_END);
|
||||
OUTPUT_CHAR (pr, ')');
|
||||
}
|
||||
}
|
||||
|
||||
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 n;
|
||||
printer_t pr;
|
||||
|
||||
HCL_ASSERT (hcl->c->printer != HCL_NULL);
|
||||
|
||||
/* the printer stack must be empty. buggy if not. */
|
||||
HCL_ASSERT (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 */
|
||||
hcl->p.e = hcl->_nil; /* reset what's remembered */
|
||||
|
||||
/* clear the printing stack if an error has occurred for GC not to keep
|
||||
* the objects in the stack */
|
||||
if (n <= -1) hcl->p.s.size = 0;
|
||||
|
||||
/* the printer stack must get empty when done. buggy if not */
|
||||
HCL_ASSERT (hcl->p.s.size == 0);
|
||||
|
||||
return n;
|
||||
}
|
||||
|
||||
int hcl_print (hcl_t* hcl, hcl_oop_t obj)
|
||||
{
|
||||
return hcl_printobj (hcl, obj, hcl->c->printer, &hcl->c->outarg);
|
||||
}
|
||||
Reference in New Issue
Block a user