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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
bin/main.c
View File

@ -393,7 +393,7 @@ static hcl_oop_t execute_in_interactive_mode (hcl_t* hcl)
{
hcl_oop_t retv;
hcl_decode (hcl, 0, hcl_getbclen(hcl));
hcl_decode (hcl, hcl_getcode(hcl), 0, hcl_getbclen(hcl));
HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n");
g_hcl = hcl;
/*setup_tick ();*/
@ -428,15 +428,60 @@ static hcl_oop_t execute_in_interactive_mode (hcl_t* hcl)
return retv;
}
/* for testing... */
static hcl_uint8_t xxxbuf[900000];
static hcl_oow_t xxxlen = 0;
static hcl_oow_t xxxpos = 0;
static int clit_writer(hcl_t* hcl, const void* ptr, hcl_oow_t len, void* ctx)
{
const hcl_uint8_t* p = (const hcl_uint8_t*)ptr;
const hcl_uint8_t* e = p + len;
while (p < e) xxxbuf[xxxlen++] = *p++;
return 0;
}
static int clit_reader(hcl_t* hcl, void* ptr, hcl_oow_t len, void* ctx)
{
hcl_uint8_t* p = (hcl_uint8_t*)ptr;
hcl_uint8_t* e = p + len;
while (p < e)
{
if (xxxpos >= xxxlen)
{
hcl_seterrbfmt (hcl, HCL_ENOENT, "no more data");
return -1;
}
*p++ = xxxbuf[xxxpos++];
}
return 0;
}
/* for testing... */
static hcl_oop_t execute_in_batch_mode(hcl_t* hcl, int verbose)
{
hcl_oop_t retv;
hcl_decode(hcl, 0, hcl_getbclen(hcl));
hcl_decode(hcl, hcl_getcode(hcl), 0, hcl_getbclen(hcl));
HCL_LOG3(hcl, HCL_LOG_MNEMONIC, "BYTECODES bclen=%zu lflen=%zu ngtmprs=%zu\n", hcl_getbclen(hcl), hcl_getlflen(hcl), hcl_getngtmprs(hcl));
g_hcl = hcl;
/*setup_tick ();*/
/* TESTING */
#if 0
{
xxxlen = 0;
hcl_marshalcode(hcl, &hcl->code, clit_writer, HCL_NULL);
xxxpos = 0;
hcl_unmarshalcode(hcl, &hcl->code, clit_reader, HCL_NULL);
}
#endif
/* END TESTING */
retv = hcl_execute(hcl);
hcl_flushudio (hcl);

7
lang.txt
View File

@ -13,6 +13,13 @@
implement namespace -> ::, ., or what notation?
review the . notation used for C-module loading... may have to change it
dynamic byte array is supported but we need yet to support byte-string(byte-array) constant
b"..." or B"..." for an byte string constant notation
u"..." or U"..." for an explicit unicode string constant notation?
make basic branded types to an object if possible.
for example (: #[10 20] at 1)
## dictionary list (DIC)
#{ 1 2 3 4 }

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;
}
}