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

writing code exchange functions
Some checks failed
continuous-integration/drone/push Build is failing
Details

Browse Source
This commit is contained in:
hyung-hwan
2023-12-27 09:09:40 +09:00
parent 58d913e3da
commit ce4c583773
7 changed files with 475 additions and 341 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
lib/comp.c
View File

@ -505,14 +505,14 @@ static int add_literal (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t* index)
if (tmp == obj)
{
/* this removes redundancy of symbols, characters, and integers. */
*index = i - lfbase;
if (index) *index = i - lfbase;
return 0;
}
else if (HCL_IS_STRING(hcl, obj) && HCL_IS_STRING(hcl, tmp) && hcl_equalobjs(hcl, obj, tmp))
{
/* a string object requires equality check. however, the string created to the literal frame
* must be made immutable. non-immutable string literals are source of various problems */
*index = i - lfbase;
if (index) *index = i - lfbase;
return 0;
}
}
@ -530,7 +530,7 @@ static int add_literal (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t* index)
hcl->code.lit.arr = (hcl_oop_oop_t)tmp;
}
*index = hcl->code.lit.len - lfbase;
if (index) *index = hcl->code.lit.len - lfbase;
((hcl_oop_oop_t)hcl->code.lit.arr)->slot[hcl->code.lit.len++] = obj;
/* TODO: RDONLY? */

17
lib/decode.c
View File

@ -49,7 +49,7 @@
#endif
/* TODO: check if ip shoots beyond the maximum length in fetching code and parameters */
int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
int hcl_decode (hcl_t* hcl, const hcl_code_t* code, hcl_oow_t start, hcl_oow_t end)
{
hcl_oob_t bcode, * cdptr;
hcl_ooi_t ip = start, fetched_instruction_pointer;
@ -58,18 +58,19 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
/* the instruction at the offset 'end' is not decoded.
* decoding offset range is from start to end - 1. */
HCL_ASSERT (hcl, start >= 0 && end >= 0);
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); /* asserted by the compiler */
HCL_ASSERT (hcl, end <= hcl->code.bc.len); /* not harmful though this fails */
if (start >= hcl->code.bc.len)
HCL_ASSERT (hcl, code->bc.len < HCL_SMOOI_MAX); /* asserted by the compiler */
HCL_ASSERT (hcl, end <= code->bc.len); /* not harmful though this fails */
if (start >= code->bc.len)
{
hcl_seterrnum (hcl, HCL_EINVAL);
return -1;
}
if (end > hcl->code.bc.len) end = hcl->code.bc.len;
if (end > code->bc.len) end = code->bc.len;
ip = start;
cdptr = hcl->code.bc.ptr;
cdptr = code->bc.ptr;
/* TODO: check if ip increases beyond bcode when fetching parameters too */
while (ip < end)
@ -742,9 +743,9 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
/* TODO: this needs changes... */
/* print literal frame contents */
for (ip = 0; ip < hcl->code.lit.len; ip++)
for (ip = 0; ip < code->lit.len; ip++)
{
HCL_LOG2(hcl, DECODE_LOG_MASK, "@%-9zd %O\n", ip, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[ip]);
HCL_LOG2(hcl, DECODE_LOG_MASK, "@%-9zd %O\n", ip, ((hcl_oop_oop_t)code->lit.arr)->slot[ip]);
}
return 0;

4
lib/hcl-prv.h
View File

@ -1776,11 +1776,9 @@ hcl_pfrc_t hcl_pf_semaphore_group_add_semaphore (hcl_t* hcl, hcl_mod_t* mod, hcl
hcl_pfrc_t hcl_pf_semaphore_group_remove_semaphore (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs);
hcl_pfrc_t hcl_pf_semaphore_group_wait (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs);
#if defined(__cplusplus)
}
#endif
#endif

44
lib/hcl.h
View File

@ -1953,6 +1953,21 @@ typedef int (*hcl_dic_walker_t) (
void* ctx
);
typedef int (*hcl_xchg_reader_t) (
hcl_t* hcl,
void* buf,
hcl_oow_t len,
void* ctx
);
typedef int (*hcl_xchg_writer_t) (
hcl_t* hcl,
const void* ptr,
hcl_oow_t len,
void* ctx
);
#if defined(__cplusplus)
extern "C" {
#endif
@ -2348,17 +2363,22 @@ HCL_EXPORT int hcl_compile (
* in the textual form.
*/
HCL_EXPORT int hcl_decode (
hcl_t* hcl,
hcl_oow_t start,
hcl_oow_t end
hcl_t* hcl,
const hcl_code_t* code,
hcl_oow_t start,
hcl_oow_t end
);
#if defined(HCL_HAVE_INLINE)
static HCL_INLINE hcl_code_t* hcl_getcode (hcl_t* hcl) { return &hcl->code; }
static HCL_INLINE hcl_oob_t* hcl_getbcptr (hcl_t* hcl) { return hcl->code.bc.ptr; }
static HCL_INLINE hcl_oow_t hcl_getbclen (hcl_t* hcl) { return hcl->code.bc.len; }
static HCL_INLINE hcl_oow_t hcl_getlflen (hcl_t* hcl) { return hcl->code.lit.len; }
static HCL_INLINE hcl_oow_t hcl_getngtmprs (hcl_t* hcl) { return hcl->code.ngtmprs; }
static HCL_INLINE hcl_ooi_t hcl_getip (hcl_t* hcl) { return hcl->ip; }
#else
# define hcl_getcode(hcl) (&(hcl)->code)
# define hcl_getbcptr(hcl) ((hcl)->code.bc.ptr)
# define hcl_getbclen(hcl) ((hcl)->code.bc.len)
# define hcl_getlflen(hcl) ((hcl)->code.lit.len)
# define hcl_getngtmprs(hcl) ((hcl)->code.ngtmprs)
@ -2762,6 +2782,24 @@ HCL_EXPORT hcl_oop_t hcl_reversecons (
hcl_oop_t cons
);
/* =========================================================================
* CODE MARSHALING/UNMARSHALING
* ========================================================================= */
HCL_EXPORT int hcl_marshalcode (
hcl_t* hcl,
const hcl_code_t* code,
hcl_xchg_writer_t wrtr,
void* ctx
);
int hcl_unmarshalcode (
hcl_t* hcl,
hcl_code_t* code,
hcl_xchg_reader_t rdr,
void* ctx
);
/* =========================================================================
* DICTIONARY ACCESS FUNCTIONS
* ========================================================================= */

689
lib/xchg.c
View File

@ -27,282 +27,38 @@
/* compiler's literal representation */
#include <hcl-pac1.h>
struct hcl_clit_hdr_t
struct hcl_xchg_hdr_t
{
hcl_uint8_t ver;
hcl_uint8_t oow_size;
};
typedef struct hcl_clit_hdr_t hcl_clit_hdr_t;
typedef struct hcl_xchg_hdr_t hcl_xchg_hdr_t;
#include <hcl-upac.h>
enum hcl_clit_type_t
enum hcl_xchg_type_t
{
HCL_CLIT_STRING = 0x00,
HCL_CLIT_SYMBOL, /* contained in a cons cell */
HCL_CLIT_PBIGINT,
HCL_CLIT_NBIGINT,
HCL_CLIT_FPDEC_1, /* smooi + smooi */
HCL_CLIT_FPDEC_2, /* pbigint + smooi */
HCL_CLIT_FPDEC_3, /* nbigint + smooi */
HCL_CLIT_PRIM,
/* byte code */
HCL_XCHG_BC = 0x00,
HCL_CLIT_END =0xFF /* end marker. not a real literal type */
/* literals */
HCL_XCHG_STRING_U,
HCL_XCHG_STRING_B,
HCL_XCHG_SYMBOL_U, /* contained in a cons cell */
HCL_XCHG_SYMBOL_B, /* contained in a cons cell */
HCL_XCHG_PBIGINT,
HCL_XCHG_NBIGINT,
HCL_XCHG_FPDEC_1, /* smooi + smooi */
HCL_XCHG_FPDEC_2, /* pbigint + smooi */
HCL_XCHG_FPDEC_3, /* nbigint + smooi */
HCL_XCHG_PRIM,
/* end marker */
HCL_XCHG_END =0xFF /* end marker. not a real literal type */
};
typedef enum hcl_clit_type_t hcl_clit_type_t;
#define HCL_CLIT_HEADER \
hcl_oow_t _type: 3; \
hcl_oow_t _size: (HCL_OOW_BITS - 3)
#define HCL_CLIT_SIZE_MAX ((((hcl_oow_t)1) << 3) >> 3)
/* TODO: should clit be chained? these fields in the header?
hcl_clit_t* _prev;
hcl_clit_t* _next
*/
struct hcl_clit_t
{
HCL_CLIT_HEADER;
};
typedef struct hcl_clit_t hcl_clit_t;
/*
struct hcl_clit_string_t
{
HCL_CLIT_HEADER;
};
typedef struct hcl_clit_string_t hcl_clit_string_t;
struct hcl_clit_symbol_t
{
HCL_CLIT_HEADER;
};
typedef struct hcl_clit_symbol_t hcl_clit_symbol_t;
*/
struct hcl_clit_fpdec_t
{
HCL_CLIT_HEADER;
#if 0
hcl_oop_t value; /* smooi or bigint */
hcl_oop_t scale; /* smooi, positiv
#else
/* TODO: how to represent value?? */
hcl_ooi_t scale;
#endif
};
typedef struct hcl_clit_fpdec_t hcl_clit_fpdec_t;
struct hcl_clit_prim_t
{
HCL_CLIT_HEADER;
};
typedef struct hcl_clit_prim_t hcl_clit_prim_t;
static hcl_clit_t* alloc_clit (hcl_t* hcl, hcl_clit_type_t type, const void* data, hcl_oow_t size)
{
hcl_clit_t* clit;
if (size > HCL_CLIT_SIZE_MAX)
{
hcl_seterrnum (hcl, HCL_EINVAL); /* TODO: more specific error messagae... */
return HCL_NULL;
}
clit = (hcl_clit_t*)hcl_allocmem(hcl, HCL_SIZEOF(*clit) + size);
if (HCL_UNLIKELY(!clit)) return HCL_NULL;
clit->_type = type;
clit->_size = size;
if (size > 0 && data) HCL_MEMCPY (clit + 1, data, size);
/* if size is greater than 0 and data is HCL_NULL, the allocated space is left uninitialized */
return clit;
}
hcl_clit_t* hcl_makestringclit (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len)
{
return alloc_clit(hcl, HCL_CLIT_STRING, ptr, len * HCL_SIZEOF(*ptr));
}
hcl_clit_t* hcl_makesymbolclit (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len)
{
return alloc_clit(hcl, HCL_CLIT_SYMBOL, ptr, len * HCL_SIZEOF(*ptr));
}
hcl_clit_t* hcl_makefpdecclit (hcl_t* hcl)
{
hcl_clit_fpdec_t* fpdec;
fpdec = (hcl_clit_fpdec_t*)alloc_clit(hcl, HCL_CLIT_FPDEC_1, HCL_NULL, HCL_SIZEOF(*fpdec) - HCL_SIZEOF(hcl_clit_t));
if (HCL_UNLIKELY(!fpdec)) return HCL_NULL;
//fpdec-> = argss;
return (hcl_clit_t*)fpdec;
}
hcl_clit_t* hcl_makeprimclit (hcl_t* hcl)
{
hcl_clit_prim_t* prim;
prim = (hcl_clit_prim_t*)alloc_clit(hcl, HCL_CLIT_PRIM, HCL_NULL, HCL_SIZEOF(*prim) - HCL_SIZEOF(hcl_clit_t));
if (HCL_UNLIKELY(!prim)) return HCL_NULL;
//prim-> = argss;
return (hcl_clit_t*)prim;
}
void hcl_freeclit (hcl_t* hcl, hcl_clit_t* clit)
{
hcl_freemem(hcl, clit);
}
#if 0
static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, int brand, const void* ptr, hcl_oow_t len, hcl_obj_type_t type, hcl_oow_t unit, int extra, int ngc)
{
/* allocate a variable object */
hcl_oop_t hdr;
hcl_oow_t xbytes, nbytes, nbytes_aligned;
xbytes = len * unit;
/* 'extra' indicates an extra unit to append at the end.
* it's useful to store a string with a terminating null */
nbytes = extra? xbytes + unit: xbytes;
nbytes_aligned = HCL_ALIGN(nbytes, HCL_SIZEOF(hcl_oop_t));
/* TODO: check overflow in size calculation*/
/* making the number of bytes to allocate a multiple of
* HCL_SIZEOF(hcl_oop_t) will guarantee the starting address
* of the allocated space to be an even number.
* see HCL_OOP_IS_NUMERIC() and HCL_OOP_IS_POINTER() */
if (HCL_UNLIKELY(ngc))
hdr = (hcl_oop_t)hcl_callocmem(hcl, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned);
else
hdr = (hcl_oop_t)hcl_allocbytes(hcl, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned);
if (HCL_UNLIKELY(!hdr)) return HCL_NULL;
hdr->_flags = HCL_OBJ_MAKE_FLAGS(type, unit, extra, 0, 0, ngc, 0, 0);
hdr->_size = len;
HCL_OBJ_SET_SIZE (hdr, len);
/*HCL_OBJ_SET_CLASS (hdr, hcl->_nil);*/
HCL_OBJ_SET_FLAGS_BRAND (hdr, brand);
if (ptr)
{
/* copy data */
HCL_MEMCPY (hdr + 1, ptr, xbytes);
HCL_MEMSET ((hcl_uint8_t*)(hdr + 1) + xbytes, 0, nbytes_aligned - xbytes);
}
else
{
/* initialize with zeros when the string pointer is not given */
HCL_MEMSET ((hdr + 1), 0, nbytes_aligned);
}
return hdr;
}
hcl_oop_t hcl_alloccharobj (hcl_t* hcl, int brand, const hcl_ooch_t* ptr, hcl_oow_t len)
{
return alloc_numeric_array(hcl, brand, ptr, len, HCL_OBJ_TYPE_CHAR, HCL_SIZEOF(hcl_ooch_t), 1, 0);
}
hcl_oop_t hcl_allocbyteobj (hcl_t* hcl, int brand, const hcl_oob_t* ptr, hcl_oow_t len)
{
return alloc_numeric_array(hcl, brand, ptr, len, HCL_OBJ_TYPE_BYTE, HCL_SIZEOF(hcl_oob_t), 0, 0);
}
hcl_oop_t hcl_allochalfwordobj (hcl_t* hcl, int brand, const hcl_oohw_t* ptr, hcl_oow_t len)
{
return alloc_numeric_array(hcl, brand, ptr, len, HCL_OBJ_TYPE_HALFWORD, HCL_SIZEOF(hcl_oohw_t), 0, 0);
}
hcl_oop_t hcl_allocwordobj (hcl_t* hcl, int brand, const hcl_oow_t* ptr, hcl_oow_t len)
{
return alloc_numeric_array(hcl, brand, ptr, len, HCL_OBJ_TYPE_WORD, HCL_SIZEOF(hcl_oow_t), 0, 0);
}
#endif
#if 0
static int add_literal (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t* index)
{
hcl_oow_t capa, i, lfbase = 0;
hcl_oop_t tmp;
lfbase = (hcl->option.trait & HCL_TRAIT_INTERACTIVE)? hcl->c->fnblk.info[hcl->c->fnblk.depth].lfbase: 0;
/* TODO: speed up the following duplicate check loop */
for (i = lfbase; i < hcl->code.lit.len; i++)
{
tmp = ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i];
if (tmp == obj)
{
/* this removes redundancy of symbols, characters, and integers. */
*index = i - lfbase;
return 0;
}
else if (HCL_IS_STRING(hcl, obj) && HCL_IS_STRING(hcl, tmp) && hcl_equalobjs(hcl, obj, tmp))
{
/* a string object requires equality check. however, the string created to the literal frame
* must be made immutable. non-immutable string literals are source of various problems */
*index = i - lfbase;
return 0;
}
}
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 (HCL_UNLIKELY(!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;
/* TODO: RDONLY? */
/*if (HCL_IS_OOP_POINTER(obj)) HCL_OBJ_SET_FLAGS_RDONLY(obj, 1); */
return 0;
}
#endif
typedef enum hcl_xchg_type_t hcl_xchg_type_t;
struct hcl_clit_frame_t
{
int x;
};
typedef struct hcl_clit_frame_t hcl_clit_frame_t;
/*
* B(1) | LEN(8) | DATA |
* DATA is B-specific.
*/
typedef int (*hcl_clit_reader_t) (
hcl_t* hcl,
void* buf,
hcl_oow_t* len,
void* ctx
);
typedef int (*hcl_clit_writer_t) (
hcl_t* hcl,
const void* ptr,
hcl_oow_t len,
void* ctx
);
int hcl_writeclits (hcl_t* hcl, hcl_clit_writer_t wrtr, void* ctx)
int hcl_marshalcode (hcl_t* hcl, const hcl_code_t* code, hcl_xchg_writer_t wrtr, void* ctx)
{
hcl_oow_t i, lfbase = 0;
hcl_oop_t tmp;
@ -310,7 +66,7 @@ int hcl_writeclits (hcl_t* hcl, hcl_clit_writer_t wrtr, void* ctx)
hcl_oow_t tsize;
hcl_uint8_t b;
hcl_oow_t w;
hcl_clit_hdr_t h;
hcl_xchg_hdr_t h;
lfbase = (hcl->option.trait & HCL_TRAIT_INTERACTIVE)? hcl->c->fnblk.info[hcl->c->fnblk.depth].lfbase: 0;
@ -319,10 +75,17 @@ int hcl_writeclits (hcl_t* hcl, hcl_clit_writer_t wrtr, void* ctx)
h.oow_size = (hcl_uint8_t)HCL_SIZEOF(hcl_oow_t); /* the size must not exceed 256 */
if (wrtr(hcl, &h, HCL_SIZEOF(h), ctx) <= -1) goto oops;
/* write the byte-code */
b = HCL_XCHG_BC;
if (wrtr(hcl, &b, HCL_SIZEOF(b), ctx) <= -1) goto oops;
w = hcl_htoleoow(code->bc.len);
if (wrtr(hcl, &w, HCL_SIZEOF(w), ctx) <= -1) goto oops;
if (wrtr(hcl, code->bc.ptr, code->bc.len, ctx) <= -1) goto oops;
/* write actual literals */
for (i = lfbase; i < hcl->code.lit.len; i++)
for (i = lfbase; i < code->lit.len; i++)
{
tmp = ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i];
tmp = ((hcl_oop_oop_t)code->lit.arr)->slot[i];
brand = HCL_OBJ_GET_FLAGS_BRAND(tmp);
tsize = HCL_OBJ_GET_SIZE(tmp);
@ -336,9 +99,10 @@ int hcl_writeclits (hcl_t* hcl, hcl_clit_writer_t wrtr, void* ctx)
hcl_liw_t liw;
/* write the brand */
b = (brand == HCL_BRAND_PBIGINT ? HCL_CLIT_PBIGINT : HCL_CLIT_NBIGINT);
if (wrtr(hcl, &b, 1, ctx) <= -1) goto oops;
b = (brand == HCL_BRAND_PBIGINT ? HCL_XCHG_PBIGINT : HCL_XCHG_NBIGINT);
if (wrtr(hcl, &b, HCL_SIZEOF(b), ctx) <= -1) goto oops;
bigint_body:
/* write the number of bytes in the little-endian */
nbytes = tsize * HCL_SIZEOF(hcl_liw_t);
w = hcl_htoleoow(nbytes);
@ -353,11 +117,53 @@ int hcl_writeclits (hcl_t* hcl, hcl_clit_writer_t wrtr, void* ctx)
break;
}
case HCL_BRAND_FPDEC:
{
hcl_oop_fpdec_t f;
f = (hcl_oop_fpdec_t)tmp;
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(f->scale));
HCL_ASSERT(hcl, HCL_OOP_IS_SMOOI(f->value) || HCL_OOP_IS_POINTER(f->value));
/* write 1-byte brand */
if (HCL_OOP_IS_SMOOI(f->value)) b = HCL_XCHG_FPDEC_1;
else if (HCL_IS_PBIGINT(hcl, f->value)) b = HCL_XCHG_FPDEC_2;
else
{
HCL_ASSERT(hcl, HCL_IS_NBIGINT(hcl, f->value));
b = HCL_XCHG_FPDEC_2;
}
if (wrtr(hcl, &b, HCL_SIZEOF(b), ctx) <= -1) goto oops;
/* cast the scale part from hcl_ooi_t to hcl_oow_t and write it */
w = hcl_htoleoow((hcl_oow_t)HCL_OOP_TO_SMOOI(f->scale));
if (wrtr(hcl, &w, HCL_SIZEOF(w), ctx) <= -1) goto oops;
/* write the value part */
if (b == HCL_XCHG_FPDEC_1)
{
w = hcl_htoleoow((hcl_oow_t)HCL_OOP_TO_SMOOI(f->value));
if (wrtr(hcl, &w, HCL_SIZEOF(w), ctx) <= -1) goto oops;
}
else
{
tmp = f->value;
brand = HCL_OBJ_GET_FLAGS_BRAND(tmp);
tsize = HCL_OBJ_GET_SIZE(tmp);
goto bigint_body;
}
break;
}
case HCL_BRAND_CONS:
{
/* write 1-byte brand */
b = (hcl_uint8_t)HCL_CLIT_SYMBOL;
if (wrtr(hcl, &b, 1, ctx) <= -1) goto oops;
#if defined(HCL_OOCH_IS_UCH)
b = (hcl_uint8_t)HCL_XCHG_SYMBOL_U;
#else
b = (hcl_uint8_t)HCL_XCHG_SYMBOL_B;
#endif
if (wrtr(hcl, &b, HCL_SIZEOF(b), ctx) <= -1) goto oops;
/* get the symbol at CAR and make it as if it is the current object processed.*/
tmp = HCL_CONS_CAR(tmp);
@ -368,34 +174,6 @@ int hcl_writeclits (hcl_t* hcl, hcl_clit_writer_t wrtr, void* ctx)
goto string_body;
}
case HCL_BRAND_FPDEC:
{
hcl_oop_fpdec_t f;
f = (hcl_oop_fpdec_t)tmp;
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(f->scale));
HCL_ASSERT(hcl, HCL_OOP_IS_SMOOI(f->value) || HCL_OOP_IS_POINTER(f->value));
/* write 1-byte brand */
if (HCL_OOP_IS_SMOOI(f->value)) b = HCL_CLIT_FPDEC_1;
else if (HCL_IS_PBIGINT(hcl, f->value)) b = HCL_CLIT_FPDEC_2;
else
{
HCL_ASSERT(hcl, HCL_IS_NBIGINT(hcl, f->value));
b = HCL_CLIT_FPDEC_2;
}
if (wrtr(hcl, &b, 1, ctx) <= -1) goto oops;
/* cast the scale part from hcl_ooi_t to hcl_oow_t */
w = hcl_htoleoow((hcl_oow_t)f->scale);
if (wrtr(hcl, &w, HCL_SIZEOF(w), ctx) <= -1) goto oops;
/* TODO: write the value part */
break;
}
case HCL_BRAND_STRING:
{
#if defined(HCL_OOCH_IS_UCH)
@ -406,15 +184,20 @@ int hcl_writeclits (hcl_t* hcl, hcl_clit_writer_t wrtr, void* ctx)
int n;
/* write 1-byte brand */
b = (hcl_uint8_t)HCL_CLIT_STRING;
if (wrtr(hcl, &b, 1, ctx) <= -1) goto oops;
b = (hcl_uint8_t)HCL_XCHG_STRING_U;
if (wrtr(hcl, &b, HCL_SIZEOF(b), ctx) <= -1) goto oops;
string_body:
ucsptr = HCL_OBJ_GET_CHAR_SLOT(tmp);
ucslen = tsize;
if (hcl_convutobchars(hcl, ucsptr, &ucslen, HCL_NULL, &bcslen) <= -1) goto oops;
/* write the number of bytes in the little-endian */
HCL_DEBUG2(hcl, "WRITIGN nbytes %d nchars %d\n", (int)tsize, (int)bcslen);
/* write the number of characters in the little endian */
w = hcl_htoleoow(tsize);
if (wrtr(hcl, &w, HCL_SIZEOF(w), ctx) <= -1) goto oops;
/* write the number of bytes in the little endian */
w = hcl_htoleoow(bcslen);
if (wrtr(hcl, &w, HCL_SIZEOF(w), ctx) <= -1) goto oops;
@ -430,55 +213,317 @@ int hcl_writeclits (hcl_t* hcl, hcl_clit_writer_t wrtr, void* ctx)
ucspos += ucslen;
}
#else
/* write 1-byte brand */
b = (hcl_uint8_t)HCL_XCHG_BSTRING;
if (wrtr(hcl, &b, HCL_SIZEOF(b), ctx) <= -1) goto oops;
string_body:
w = hcl_htoleoow(tsize);
if (wrtr(hcl, &w, HCL_SIZEOF(w), ctx) <= -1) goto oops;
if (wrtr(hcl, HCL_OBJ_GET_CHAR_SLOT(tmp), tsize, ctx) <= -1) goto oops;
#endif
break;
}
case HCL_BRAND_PRIM:
/* TODO: can't have resolved pointer... need module name and the functio name??? */
break;
}
}
b = HCL_CLIT_END;
if (wrtr(hcl, &b, 1, ctx) <= -1) goto oops;
b = HCL_XCHG_END;
if (wrtr(hcl, &b, HCL_SIZEOF(b), ctx) <= -1) goto oops;
return 0;
oops:
return -1;
}
int hcl_restoreclits(hcl_t* hcl, hcl_clit_reader_t rdr, void* ctx)
static void set_rdr_ioerr (hcl_t* hcl, const hcl_bch_t* msg)
{
const hcl_ooch_t* orgmsg = hcl_backuperrmsg(hcl);
hcl_seterrbfmt(hcl, HCL_EIOERR, "%hs - %js", orgmsg);
}
int hcl_unmarshalcode (hcl_t* hcl, hcl_code_t* code, hcl_xchg_reader_t rdr, void* ctx)
{
int n;
hcl_uint8_t buf[128];
hcl_oow_t len, i;
hcl_xchg_hdr_t h;
hcl_uint8_t b;
hcl_oow_t w;
/* [NOTE]
* this function may pollute the code data when it fails because it doesn't
* roll back changed made to the memory pointed to by 'code'. the caller side
* may use two code structs. and switch between them for each call to hcl_unmarshalcode()
* to avoid this issue.
*/
//TODO: code->lit.len = 0; or lfbase??/
n = rdr(hcl, &h, HCL_SIZEOF(h), ctx);
if (n <= -1)
{
set_rdr_ioerr(hcl, "erroneous or insufficient header");
goto oops;
}
if (h.ver != 1)
{
hcl_seterrbfmt(hcl, HCL_EIOERR, "unsupported header version %d", (int)h.ver);
goto oops;
}
if (h.oow_size != HCL_SIZEOF(hcl_oow_t))
{
/* no support for cross-architecture exchange yet */
hcl_seterrbfmt(hcl, HCL_EIOERR, "unsupported word size %d", (int)h.oow_size);
goto oops;
}
while (1)
{
len = HCL_COUNTOF(buf);
n = rdr(hcl, buf, &len, ctx);
if (n <= -1) goto oops;
if (n == 0) break;
for (i = 0; i < len; i++)
/* read 1-byte brand */
n = rdr(hcl, &b, HCL_SIZEOF(b), ctx);
if (n <= -1)
{
switch (buf[i])
set_rdr_ioerr(hcl, "erroneous or insufficient record type");
goto oops;
}
if (b == HCL_XCHG_END) break;
HCL_DEBUG1(hcl, "bbbbbbbbbbb=>%d\n", b);
switch (b)
{
case HCL_XCHG_BC:
{
case HCL_BRAND_PBIGINT:
case HCL_BRAND_NBIGINT:
break;
case HCL_BRAND_STRING:
break;
hcl_oow_t nbytes;
/* this must appear only once but never mind about multiple occurrences */
n = rdr(hcl, &w, HCL_SIZEOF(w), ctx);
if (n <= -1)
{
set_rdr_ioerr(hcl, "erroneous or insufficient record length");
goto oops;
}
nbytes = hcl_leoowtoh(w);
if (nbytes > code->bc.capa)
{
/* grow the buffer */
hcl_oow_t newcapa;
hcl_oob_t* newptr;
newcapa = nbytes;
if (HCL_UNLIKELY(newcapa <= 0)) newcapa++;
newcapa = HCL_ALIGN(newcapa, HCL_BC_BUFFER_ALIGN);
newptr = hcl_reallocmem(hcl, code->bc.ptr, newcapa);
if (!newptr) goto oops;
code->bc.ptr = newptr;
code->bc.capa = newcapa;
}
n = rdr(hcl, code->bc.ptr, nbytes, ctx);
if (n <= -1) goto oops;
code->bc.len = nbytes;
break;
}
case HCL_XCHG_STRING_U:
case HCL_XCHG_SYMBOL_U:
{
hcl_bch_t bcsbuf[64];
hcl_oow_t bcslen, bcsres, ucslen, ucspos;
hcl_oow_t nbytes, nchars;
hcl_oop_t ns;
n = rdr(hcl, &w, HCL_SIZEOF(w), ctx);
if (n <= -1)
{
set_rdr_ioerr(hcl, "erroneous or insufficient record length");
goto oops;
}
nchars = hcl_leoowtoh(w);
n = rdr(hcl, &w, HCL_SIZEOF(w), ctx);
if (n <= -1)
{
set_rdr_ioerr(hcl, "erroneous or insufficient record length");
goto oops;
}
nbytes = hcl_leoowtoh(w);
HCL_DEBUG2(hcl, "nchars %d nbytes %d\n", (int)nchars, (int)nbytes);
ns = hcl_makestring(hcl, HCL_NULL, nchars, 0);
if (HCL_UNLIKELY(!ns)) goto oops;
HCL_DEBUG2(hcl, "222 nchars %d nbytes %d\n", (int)nchars, (int)nbytes);
ucspos = 0;
bcsres = 0;
while (nbytes > 0)
{
bcslen = nbytes <= HCL_SIZEOF(bcsbuf)? nbytes : HCL_SIZEOF(bcsbuf);
HCL_DEBUG4(hcl, "333 nchars %d nbytes %d bcsres %d bcslen - bcsres %d\n", (int)nchars, (int)nbytes, (int)bcsres, (int)bcslen - bcsres);
n = rdr(hcl, &bcsbuf[bcsres], bcslen - bcsres, ctx);
if (n <= -1)
{
set_rdr_ioerr(hcl, "erroneous or insufficient record data");
goto oops;
}
HCL_DEBUG4(hcl, "333 nchars %d nbytes %d bcslen %d ucslen %d\n", (int)nchars, (int)nbytes, (int)bcslen, (int)ucslen);
HCL_ASSERT(hcl, ucspos < nchars);
bcsres = bcslen;
ucslen = nchars - ucspos;
if (hcl_convbtouchars(hcl, bcsbuf, &bcslen, HCL_OBJ_GET_CHAR_PTR(ns, ucspos), &ucslen) <= -1 && bcslen <= 0)
{
HCL_DEBUG0(hcl, "EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE\n");
goto oops;
}
ucspos += ucslen;
nbytes -= bcslen;
bcsres -= bcslen;
if (bcsres > 0) HCL_MEMMOVE(bcsbuf, &bcsbuf[bcslen], bcsres);
HCL_DEBUG3(hcl, "444 nchars %d nbytes %d bcslen %d\n", (int)nchars, (int)nbytes, (int)bcslen);
}
HCL_ASSERT(hcl, ucspos == nchars);
HCL_DEBUG1(hcl, "RESTORED=>[[%js]]\n", HCL_OBJ_GET_CHAR_SLOT(ns));
if (b == HCL_XCHG_SYMBOL_U)
{
/* form a cons cell */
hcl_oop_t nc;
hcl_pushvolat(hcl, &ns);
nc = hcl_makecons(hcl, ns, hcl->_nil);
hcl_popvolat(hcl);
ns = nc;
}
/* TODO: set ns to the internal literal frame... */
/* TODO: ... add_literal(hcl, code, ns, &) */
break;
}
case HCL_XCHG_STRING_B:
case HCL_XCHG_SYMBOL_B:
/* TODO */
break;
case HCL_XCHG_PBIGINT:
case HCL_XCHG_NBIGINT:
{
hcl_oow_t nbytes, nwords, j;
hcl_liw_t liw;
hcl_oop_t ns;
n = rdr(hcl, &w, HCL_SIZEOF(w), ctx);
if (n <= -1)
{
set_rdr_ioerr(hcl, "erroneous or insufficient bigint length");
goto oops;
}
nbytes = hcl_leoowtoh(w);
if (nbytes % HCL_SIZEOF(hcl_liw_t)) goto oops; /* not the right number of bytes */
nwords = nbytes / HCL_SIZEOF(hcl_liw_t);
ns = hcl_makebigint(hcl, ((b == HCL_XCHG_PBIGINT)? HCL_BRAND_PBIGINT: HCL_BRAND_NBIGINT), HCL_NULL, nwords);
if (HCL_UNLIKELY(!ns)) goto oops;
for (j = 0; j < nwords; j ++)
{
if (rdr(hcl, &liw, HCL_SIZEOF(liw), ctx) <= -1) goto oops;
liw = hcl_leliwtoh(liw);
HCL_OBJ_SET_LIWORD_VAL(ns, j, liw);
}
HCL_DEBUG1(hcl, "RESTORED BIGINT... [%O]\n", ns);
break;
}
case HCL_XCHG_FPDEC_1:
case HCL_XCHG_FPDEC_2:
case HCL_XCHG_FPDEC_3:
{
hcl_ooi_t scale;
hcl_oop_t ns;
/* read scale */
n = rdr(hcl, &w, HCL_SIZEOF(w), ctx);
if (n <= -1)
{
set_rdr_ioerr(hcl, "erroneous or insufficient record length");
goto oops;
}
scale = (hcl_ooi_t)hcl_leoowtoh(w);
HCL_DEBUG1(hcl, "RESTORED scale... [%O]\n", HCL_SMOOI_TO_OOP(scale));
if (b == HCL_XCHG_FPDEC_1)
{
hcl_ooi_t value;
n = rdr(hcl, &w, HCL_SIZEOF(w), ctx);
if (n <= -1)
{
set_rdr_ioerr(hcl, "erroneous or insufficient record length");
goto oops;
}
value = (hcl_ooi_t)hcl_leoowtoh(w);
ns = hcl_makefpdec(hcl, HCL_SMOOI_TO_OOP(value), scale);
if (HCL_UNLIKELY(!ns)) goto oops;
}
else
{
hcl_oow_t j, nbytes, nwords;
hcl_liw_t liw;
hcl_oop_t v;
n = rdr(hcl, &w, HCL_SIZEOF(w), ctx);
if (n <= -1)
{
set_rdr_ioerr(hcl, "erroneous or insufficient record length");
goto oops;
}
nbytes = hcl_leoowtoh(w);
if (nbytes % HCL_SIZEOF(hcl_liw_t)) goto oops; /* not the right number of bytes */
nwords = nbytes / HCL_SIZEOF(hcl_liw_t);
HCL_DEBUG1(hcl, "FPDEC NWORD %d\n", (int)nwords);
v = hcl_makebigint(hcl, ((b == HCL_XCHG_FPDEC_2) ? HCL_BRAND_PBIGINT : HCL_BRAND_NBIGINT), HCL_NULL, nwords);
if (HCL_UNLIKELY(!v)) goto oops;
for (j = 0; j < nwords; j++)
{
if (rdr(hcl, &liw, HCL_SIZEOF(liw), ctx) <= -1) goto oops;
liw = hcl_leliwtoh(liw);
HCL_OBJ_SET_LIWORD_VAL(v, j, liw);
}
HCL_DEBUG1(hcl, "RESTORED v... [%O]\n", v);
hcl_pushvolat (hcl, &v);
ns = hcl_makefpdec(hcl, v, scale);
hcl_popvolat (hcl);
if (HCL_UNLIKELY(!ns)) goto oops;
}
HCL_DEBUG1(hcl, "RESTORED FPDEC... [%O]\n", ns);
break;
}
case HCL_XCHG_PRIM:
/* TODO: */
break;
}
}
/* TODO: have i SEEN HCL_CLIT_END??? otherwise, incomplete... */
return 0;
oops:
return -1;
}
}