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

work in progress dropping the brand bits
Some checks failed
continuous-integration/drone/push Build is failing
Details

Browse Source
This commit is contained in:
hyung-hwan 2024-09-12 18:06:12 +09:00
parent 6e9e1d35f4
commit f6f475df4a
8 changed files with 136 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
lib/bigint.c
View File

@ -73,6 +73,9 @@ static const hcl_uint8_t debruijn_64[64] =
50, 31, 19, 15, 30, 14, 13, 12 50, 31, 19, 15, 30, 14, 13, 12
}; };
#define make_pbigint(hcl, ptr, len) (hcl_instantiate(hcl, hcl->c_large_positive_integer, ptr, len))
#define make_nbigint(hcl, ptr, len) (hcl_instantiate(hcl, hcl->c_large_negative_integer, ptr, len))
#if defined(HCL_HAVE_UINT32_T) #if defined(HCL_HAVE_UINT32_T)
# define LOG2_FOR_POW2_32(x) (debruijn_32[(hcl_uint32_t)((hcl_uint32_t)(x) * 0x077CB531) >> 27]) # define LOG2_FOR_POW2_32(x) (debruijn_32[(hcl_uint32_t)((hcl_uint32_t)(x) * 0x077CB531) >> 27])
#endif #endif
@ -531,12 +534,12 @@ static HCL_INLINE hcl_oop_t make_bigint_with_oow (hcl_t* hcl, hcl_oow_t w)
{ {
#if (HCL_LIW_BITS == HCL_OOW_BITS) #if (HCL_LIW_BITS == HCL_OOW_BITS)
HCL_ASSERT (hcl, HCL_SIZEOF(hcl_oow_t) == HCL_SIZEOF(hcl_liw_t)); HCL_ASSERT (hcl, HCL_SIZEOF(hcl_oow_t) == HCL_SIZEOF(hcl_liw_t));
return hcl_makebigint(hcl, HCL_BRAND_PBIGINT, &w, 1); return make_pbigint(hcl, &w, 1);
#elif (HCL_LIW_BITS == HCL_OOHW_BITS) #elif (HCL_LIW_BITS == HCL_OOHW_BITS)
hcl_liw_t hw[2]; hcl_liw_t hw[2];
hw[0] = w /*& HCL_LBMASK(hcl_oow_t,HCL_LIW_BITS)*/; hw[0] = w /*& HCL_LBMASK(hcl_oow_t,HCL_LIW_BITS)*/;
hw[1] = w >> HCL_LIW_BITS; hw[1] = w >> HCL_LIW_BITS;
return hcl_makebigint(hcl, HCL_BRAND_PBIGINT, hw, (hw[1] > 0? 2: 1)); return make_pbigint(hcl, hw, (hw[1] > 0? 2: 1));
#else #else
# error UNSUPPORTED LIW BIT SIZE # error UNSUPPORTED LIW BIT SIZE
#endif #endif
@ -551,12 +554,12 @@ static HCL_INLINE hcl_oop_t make_bigint_with_ooi (hcl_t* hcl, hcl_ooi_t i)
if (i >= 0) if (i >= 0)
{ {
w = i; w = i;
return hcl_makebigint(hcl, HCL_BRAND_PBIGINT, &w, 1); return make_pbigint(hcl, &w, 1);
} }
else else
{ {
w = (i == HCL_TYPE_MIN(hcl_ooi_t))? ((hcl_oow_t)HCL_TYPE_MAX(hcl_ooi_t) + 1): -i; w = (i == HCL_TYPE_MIN(hcl_ooi_t))? ((hcl_oow_t)HCL_TYPE_MAX(hcl_ooi_t) + 1): -i;
return hcl_makebigint(hcl, HCL_BRAND_NBIGINT, &w, 1); return make_nbigint(hcl, &w, 1);
} }
#elif (HCL_LIW_BITS == HCL_OOHW_BITS) #elif (HCL_LIW_BITS == HCL_OOHW_BITS)
hcl_liw_t hw[2]; hcl_liw_t hw[2];
@ -568,7 +571,7 @@ static HCL_INLINE hcl_oop_t make_bigint_with_ooi (hcl_t* hcl, hcl_ooi_t i)
w = i; w = i;
hw[0] = w /*& HCL_LBMASK(hcl_oow_t,HCL_LIW_BITS)*/; hw[0] = w /*& HCL_LBMASK(hcl_oow_t,HCL_LIW_BITS)*/;
hw[1] = w >> HCL_LIW_BITS; hw[1] = w >> HCL_LIW_BITS;
return hcl_makebigint(hcl, HCL_BRAND_PBIGINT, hw, (hw[1] > 0? 2: 1)); return make_pbigint(hcl, hw, (hw[1] > 0? 2: 1));
} }
else else
{ {
@ -576,7 +579,7 @@ static HCL_INLINE hcl_oop_t make_bigint_with_ooi (hcl_t* hcl, hcl_ooi_t i)
w = (i == HCL_TYPE_MIN(hcl_ooi_t))? ((hcl_oow_t)HCL_TYPE_MAX(hcl_ooi_t) + 1): -i; w = (i == HCL_TYPE_MIN(hcl_ooi_t))? ((hcl_oow_t)HCL_TYPE_MAX(hcl_ooi_t) + 1): -i;
hw[0] = w /*& HCL_LBMASK(hcl_oow_t,HCL_LIW_BITS)*/; hw[0] = w /*& HCL_LBMASK(hcl_oow_t,HCL_LIW_BITS)*/;
hw[1] = w >> HCL_LIW_BITS; hw[1] = w >> HCL_LIW_BITS;
return hcl_makebigint(hcl, HCL_BRAND_NBIGINT, hw, (hw[1] > 0? 2: 1)); return make_nbigint(hcl, hw, (hw[1] > 0? 2: 1));
} }
#else #else
# error UNSUPPORTED LIW BIT SIZE # error UNSUPPORTED LIW BIT SIZE
@ -594,12 +597,12 @@ static HCL_INLINE hcl_oop_t make_bloated_bigint_with_ooi (hcl_t* hcl, hcl_ooi_t
if (i >= 0) if (i >= 0)
{ {
w = i; w = i;
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, 1 + extra); z = make_pbigint(hcl, HCL_NULL, 1 + extra);
} }
else else
{ {
w = (i == HCL_TYPE_MIN(hcl_ooi_t))? ((hcl_oow_t)HCL_TYPE_MAX(hcl_ooi_t) + 1): -i; w = (i == HCL_TYPE_MIN(hcl_ooi_t))? ((hcl_oow_t)HCL_TYPE_MAX(hcl_ooi_t) + 1): -i;
z = hcl_makebigint(hcl, HCL_BRAND_NBIGINT, HCL_NULL, 1 + extra); z = make_nbigint(hcl, HCL_NULL, 1 + extra);
} }
if (!z) return HCL_NULL; if (!z) return HCL_NULL;
@ -617,14 +620,14 @@ static HCL_INLINE hcl_oop_t make_bloated_bigint_with_ooi (hcl_t* hcl, hcl_ooi_t
w = i; w = i;
hw[0] = w /*& HCL_LBMASK(hcl_oow_t,HCL_LIW_BITS)*/; hw[0] = w /*& HCL_LBMASK(hcl_oow_t,HCL_LIW_BITS)*/;
hw[1] = w >> HCL_LIW_BITS; hw[1] = w >> HCL_LIW_BITS;
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, (hw[1] > 0? 2: 1) + extra); z = make_pbigint(hcl, HCL_NULL, (hw[1] > 0? 2: 1) + extra);
} }
else else
{ {
w = (i == HCL_TYPE_MIN(hcl_ooi_t))? ((hcl_oow_t)HCL_TYPE_MAX(hcl_ooi_t) + 1): -i; w = (i == HCL_TYPE_MIN(hcl_ooi_t))? ((hcl_oow_t)HCL_TYPE_MAX(hcl_ooi_t) + 1): -i;
hw[0] = w /*& HCL_LBMASK(hcl_oow_t,HCL_LIW_BITS)*/; hw[0] = w /*& HCL_LBMASK(hcl_oow_t,HCL_LIW_BITS)*/;
hw[1] = w >> HCL_LIW_BITS; hw[1] = w >> HCL_LIW_BITS;
z = hcl_makebigint(hcl, HCL_BRAND_NBIGINT, HCL_NULL, (hw[1] > 0? 2: 1) + extra); z = make_nbigint(hcl, HCL_NULL, (hw[1] > 0? 2: 1) + extra);
} }
if (!z) return HCL_NULL; if (!z) return HCL_NULL;
@ -641,7 +644,7 @@ static HCL_INLINE hcl_oop_t make_bigint_with_intmax (hcl_t* hcl, hcl_intmax_t v)
hcl_oow_t len; hcl_oow_t len;
hcl_liw_t buf[HCL_SIZEOF_INTMAX_T / HCL_SIZEOF_LIW_T]; hcl_liw_t buf[HCL_SIZEOF_INTMAX_T / HCL_SIZEOF_LIW_T];
hcl_uintmax_t ui; hcl_uintmax_t ui;
int brand; hcl_oop_class_t _class;
/* this is not a generic function. it can't handle v /* this is not a generic function. it can't handle v
* if it's HCL_TYPE_MIN(hcl_intmax_t) */ * if it's HCL_TYPE_MIN(hcl_intmax_t) */
@ -650,12 +653,12 @@ static HCL_INLINE hcl_oop_t make_bigint_with_intmax (hcl_t* hcl, hcl_intmax_t v)
if (v >= 0) if (v >= 0)
{ {
ui = v; ui = v;
brand = HCL_BRAND_PBIGINT; _class = hcl->c_large_positive_integer;
} }
else else
{ {
ui = (v == HCL_TYPE_MIN(hcl_intmax_t))? ((hcl_uintmax_t)HCL_TYPE_MAX(hcl_intmax_t) + 1): -v; ui = (v == HCL_TYPE_MIN(hcl_intmax_t))? ((hcl_uintmax_t)HCL_TYPE_MAX(hcl_intmax_t) + 1): -v;
brand = HCL_BRAND_NBIGINT; _class = hcl->c_large_negative_integer;
} }
len = 0; len = 0;
@ -666,7 +669,7 @@ static HCL_INLINE hcl_oop_t make_bigint_with_intmax (hcl_t* hcl, hcl_intmax_t v)
} }
while (ui > 0); while (ui > 0);
return hcl_makebigint(hcl, brand, buf, len); return hcl_instantiate(hcl, _class, buf, len);
} }
static HCL_INLINE hcl_oop_t make_bigint_with_uintmax (hcl_t* hcl, hcl_uintmax_t ui) static HCL_INLINE hcl_oop_t make_bigint_with_uintmax (hcl_t* hcl, hcl_uintmax_t ui)
@ -682,7 +685,7 @@ static HCL_INLINE hcl_oop_t make_bigint_with_uintmax (hcl_t* hcl, hcl_uintmax_t
} }
while (ui > 0); while (ui > 0);
return hcl_makebigint(hcl, HCL_BRAND_PBIGINT, buf, len); return make_pbigint(hcl, buf, len);
} }
hcl_oop_t hcl_oowtoint (hcl_t* hcl, hcl_oow_t w) hcl_oop_t hcl_oowtoint (hcl_t* hcl, hcl_oow_t w)
@ -750,14 +753,19 @@ static HCL_INLINE hcl_oop_t expand_bigint (hcl_t* hcl, hcl_oop_t oop, hcl_oow_t
if (inc > HCL_OBJ_SIZE_MAX - count) if (inc > HCL_OBJ_SIZE_MAX - count)
{ {
hcl_seterrnum (hcl, HCL_EOOMEM); /* TODO: is it a soft failure or a hard failure? is this error code proper? */ hcl_seterrbfmt (hcl, HCL_EOOMEM, "unable to expand bigint %O by %zu liwords", oop, inc); /* TODO: is it a soft failure or a hard failure? is this error code proper? */
return HCL_NULL; return HCL_NULL;
} }
hcl_pushvolat (hcl, &oop); hcl_pushvolat (hcl, &oop);
z = hcl_makebigint(hcl, HCL_OBJ_GET_FLAGS_BRAND(oop), HCL_NULL, count + inc); z = hcl_instantiate(hcl, HCL_OBJ_GET_CLASS(oop), HCL_NULL, count + inc);
hcl_popvolat (hcl); hcl_popvolat (hcl);
if (!z) return HCL_NULL; if (!z)
{
const hcl_ooch_t* orgmsg = hcl_backuperrmsg(hcl);
hcl_seterrbfmt (hcl, HCL_ERRNUM(hcl), "unable to clone bigint %O for expansion - %s", oop, orgmsg);
return HCL_NULL;
}
for (i = 0; i < count; i++) for (i = 0; i < count; i++)
{ {
@ -766,7 +774,7 @@ static HCL_INLINE hcl_oop_t expand_bigint (hcl_t* hcl, hcl_oop_t oop, hcl_oow_t
return z; return z;
} }
static HCL_INLINE hcl_oop_t _clone_bigint (hcl_t* hcl, hcl_oop_t oop, hcl_oow_t count, int brand) static HCL_INLINE hcl_oop_t _clone_bigint(hcl_t* hcl, hcl_oop_t oop, hcl_oow_t count, hcl_oop_class_t _class)
{ {
hcl_oop_t z; hcl_oop_t z;
hcl_oow_t i; hcl_oow_t i;
@ -774,8 +782,10 @@ static HCL_INLINE hcl_oop_t _clone_bigint (hcl_t* hcl, hcl_oop_t oop, hcl_oow_t
HCL_ASSERT (hcl, HCL_OOP_IS_POINTER(oop)); HCL_ASSERT (hcl, HCL_OOP_IS_POINTER(oop));
if (count <= 0) count = HCL_OBJ_GET_SIZE(oop); if (count <= 0) count = HCL_OBJ_GET_SIZE(oop);
hcl_pushvolat (hcl, &_class);
hcl_pushvolat (hcl, &oop); hcl_pushvolat (hcl, &oop);
z = hcl_makebigint(hcl, brand, HCL_NULL, count); z = hcl_instantiate(hcl, _class, HCL_NULL, count);
hcl_popvolat (hcl);
hcl_popvolat (hcl); hcl_popvolat (hcl);
if (!z) return HCL_NULL; if (!z) return HCL_NULL;
@ -788,31 +798,31 @@ static HCL_INLINE hcl_oop_t _clone_bigint (hcl_t* hcl, hcl_oop_t oop, hcl_oow_t
static HCL_INLINE hcl_oop_t clone_bigint (hcl_t* hcl, hcl_oop_t oop, hcl_oow_t count) static HCL_INLINE hcl_oop_t clone_bigint (hcl_t* hcl, hcl_oop_t oop, hcl_oow_t count)
{ {
return _clone_bigint (hcl, oop, count, HCL_OBJ_GET_FLAGS_BRAND(oop)); return _clone_bigint(hcl, oop, count, HCL_OBJ_GET_CLASS(oop));
} }
static HCL_INLINE hcl_oop_t clone_bigint_negated (hcl_t* hcl, hcl_oop_t oop, hcl_oow_t count) static HCL_INLINE hcl_oop_t clone_bigint_negated (hcl_t* hcl, hcl_oop_t oop, hcl_oow_t count)
{ {
int brand; hcl_oop_class_t _class;
HCL_ASSERT (hcl, HCL_IS_BIGINT(hcl,oop)); HCL_ASSERT (hcl, HCL_IS_BIGINT(hcl,oop));
if (HCL_IS_PBIGINT(hcl, oop)) if (HCL_IS_PBIGINT(hcl, oop))
{ {
brand = HCL_BRAND_NBIGINT; _class = hcl->c_large_negative_integer;
} }
else else
{ {
HCL_ASSERT (hcl, HCL_IS_NBIGINT(hcl, oop)); HCL_ASSERT (hcl, HCL_IS_NBIGINT(hcl, oop));
brand = HCL_BRAND_PBIGINT; _class = hcl->c_large_positive_integer;
} }
return _clone_bigint (hcl, oop, count, brand); return _clone_bigint(hcl, oop, count, _class);
} }
static HCL_INLINE hcl_oop_t clone_bigint_to_positive (hcl_t* hcl, hcl_oop_t oop, hcl_oow_t count) static HCL_INLINE hcl_oop_t clone_bigint_to_positive (hcl_t* hcl, hcl_oop_t oop, hcl_oow_t count)
{ {
return _clone_bigint (hcl, oop, count, HCL_BRAND_PBIGINT); return _clone_bigint(hcl, oop, count, hcl->c_large_positive_integer);
} }
static HCL_INLINE hcl_oow_t count_effective (hcl_liw_t* x, hcl_oow_t xs) static HCL_INLINE hcl_oow_t count_effective (hcl_liw_t* x, hcl_oow_t xs)
@ -2121,7 +2131,7 @@ static hcl_oop_t add_unsigned_integers (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y)
hcl_pushvolat (hcl, &x); hcl_pushvolat (hcl, &x);
hcl_pushvolat (hcl, &y); hcl_pushvolat (hcl, &y);
z = hcl_makebigint(hcl, HCL_OBJ_GET_FLAGS_BRAND(x), HCL_NULL, zs); z = hcl_instantiate(hcl, HCL_OBJ_GET_CLASS(x), HCL_NULL, zs);
hcl_popvolats (hcl, 2); hcl_popvolats (hcl, 2);
if (!z) return HCL_NULL; if (!z) return HCL_NULL;
@ -2142,7 +2152,7 @@ static hcl_oop_t subtract_unsigned_integers (hcl_t* hcl, hcl_oop_t x, hcl_oop_t
hcl_pushvolat (hcl, &x); hcl_pushvolat (hcl, &x);
hcl_pushvolat (hcl, &y); hcl_pushvolat (hcl, &y);
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, HCL_OBJ_GET_SIZE(x)); z = make_pbigint(hcl, HCL_NULL, HCL_OBJ_GET_SIZE(x));
hcl_popvolats (hcl, 2); hcl_popvolats (hcl, 2);
if (!z) return HCL_NULL; if (!z) return HCL_NULL;
@ -2169,7 +2179,7 @@ static hcl_oop_t multiply_unsigned_integers (hcl_t* hcl, hcl_oop_t x, hcl_oop_t
hcl_pushvolat (hcl, &x); hcl_pushvolat (hcl, &x);
hcl_pushvolat (hcl, &y); hcl_pushvolat (hcl, &y);
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, xs + ys); z = make_pbigint(hcl, HCL_NULL, xs + ys);
hcl_popvolats (hcl, 2); hcl_popvolats (hcl, 2);
if (!z) return HCL_NULL; if (!z) return HCL_NULL;
@ -2233,11 +2243,11 @@ static hcl_oop_t divide_unsigned_integers (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y,
/*#define USE_DIVIDE_UNSIGNED_ARRAY3*/ /*#define USE_DIVIDE_UNSIGNED_ARRAY3*/
#if defined(USE_DIVIDE_UNSIGNED_ARRAY3) #if defined(USE_DIVIDE_UNSIGNED_ARRAY3)
qq = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, HCL_OBJ_GET_SIZE(x) + 2); qq = make_pbigint(hcl, HCL_NULL, HCL_OBJ_GET_SIZE(x) + 2);
#elif defined(USE_DIVIDE_UNSIGNED_ARRAY2) #elif defined(USE_DIVIDE_UNSIGNED_ARRAY2)
qq = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, HCL_OBJ_GET_SIZE(x) + 1); qq = make_pbigint(hcl, HCL_NULL, HCL_OBJ_GET_SIZE(x) + 1);
#else #else
qq = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, HCL_OBJ_GET_SIZE(x)); qq = make_pbigint(hcl, HCL_NULL, HCL_OBJ_GET_SIZE(x));
#endif #endif
if (!qq) if (!qq)
{ {
@ -2247,11 +2257,11 @@ static hcl_oop_t divide_unsigned_integers (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y,
hcl_pushvolat (hcl, &qq); hcl_pushvolat (hcl, &qq);
#if defined(USE_DIVIDE_UNSIGNED_ARRAY3) #if defined(USE_DIVIDE_UNSIGNED_ARRAY3)
rr = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, HCL_OBJ_GET_SIZE(y)); rr = make_pbigint(hcl, HCL_NULL, HCL_OBJ_GET_SIZE(y));
#elif defined(USE_DIVIDE_UNSIGNED_ARRAY2) #elif defined(USE_DIVIDE_UNSIGNED_ARRAY2)
rr = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, HCL_OBJ_GET_SIZE(y)); rr = make_pbigint(hcl, HCL_NULL, HCL_OBJ_GET_SIZE(y));
#else #else
rr = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, HCL_OBJ_GET_SIZE(y) + 1); rr = make_pbigint(hcl, HCL_NULL, HCL_OBJ_GET_SIZE(y) + 1);
#endif #endif
hcl_popvolats (hcl, 3); hcl_popvolats (hcl, 3);
if (!rr) return HCL_NULL; if (!rr) return HCL_NULL;
@ -3170,7 +3180,7 @@ hcl_oop_t hcl_bitandints (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y)
hcl_pushvolat (hcl, &x); hcl_pushvolat (hcl, &x);
hcl_pushvolat (hcl, &y); hcl_pushvolat (hcl, &y);
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, zalloc); z = make_pbigint(hcl, HCL_NULL, zalloc);
hcl_popvolats (hcl, 2); hcl_popvolats (hcl, 2);
if (!z) return HCL_NULL; if (!z) return HCL_NULL;
@ -3390,7 +3400,7 @@ hcl_oop_t hcl_bitorints (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y)
hcl_pushvolat (hcl, &x); hcl_pushvolat (hcl, &x);
hcl_pushvolat (hcl, &y); hcl_pushvolat (hcl, &y);
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, zalloc); z = make_pbigint(hcl, HCL_NULL, zalloc);
hcl_popvolats (hcl, 2); hcl_popvolats (hcl, 2);
if (!z) return HCL_NULL; if (!z) return HCL_NULL;
@ -3608,7 +3618,7 @@ hcl_oop_t hcl_bitxorints (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y)
hcl_pushvolat (hcl, &x); hcl_pushvolat (hcl, &x);
hcl_pushvolat (hcl, &y); hcl_pushvolat (hcl, &y);
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, zalloc); z = make_pbigint(hcl, HCL_NULL, zalloc);
hcl_popvolats (hcl, 2); hcl_popvolats (hcl, 2);
if (!z) return HCL_NULL; if (!z) return HCL_NULL;
@ -3766,7 +3776,7 @@ hcl_oop_t hcl_bitinvint (hcl_t* hcl, hcl_oop_t x)
} }
hcl_pushvolat (hcl, &x); hcl_pushvolat (hcl, &x);
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, zalloc); z = make_pbigint(hcl, HCL_NULL, zalloc);
hcl_popvolat (hcl); hcl_popvolat (hcl);
if (!z) return HCL_NULL; if (!z) return HCL_NULL;
@ -3838,7 +3848,7 @@ static HCL_INLINE hcl_oop_t rshift_negative_bigint (hcl_t* hcl, hcl_oop_t x, hcl
hcl_pushvolat (hcl, &x); hcl_pushvolat (hcl, &x);
/* +1 for the second inversion below */ /* +1 for the second inversion below */
z = hcl_makebigint(hcl, HCL_BRAND_NBIGINT, HCL_NULL, xs + 1); z = make_nbigint(hcl, HCL_NULL, xs + 1);
hcl_popvolat (hcl); hcl_popvolat (hcl);
if (!z) return HCL_NULL; if (!z) return HCL_NULL;
@ -4504,7 +4514,7 @@ hcl_oop_t hcl_strtoint (hcl_t* hcl, const hcl_ooch_t* str, hcl_oow_t len, int ra
# error UNSUPPORTED LIW BIT SIZE # error UNSUPPORTED LIW BIT SIZE
#endif #endif
res = hcl_makebigint(hcl, (sign < 0? HCL_BRAND_NBIGINT: HCL_BRAND_PBIGINT), hwp, hwlen); res = hcl_instantiate(hcl, (sign < 0? hcl->c_large_negative_integer: hcl->c_large_positive_integer), hwp, hwlen);
if (hwp && hw != hwp) hcl_freemem (hcl, hwp); if (hwp && hw != hwp) hcl_freemem (hcl, hwp);
return res; return res;
@ -4794,7 +4804,7 @@ hcl_oop_t hcl_absint (hcl_t* hcl, hcl_oop_t x)
} }
else if (HCL_IS_NBIGINT(hcl, x)) else if (HCL_IS_NBIGINT(hcl, x))
{ {
x = _clone_bigint(hcl, x, HCL_OBJ_GET_SIZE(x), HCL_BRAND_PBIGINT); x = _clone_bigint(hcl, x, HCL_OBJ_GET_SIZE(x), hcl->c_large_positive_integer);
} }
else if (HCL_IS_PBIGINT(hcl, x)) else if (HCL_IS_PBIGINT(hcl, x))
{ {

7
lib/exec.c
View File

@ -568,12 +568,7 @@ static hcl_oop_process_t make_process (hcl_t* hcl, hcl_oop_context_t c)
return HCL_NULL; return HCL_NULL;
} }
#if 0 HCL_OBJ_SET_FLAGS_PROC (proc, 1); /* a special flag to indicate an object is a process instance */
////////////////////
//// HCL_OBJ_SET_FLAGS_PROC (proc, proc_flags); /* a special flag to indicate an object is a process instance */
////////////////////
#endif
proc->state = HCL_SMOOI_TO_OOP(HCL_PROCESS_STATE_SUSPENDED); proc->state = HCL_SMOOI_TO_OOP(HCL_PROCESS_STATE_SUSPENDED);
/* assign a process id to the process */ /* assign a process id to the process */

32
lib/gc.c
View File

@ -622,7 +622,7 @@ static kernel_class_info_t kernel_classes[__KCI_MAX__] =
KCI(KCI_LARGE_POSITIVE_INTEGER) { KCI(KCI_LARGE_POSITIVE_INTEGER) {
"LargePositiveInteger", "LargePositiveInteger",
KCI_NUMBER, KCI_NUMBER,
0, HCL_BRAND_PBIGINT,
HCL_CLASS_SELFSPEC_FLAG_LIMITED, HCL_CLASS_SELFSPEC_FLAG_LIMITED,
0, 0,
0, 0,
@ -634,7 +634,7 @@ static kernel_class_info_t kernel_classes[__KCI_MAX__] =
KCI(KCI_LARGE_NEGATIVE_INTEGER) { KCI(KCI_LARGE_NEGATIVE_INTEGER) {
"LargeNegativeInteger", "LargeNegativeInteger",
KCI_NUMBER, KCI_NUMBER,
0, HCL_BRAND_NBIGINT,
HCL_CLASS_SELFSPEC_FLAG_LIMITED, HCL_CLASS_SELFSPEC_FLAG_LIMITED,
0, 0,
0, 0,
@ -870,11 +870,11 @@ static HCL_INLINE void gc_ms_scan_stack (hcl_t* hcl)
/* is it really better to use a flag bit in the header to /* is it really better to use a flag bit in the header to
* determine that it is an instance of process? */ * determine that it is an instance of process? */
/* if (HCL_UNLIKELY(HCL_OBJ_GET_FLAGS_PROC(oop))) */ if (HCL_UNLIKELY(HCL_OBJ_GET_FLAGS_PROC(oop)))
if (HCL_OBJ_GET_FLAGS_BRAND(oop) == HCL_BRAND_PROCESS) /* TODO: use a class or make this a special bit???*/
{ {
hcl_oop_process_t proc; hcl_oop_process_t proc;
HCL_ASSERT (hcl, HCL_IS_PROCESS(hcl, oop));
/* the stack in a process object doesn't need to be /* the stack in a process object doesn't need to be
* scanned in full. the slots above the stack pointer * scanned in full. the slots above the stack pointer
* are garbages. */ * are garbages. */
@ -886,13 +886,14 @@ static HCL_INLINE void gc_ms_scan_stack (hcl_t* hcl)
/* stack */ /* stack */
ll = HCL_OOP_TO_SMOOI(proc->sp); ll = HCL_OOP_TO_SMOOI(proc->sp);
HCL_ASSERT (hcl, ll < (hcl_ooi_t)(HCL_OBJ_GET_SIZE(oop) - HCL_PROCESS_NAMED_INSTVARS)); HCL_ASSERT (hcl, ll < (hcl_ooi_t)(HCL_OBJ_GET_SIZE(oop) - HCL_PROCESS_NAMED_INSTVARS));
for (i = 0; i <= ll; i++) gc_ms_mark_object (hcl, proc->slot[i]); for (i = 0; i <= ll; i++) gc_ms_mark_object (hcl, proc->slot[i]);
/* exception stack */ /* exception stack */
ll = HCL_OOP_TO_SMOOI(proc->exsp); ll = HCL_OOP_TO_SMOOI(proc->exsp);
HCL_ASSERT (hcl, ll < (hcl_ooi_t)(HCL_OBJ_GET_SIZE(oop) - HCL_PROCESS_NAMED_INSTVARS)); HCL_ASSERT (hcl, ll < (hcl_ooi_t)(HCL_OBJ_GET_SIZE(oop) - HCL_PROCESS_NAMED_INSTVARS));
for (i = HCL_OOP_TO_SMOOI(proc->st) + 1; i <= ll; i++) gc_ms_mark_object (hcl, proc->slot[i]); for (i = HCL_OOP_TO_SMOOI(proc->st) + 1; i <= ll; i++) gc_ms_mark_object (hcl, proc->slot[i]);
/* class stack */ /* class stack */
ll = HCL_OOP_TO_SMOOI(proc->clsp); ll = HCL_OOP_TO_SMOOI(proc->clsp);
HCL_ASSERT (hcl, ll < (hcl_ooi_t)(HCL_OBJ_GET_SIZE(oop) - HCL_PROCESS_NAMED_INSTVARS)); HCL_ASSERT (hcl, ll < (hcl_ooi_t)(HCL_OBJ_GET_SIZE(oop) - HCL_PROCESS_NAMED_INSTVARS));
@ -1818,8 +1819,14 @@ int hcl_ignite (hcl_t* hcl, hcl_oow_t heapsize)
{ {
/* Create a nil process used to simplify nil check in GC. /* Create a nil process used to simplify nil check in GC.
* only accessible by VM. not exported via the global dictionary. */ * only accessible by VM. not exported via the global dictionary. */
hcl->nil_process = (hcl_oop_process_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS); /*hcl->nil_process = (hcl_oop_process_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS);*/
if (HCL_UNLIKELY(!hcl->nil_process)) goto oops; hcl->nil_process = (hcl_oop_process_t)hcl_instantiate(hcl, hcl->c_process, HCL_NULL, 0);
if (HCL_UNLIKELY(!hcl->nil_process))
{
const hcl_ooch_t* orgmsg = hcl_backuperrmsg(hcl);
hcl_seterrbfmt (hcl, HCL_ERRNUM(hcl), "unable to make nil process - %js", orgmsg);
goto oops;
}
/* unusable stack */ /* unusable stack */
hcl->nil_process->sp = HCL_SMOOI_TO_OOP(-1); hcl->nil_process->sp = HCL_SMOOI_TO_OOP(-1);
@ -1834,8 +1841,15 @@ int hcl_ignite (hcl_t* hcl, hcl_oow_t heapsize)
if (!hcl->processor) if (!hcl->processor)
{ {
hcl->processor = (hcl_oop_process_scheduler_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS_SCHEDULER, HCL_PROCESS_SCHEDULER_NAMED_INSTVARS); /*hcl->processor = (hcl_oop_process_scheduler_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS_SCHEDULER, HCL_PROCESS_SCHEDULER_NAMED_INSTVARS);*/
if (HCL_UNLIKELY(!hcl->processor)) goto oops; hcl->processor = (hcl_oop_process_scheduler_t)hcl_instantiate(hcl, hcl->c_process_scheduler, HCL_NULL, 0);
if (HCL_UNLIKELY(!hcl->processor))
{
const hcl_ooch_t* orgmsg = hcl_backuperrmsg(hcl);
hcl_seterrbfmt (hcl, HCL_ERRNUM(hcl), "unable to make process scheduler - %js", orgmsg);
goto oops;
}
hcl->processor->active = hcl->nil_process; hcl->processor->active = hcl->nil_process;
hcl->processor->total_count = HCL_SMOOI_TO_OOP(0); hcl->processor->total_count = HCL_SMOOI_TO_OOP(0);
hcl->processor->runnable.count = HCL_SMOOI_TO_OOP(0); hcl->processor->runnable.count = HCL_SMOOI_TO_OOP(0);

57
lib/hcl.h
View File

@ -370,11 +370,11 @@ typedef enum hcl_obj_type_t hcl_obj_type_t;
#define HCL_OBJ_FLAGS_BRAND_BITS (6) /* 29 */ #define HCL_OBJ_FLAGS_BRAND_BITS (6) /* 29 */
#define HCL_OBJ_FLAGS_FLEXI_BITS (1) /* 30 */ #define HCL_OBJ_FLAGS_FLEXI_BITS (1) /* 30 */
#define HCL_OBJ_FLAGS_RDONLY_BITS (1) /* 31 */ #define HCL_OBJ_FLAGS_RDONLY_BITS (1) /* 31 */
#define HCL_OBJ_FLAGS_PROC_BITS (1) /* 32 */
/* /*
#define HCL_OBJ_FLAGS_PERM_BITS 1 #define HCL_OBJ_FLAGS_PERM_BITS 1
#define HCL_OBJ_FLAGS_MOVED_BITS 2 #define HCL_OBJ_FLAGS_MOVED_BITS 2
#define HCL_OBJ_FLAGS_PROC_BITS 2
#define HCL_OBJ_FLAGS_GCFIN_BITS 4 #define HCL_OBJ_FLAGS_GCFIN_BITS 4
#define HCL_OBJ_FLAGS_TRAILER_BITS 1 #define HCL_OBJ_FLAGS_TRAILER_BITS 1
#define HCL_OBJ_FLAGS_HASH_BITS 2 #define HCL_OBJ_FLAGS_HASH_BITS 2
@ -391,7 +391,8 @@ typedef enum hcl_obj_type_t hcl_obj_type_t;
#define HCL_OBJ_FLAGS_SYNCODE_SHIFT (HCL_OBJ_FLAGS_BRAND_BITS + HCL_OBJ_FLAGS_BRAND_SHIFT) #define HCL_OBJ_FLAGS_SYNCODE_SHIFT (HCL_OBJ_FLAGS_BRAND_BITS + HCL_OBJ_FLAGS_BRAND_SHIFT)
#define HCL_OBJ_FLAGS_BRAND_SHIFT (HCL_OBJ_FLAGS_FLEXI_BITS + HCL_OBJ_FLAGS_FLEXI_SHIFT) #define HCL_OBJ_FLAGS_BRAND_SHIFT (HCL_OBJ_FLAGS_FLEXI_BITS + HCL_OBJ_FLAGS_FLEXI_SHIFT)
#define HCL_OBJ_FLAGS_FLEXI_SHIFT (HCL_OBJ_FLAGS_RDONLY_BITS + HCL_OBJ_FLAGS_RDONLY_SHIFT) #define HCL_OBJ_FLAGS_FLEXI_SHIFT (HCL_OBJ_FLAGS_RDONLY_BITS + HCL_OBJ_FLAGS_RDONLY_SHIFT)
#define HCL_OBJ_FLAGS_RDONLY_SHIFT (0) #define HCL_OBJ_FLAGS_RDONLY_SHIFT (HCL_OBJ_FLAGS_PROC_BITS + HCL_OBJ_FLAGS_PROC_SHIFT)
#define HCL_OBJ_FLAGS_PROC_SHIFT (0)
#define HCL_OBJ_GET_FLAGS_TYPE(oop) HCL_GETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_TYPE_SHIFT, HCL_OBJ_FLAGS_TYPE_BITS) #define HCL_OBJ_GET_FLAGS_TYPE(oop) HCL_GETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_TYPE_SHIFT, HCL_OBJ_FLAGS_TYPE_BITS)
#define HCL_OBJ_GET_FLAGS_UNIT(oop) HCL_GETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_UNIT_SHIFT, HCL_OBJ_FLAGS_UNIT_BITS) #define HCL_OBJ_GET_FLAGS_UNIT(oop) HCL_GETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_UNIT_SHIFT, HCL_OBJ_FLAGS_UNIT_BITS)
@ -404,6 +405,7 @@ typedef enum hcl_obj_type_t hcl_obj_type_t;
#define HCL_OBJ_GET_FLAGS_BRAND(oop) HCL_GETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_BRAND_SHIFT, HCL_OBJ_FLAGS_BRAND_BITS) #define HCL_OBJ_GET_FLAGS_BRAND(oop) HCL_GETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_BRAND_SHIFT, HCL_OBJ_FLAGS_BRAND_BITS)
#define HCL_OBJ_GET_FLAGS_FLEXI(oop) HCL_GETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_FLEXI_SHIFT, HCL_OBJ_FLAGS_FLEXI_BITS) #define HCL_OBJ_GET_FLAGS_FLEXI(oop) HCL_GETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_FLEXI_SHIFT, HCL_OBJ_FLAGS_FLEXI_BITS)
#define HCL_OBJ_GET_FLAGS_RDONLY(oop) HCL_GETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_RDONLY_SHIFT, HCL_OBJ_FLAGS_RDONLY_BITS) #define HCL_OBJ_GET_FLAGS_RDONLY(oop) HCL_GETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_RDONLY_SHIFT, HCL_OBJ_FLAGS_RDONLY_BITS)
#define HCL_OBJ_GET_FLAGS_PROC(oop) HCL_GETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_PROC_SHIFT, HCL_OBJ_FLAGS_PROC_BITS)
#define HCL_OBJ_SET_FLAGS_TYPE(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_TYPE_SHIFT, HCL_OBJ_FLAGS_TYPE_BITS, v) #define HCL_OBJ_SET_FLAGS_TYPE(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_TYPE_SHIFT, HCL_OBJ_FLAGS_TYPE_BITS, v)
#define HCL_OBJ_SET_FLAGS_UNIT(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_UNIT_SHIFT, HCL_OBJ_FLAGS_UNIT_BITS, v) #define HCL_OBJ_SET_FLAGS_UNIT(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_UNIT_SHIFT, HCL_OBJ_FLAGS_UNIT_BITS, v)
@ -416,6 +418,7 @@ typedef enum hcl_obj_type_t hcl_obj_type_t;
#define HCL_OBJ_SET_FLAGS_BRAND(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_BRAND_SHIFT, HCL_OBJ_FLAGS_BRAND_BITS, v) #define HCL_OBJ_SET_FLAGS_BRAND(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_BRAND_SHIFT, HCL_OBJ_FLAGS_BRAND_BITS, v)
#define HCL_OBJ_SET_FLAGS_FLEXI(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_FLEXI_SHIFT, HCL_OBJ_FLAGS_FLEXI_BITS, v) #define HCL_OBJ_SET_FLAGS_FLEXI(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_FLEXI_SHIFT, HCL_OBJ_FLAGS_FLEXI_BITS, v)
#define HCL_OBJ_SET_FLAGS_RDONLY(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_RDONLY_SHIFT, HCL_OBJ_FLAGS_RDONLY_BITS, v) #define HCL_OBJ_SET_FLAGS_RDONLY(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_RDONLY_SHIFT, HCL_OBJ_FLAGS_RDONLY_BITS, v)
#define HCL_OBJ_SET_FLAGS_PROC(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_PROC_SHIFT, HCL_OBJ_FLAGS_PROC_BITS, v)
#define HCL_OBJ_GET_SIZE(oop) ((oop)->_size) #define HCL_OBJ_GET_SIZE(oop) ((oop)->_size)
#define HCL_OBJ_GET_CLASS(oop) ((oop)->_class) #define HCL_OBJ_GET_CLASS(oop) ((oop)->_class)
@ -2087,55 +2090,58 @@ typedef enum hcl_concode_t hcl_concode_t;
#define HCL_IS_FALSE(hcl,v) (v == (hcl)->_false) #define HCL_IS_FALSE(hcl,v) (v == (hcl)->_false)
/*#define HCL_IS_SYMBOL(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL)*/ /*#define HCL_IS_SYMBOL(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL)*/
#define HCL_IS_SYMBOL(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_symbol) #define HCL_IS_SYMBOL(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_symbol)
/*#define HCL_IS_STRING(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_STRING)*/ /*#define HCL_IS_STRING(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_STRING)*/
#define HCL_IS_STRING(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_string) #define HCL_IS_STRING(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_string)
/*#define HCL_IS_CONTEXT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONTEXT)*/ /*#define HCL_IS_CONTEXT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONTEXT)*/
#define HCL_IS_CONTEXT(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_block_context) #define HCL_IS_CONTEXT(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_block_context)
/*#define HCL_IS_FUNCTION(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FUNCTION)*/ /*#define HCL_IS_FUNCTION(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FUNCTION)*/
#define HCL_IS_FUNCTION(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_function) #define HCL_IS_FUNCTION(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_function)
/*#define HCL_IS_COMPILED_BLOCK(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_BLOCK)*/ /*#define HCL_IS_COMPILED_BLOCK(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_BLOCK)*/
#define HCL_IS_COMPILED_BLOCK(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_compiled_block) #define HCL_IS_COMPILED_BLOCK(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_compiled_block)
/*#define HCL_IS_CLASS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CLASS)*/ /*#define HCL_IS_CLASS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CLASS)*/
#define HCL_IS_CLASS(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_class) #define HCL_IS_CLASS(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_class)
#define HCL_IS_INSTANCE(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_INSTANCE) #define HCL_IS_INSTANCE(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_INSTANCE)
/*#define HCL_IS_CONS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONS)*/ /*#define HCL_IS_CONS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONS)*/
#define HCL_IS_CONS(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_cons) #define HCL_IS_CONS(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_cons)
#define HCL_IS_CONS_CONCODED(hcl,v,concode) (HCL_IS_CONS(hcl,v) && HCL_OBJ_GET_FLAGS_SYNCODE(v) == (concode)) #define HCL_IS_CONS_CONCODED(hcl,v,concode) (HCL_IS_CONS(hcl,v) && HCL_OBJ_GET_FLAGS_SYNCODE(v) == (concode))
/*#define HCL_IS_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_ARRAY)*/ /*#define HCL_IS_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_ARRAY)*/
#define HCL_IS_ARRAY(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_array) #define HCL_IS_ARRAY(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_array)
/*#define HCL_IS_BYTEARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_BYTE_ARRAY)*/ /*#define HCL_IS_BYTEARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_BYTE_ARRAY)*/
#define HCL_IS_BYTEARRAY(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_byte_array) #define HCL_IS_BYTEARRAY(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_byte_array)
/*#define HCL_IS_DIC(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_DIC)*/ /*#define HCL_IS_DIC(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_DIC)*/
#define HCL_IS_DIC(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_dictionary) #define HCL_IS_DIC(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_dictionary)
/*#define HCL_IS_PRIM(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PRIM)*/ /*#define HCL_IS_PRIM(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PRIM)*/
#define HCL_IS_PRIM(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_primitive) #define HCL_IS_PRIM(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_primitive)
#define HCL_IS_PBIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PBIGINT) /*#define HCL_IS_PBIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PBIGINT)*/
#define HCL_IS_NBIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_NBIGINT) #define HCL_IS_PBIGINT(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_large_positive_integer)
#define HCL_IS_BIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && (HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PBIGINT || HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_NBIGINT)) /*#define HCL_IS_NBIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_NBIGINT)*/
#define HCL_IS_FPDEC(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FPDEC) #define HCL_IS_NBIGINT(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_large_negative_integer)
#define HCL_IS_BIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && (HCL_OBJ_GET_CLASS(v) == (hcl_oop_t)(hcl)->c_large_positive_integer || HCL_OBJ_GET_CLASS(v) == (hcl_oop_t)(hcl)->c_large_negative_integer))
/*#define HCL_IS_FPDEC(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FPDEC)*/
#define HCL_IS_FPDEC(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_fixed_point_decimal)
/*#define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS)*/ /*#define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS)*/
#define HCL_IS_PROCESS(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_process) #define HCL_IS_PROCESS(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_process)
/*#define HCL_IS_SEMAPHORE(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SEMAPHORE)*/ /*#define HCL_IS_SEMAPHORE(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SEMAPHORE)*/
#define HCL_IS_SEMAPHORE(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_semaphore) #define HCL_IS_SEMAPHORE(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_semaphore)
/*#define HCL_IS_SEMAPHORE_GROUP(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SEMAPHORE_GROUP)*/ /*#define HCL_IS_SEMAPHORE_GROUP(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SEMAPHORE_GROUP)*/
#define HCL_IS_SEMAPHORE_GROUP(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_semaphore_group) #define HCL_IS_SEMAPHORE_GROUP(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_semaphore_group)
#define HCL_CONS_CAR(v) (((hcl_cons_t*)(v))->car) #define HCL_CONS_CAR(v) (((hcl_cons_t*)(v))->car)
#define HCL_CONS_CDR(v) (((hcl_cons_t*)(v))->cdr) #define HCL_CONS_CDR(v) (((hcl_cons_t*)(v))->cdr)
@ -2147,7 +2153,6 @@ typedef int (*hcl_dic_walker_t) (
void* ctx void* ctx
); );
typedef int (*hcl_xchg_reader_t) ( typedef int (*hcl_xchg_reader_t) (
hcl_t* hcl, hcl_t* hcl,
void* buf, void* buf,
@ -2974,14 +2979,6 @@ HCL_EXPORT hcl_oop_t hcl_makeprim (
hcl_mod_t* mod hcl_mod_t* mod
); );
HCL_EXPORT hcl_oop_t hcl_makebigint (
hcl_t* hcl,
int brand,
const hcl_liw_t* ptr,
hcl_oow_t len
);
HCL_EXPORT hcl_oop_t hcl_oowtoint ( HCL_EXPORT hcl_oop_t hcl_oowtoint (
hcl_t* hcl, hcl_t* hcl,
hcl_oow_t w hcl_oow_t w

28
lib/obj.c
View File

@ -286,30 +286,6 @@ hcl_oop_t hcl_hatchnil (hcl_t* hcl)
return v; return v;
} }
hcl_oop_t hcl_makebigint (hcl_t* hcl, int brand, const hcl_liw_t* ptr, hcl_oow_t len)
{
hcl_oop_t v;
/* TODO: use hcl_instantiate.. */
HCL_ASSERT (hcl, brand == HCL_BRAND_PBIGINT || brand == HCL_BRAND_NBIGINT);
#if (HCL_LIW_BITS == HCL_OOW_BITS)
v = hcl_allocwordobj(hcl, brand, ptr, len);
#elif (HCL_LIW_BITS == HCL_OOHW_BITS)
v = hcl_allochalfwordobj(hcl, brand, ptr, len);
#else
# error UNSUPPORTED LIW BIT SIZE
#endif
if (HCL_UNLIKELY(v))
{
hcl_oop_class_t _class = (brand == HCL_BRAND_PBIGINT)?
hcl->c_large_positive_integer: hcl->c_large_negative_integer;
HCL_OBJ_SET_FLAGS_BRAND (v, brand);
HCL_OBJ_SET_CLASS (v, (hcl_oop_t)_class);
}
return v;
}
hcl_oop_t hcl_makecons (hcl_t* hcl, hcl_oop_t car, hcl_oop_t cdr) hcl_oop_t hcl_makecons (hcl_t* hcl, hcl_oop_t car, hcl_oop_t cdr)
{ {
/* TODO: use hcl_instantiate() */ /* TODO: use hcl_instantiate() */
@ -522,7 +498,8 @@ hcl_oop_t hcl_makefpdec (hcl_t* hcl, hcl_oop_t value, hcl_ooi_t scale)
} }
hcl_pushvolat (hcl, &value); hcl_pushvolat (hcl, &value);
f = (hcl_oop_fpdec_t)hcl_allocoopobj(hcl, HCL_BRAND_FPDEC, HCL_FPDEC_NAMED_INSTVARS); /* f = (hcl_oop_fpdec_t)hcl_allocoopobj(hcl, HCL_BRAND_FPDEC, HCL_FPDEC_NAMED_INSTVARS); */
f = (hcl_oop_fpdec_t)hcl_instantiate(hcl, hcl->c_fixed_point_decimal, HCL_NULL, 0);
hcl_popvolat (hcl); hcl_popvolat (hcl);
if (HCL_UNLIKELY(!f)) if (HCL_UNLIKELY(!f))
@ -534,7 +511,6 @@ hcl_oop_t hcl_makefpdec (hcl_t* hcl, hcl_oop_t value, hcl_ooi_t scale)
{ {
f->value = value; f->value = value;
f->scale = HCL_SMOOI_TO_OOP(scale); f->scale = HCL_SMOOI_TO_OOP(scale);
HCL_OBJ_SET_CLASS (f, (hcl_oop_t)hcl->c_fixed_point_decimal);
} }
return (hcl_oop_t)f; return (hcl_oop_t)f;

4
lib/xchg.c
View File

@ -446,7 +446,7 @@ int hcl_unmarshalcode (hcl_t* hcl, hcl_code_t* code, hcl_xchg_reader_t rdr, void
if (nbytes % HCL_SIZEOF(hcl_liw_t)) goto oops; /* not the right number of bytes */ if (nbytes % HCL_SIZEOF(hcl_liw_t)) goto oops; /* not the right number of bytes */
nwords = nbytes / HCL_SIZEOF(hcl_liw_t); nwords = nbytes / HCL_SIZEOF(hcl_liw_t);
ns = hcl_makebigint(hcl, ((b == HCL_XCHG_PBIGINT)? HCL_BRAND_PBIGINT: HCL_BRAND_NBIGINT), HCL_NULL, nwords); ns = hcl_instantiate(hcl, ((b == HCL_XCHG_PBIGINT)? hcl->c_large_positive_integer: hcl->c_large_negative_integer), HCL_NULL, nwords);
if (HCL_UNLIKELY(!ns)) goto oops; if (HCL_UNLIKELY(!ns)) goto oops;
for (j = 0; j < nwords; j ++) for (j = 0; j < nwords; j ++)
@ -506,7 +506,7 @@ int hcl_unmarshalcode (hcl_t* hcl, hcl_code_t* code, hcl_xchg_reader_t rdr, void
if (nbytes % HCL_SIZEOF(hcl_liw_t)) goto oops; /* not the right number of bytes */ if (nbytes % HCL_SIZEOF(hcl_liw_t)) goto oops; /* not the right number of bytes */
nwords = nbytes / HCL_SIZEOF(hcl_liw_t); nwords = nbytes / HCL_SIZEOF(hcl_liw_t);
v = hcl_makebigint(hcl, ((b == HCL_XCHG_FPDEC_2) ? HCL_BRAND_PBIGINT : HCL_BRAND_NBIGINT), HCL_NULL, nwords); v = hcl_instantiate(hcl, ((b == HCL_XCHG_FPDEC_2) ? hcl->c_large_positive_integer : hcl->c_large_negative_integer), HCL_NULL, nwords);
if (HCL_UNLIKELY(!v)) goto oops; if (HCL_UNLIKELY(!v)) goto oops;
for (j = 0; j < nwords; j++) for (j = 0; j < nwords; j++)

1
t/proc-01.hcl
View File

@ -47,4 +47,3 @@ if (== z1 101) { printf "OK: z1 is %d\n" z1 } \
else { printf "ERROR: z1 is not 101 - %d\n" z1 } else { printf "ERROR: z1 is not 101 - %d\n" z1 }
if (== z2 100) { printf "OK: z2 is %d\n" z2 } \ if (== z2 100) { printf "OK: z2 is %d\n" z2 } \
else { printf "ERROR: z1 is not 100 - %d\n" z2 } else { printf "ERROR: z1 is not 100 - %d\n" z2 }

19
t/ret-01.hcl
View File

@ -1,11 +1,11 @@
defun repeat(n f) { fun repeat(n f) {
while (> n 0) { while (> n 0) {
f; f;
set n (- n 1); set n (- n 1);
}; };
}; };
defun test-non-local-ret-1(k) { fun test-non-local-ret-1(k) {
repeat 10 (fun() { repeat 10 (fun() {
set k (+ k 2); set k (+ k 2);
if (= k 28) { revert k }; if (= k 28) { revert k };
@ -22,8 +22,21 @@ set a (test-non-local-ret-1 21);
if (~= a 41) { printf "ERROR: a must be 41\n" } \ if (~= a 41) { printf "ERROR: a must be 41\n" } \
else { printf "OK %d\n" a }; else { printf "OK %d\n" a };
fun dd() { return (- 99999999999999991111111111111111111111111111111111111111.111111111 999999999999999999999999999999.999999999999) }
defun ff() { return 999 }; fun ee() { return (+ 1111111111111111111111111111111111111111111111111 999999999999999999999999999999999999999999) }
fun ff() { return 999 };
## test a normal block return with a fixed point decimal
set a (dd);
if (~= a 99999999999999991111111110111111111111111111111111111111.111111111001) { printf "ERROR: a must be 99999999999999991111111110111111111111111111111111111111.111111111001\n" } \
else { printf "OK %f\n" a };
## test a normal block return with a large integer
set a (ee);
if (~= a 1111112111111111111111111111111111111111111111110) { printf "ERROR: a must be 1111112111111111111111111111111111111111111111110\n" } \
else { printf "OK %d\n" a };
## test a normal block return ## test a normal block return
set a (ff); set a (ff);