work in progress dropping the brand bits
Some checks failed
continuous-integration/drone/push Build is failing
Some checks failed
continuous-integration/drone/push Build is failing
This commit is contained in:
parent
6e9e1d35f4
commit
f6f475df4a
120
lib/bigint.c
120
lib/bigint.c
@ -73,6 +73,9 @@ static const hcl_uint8_t debruijn_64[64] =
|
||||
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)
|
||||
# define LOG2_FOR_POW2_32(x) (debruijn_32[(hcl_uint32_t)((hcl_uint32_t)(x) * 0x077CB531) >> 27])
|
||||
#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)
|
||||
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)
|
||||
hcl_liw_t hw[2];
|
||||
hw[0] = w /*& HCL_LBMASK(hcl_oow_t,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
|
||||
# error UNSUPPORTED LIW BIT SIZE
|
||||
#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)
|
||||
{
|
||||
w = i;
|
||||
return hcl_makebigint(hcl, HCL_BRAND_PBIGINT, &w, 1);
|
||||
return make_pbigint(hcl, &w, 1);
|
||||
}
|
||||
else
|
||||
{
|
||||
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)
|
||||
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;
|
||||
hw[0] = w /*& HCL_LBMASK(hcl_oow_t,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
|
||||
{
|
||||
@ -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;
|
||||
hw[0] = w /*& HCL_LBMASK(hcl_oow_t,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
|
||||
# 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)
|
||||
{
|
||||
w = i;
|
||||
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, 1 + extra);
|
||||
z = make_pbigint(hcl, HCL_NULL, 1 + extra);
|
||||
}
|
||||
else
|
||||
{
|
||||
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;
|
||||
@ -617,14 +620,14 @@ static HCL_INLINE hcl_oop_t make_bloated_bigint_with_ooi (hcl_t* hcl, hcl_ooi_t
|
||||
w = i;
|
||||
hw[0] = w /*& HCL_LBMASK(hcl_oow_t,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
|
||||
{
|
||||
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[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;
|
||||
@ -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_liw_t buf[HCL_SIZEOF_INTMAX_T / HCL_SIZEOF_LIW_T];
|
||||
hcl_uintmax_t ui;
|
||||
int brand;
|
||||
hcl_oop_class_t _class;
|
||||
|
||||
/* this is not a generic function. it can't handle v
|
||||
* 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)
|
||||
{
|
||||
ui = v;
|
||||
brand = HCL_BRAND_PBIGINT;
|
||||
_class = hcl->c_large_positive_integer;
|
||||
}
|
||||
else
|
||||
{
|
||||
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;
|
||||
@ -666,7 +669,7 @@ static HCL_INLINE hcl_oop_t make_bigint_with_intmax (hcl_t* hcl, hcl_intmax_t v)
|
||||
}
|
||||
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)
|
||||
@ -682,7 +685,7 @@ static HCL_INLINE hcl_oop_t make_bigint_with_uintmax (hcl_t* hcl, hcl_uintmax_t
|
||||
}
|
||||
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)
|
||||
@ -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)
|
||||
{
|
||||
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;
|
||||
}
|
||||
|
||||
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);
|
||||
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++)
|
||||
{
|
||||
@ -766,7 +774,7 @@ static HCL_INLINE hcl_oop_t expand_bigint (hcl_t* hcl, hcl_oop_t oop, hcl_oow_t
|
||||
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_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));
|
||||
if (count <= 0) count = HCL_OBJ_GET_SIZE(oop);
|
||||
|
||||
hcl_pushvolat (hcl, &_class);
|
||||
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);
|
||||
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)
|
||||
{
|
||||
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)
|
||||
{
|
||||
int brand;
|
||||
hcl_oop_class_t _class;
|
||||
|
||||
HCL_ASSERT (hcl, HCL_IS_BIGINT(hcl,oop));
|
||||
|
||||
if (HCL_IS_PBIGINT(hcl, oop))
|
||||
{
|
||||
brand = HCL_BRAND_NBIGINT;
|
||||
_class = hcl->c_large_negative_integer;
|
||||
}
|
||||
else
|
||||
{
|
||||
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)
|
||||
{
|
||||
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)
|
||||
@ -902,7 +912,7 @@ static hcl_oop_t normalize_bigint (hcl_t* hcl, hcl_oop_t oop)
|
||||
return oop;
|
||||
}
|
||||
|
||||
return clone_bigint (hcl, oop, count);
|
||||
return clone_bigint(hcl, oop, count);
|
||||
}
|
||||
|
||||
static HCL_INLINE int is_less_unsigned_array (const hcl_liw_t* x, hcl_oow_t xs, const hcl_liw_t* y, hcl_oow_t ys)
|
||||
@ -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, &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);
|
||||
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, &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);
|
||||
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, &y);
|
||||
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, xs + ys);
|
||||
z = make_pbigint(hcl, HCL_NULL, xs + ys);
|
||||
hcl_popvolats (hcl, 2);
|
||||
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*/
|
||||
|
||||
#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)
|
||||
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
|
||||
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
|
||||
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);
|
||||
#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)
|
||||
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
|
||||
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
|
||||
hcl_popvolats (hcl, 3);
|
||||
if (!rr) return HCL_NULL;
|
||||
@ -2301,7 +2311,7 @@ hcl_oop_t hcl_addints (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y)
|
||||
if (!hcl_isbigint(hcl,y)) goto oops_einval;
|
||||
|
||||
v = HCL_OOP_TO_SMOOI(x);
|
||||
if (v == 0) return clone_bigint (hcl, y, HCL_OBJ_GET_SIZE(y));
|
||||
if (v == 0) return clone_bigint(hcl, y, HCL_OBJ_GET_SIZE(y));
|
||||
|
||||
hcl_pushvolat (hcl, &y);
|
||||
x = make_bigint_with_ooi (hcl, v);
|
||||
@ -2313,7 +2323,7 @@ hcl_oop_t hcl_addints (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y)
|
||||
if (!hcl_isbigint(hcl,x)) goto oops_einval;
|
||||
|
||||
v = HCL_OOP_TO_SMOOI(y);
|
||||
if (v == 0) return clone_bigint (hcl, x, HCL_OBJ_GET_SIZE(x));
|
||||
if (v == 0) return clone_bigint(hcl, x, HCL_OBJ_GET_SIZE(x));
|
||||
|
||||
hcl_pushvolat (hcl, &x);
|
||||
y = make_bigint_with_ooi (hcl, v);
|
||||
@ -2408,7 +2418,7 @@ hcl_oop_t hcl_subints (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y)
|
||||
if (v == 0)
|
||||
{
|
||||
/* switch the sign to the opposite and return it */
|
||||
return clone_bigint_negated (hcl, y, HCL_OBJ_GET_SIZE(y));
|
||||
return clone_bigint_negated(hcl, y, HCL_OBJ_GET_SIZE(y));
|
||||
}
|
||||
|
||||
hcl_pushvolat (hcl, &y);
|
||||
@ -2421,7 +2431,7 @@ hcl_oop_t hcl_subints (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y)
|
||||
if (!hcl_isbigint(hcl,x)) goto oops_einval;
|
||||
|
||||
v = HCL_OOP_TO_SMOOI(y);
|
||||
if (v == 0) return clone_bigint (hcl, x, HCL_OBJ_GET_SIZE(x));
|
||||
if (v == 0) return clone_bigint(hcl, x, HCL_OBJ_GET_SIZE(x));
|
||||
|
||||
hcl_pushvolat (hcl, &x);
|
||||
y = make_bigint_with_ooi (hcl, v);
|
||||
@ -2523,9 +2533,9 @@ hcl_oop_t hcl_mulints (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y)
|
||||
case 0:
|
||||
return HCL_SMOOI_TO_OOP(0);
|
||||
case 1:
|
||||
return clone_bigint (hcl, y, HCL_OBJ_GET_SIZE(y));
|
||||
return clone_bigint(hcl, y, HCL_OBJ_GET_SIZE(y));
|
||||
case -1:
|
||||
return clone_bigint_negated (hcl, y, HCL_OBJ_GET_SIZE(y));
|
||||
return clone_bigint_negated(hcl, y, HCL_OBJ_GET_SIZE(y));
|
||||
}
|
||||
|
||||
hcl_pushvolat (hcl, &y);
|
||||
@ -2543,9 +2553,9 @@ hcl_oop_t hcl_mulints (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y)
|
||||
case 0:
|
||||
return HCL_SMOOI_TO_OOP(0);
|
||||
case 1:
|
||||
return clone_bigint (hcl, x, HCL_OBJ_GET_SIZE(x));
|
||||
return clone_bigint(hcl, x, HCL_OBJ_GET_SIZE(x));
|
||||
case -1:
|
||||
return clone_bigint_negated (hcl, x, HCL_OBJ_GET_SIZE(x));
|
||||
return clone_bigint_negated(hcl, x, HCL_OBJ_GET_SIZE(x));
|
||||
}
|
||||
|
||||
hcl_pushvolat (hcl, &x);
|
||||
@ -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, &y);
|
||||
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, zalloc);
|
||||
z = make_pbigint(hcl, HCL_NULL, zalloc);
|
||||
hcl_popvolats (hcl, 2);
|
||||
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, &y);
|
||||
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, zalloc);
|
||||
z = make_pbigint(hcl, HCL_NULL, zalloc);
|
||||
hcl_popvolats (hcl, 2);
|
||||
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, &y);
|
||||
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, zalloc);
|
||||
z = make_pbigint(hcl, HCL_NULL, zalloc);
|
||||
hcl_popvolats (hcl, 2);
|
||||
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);
|
||||
z = hcl_makebigint(hcl, HCL_BRAND_PBIGINT, HCL_NULL, zalloc);
|
||||
z = make_pbigint(hcl, HCL_NULL, zalloc);
|
||||
hcl_popvolat (hcl);
|
||||
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);
|
||||
/* +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);
|
||||
if (!z) return HCL_NULL;
|
||||
|
||||
@ -3981,7 +3991,7 @@ static HCL_INLINE hcl_oop_t rshift_positive_bigint_and_normalize (hcl_t* hcl, hc
|
||||
zs = HCL_OBJ_GET_SIZE(x);
|
||||
|
||||
hcl_pushvolat (hcl, &y);
|
||||
z = clone_bigint (hcl, x, zs);
|
||||
z = clone_bigint(hcl, x, zs);
|
||||
hcl_popvolat (hcl);
|
||||
if (!z) return HCL_NULL;
|
||||
|
||||
@ -4192,7 +4202,7 @@ hcl_oop_t hcl_bitshiftint (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y)
|
||||
if (!hcl_isbigint(hcl,x)) goto oops_einval;
|
||||
|
||||
v = HCL_OOP_TO_SMOOI(y);
|
||||
if (v == 0) return clone_bigint (hcl, x, HCL_OBJ_GET_SIZE(x));
|
||||
if (v == 0) return clone_bigint(hcl, x, HCL_OBJ_GET_SIZE(x));
|
||||
|
||||
negx = HCL_IS_NBIGINT(hcl, x);
|
||||
if (v > 0)
|
||||
@ -4279,12 +4289,12 @@ hcl_oop_t hcl_bitshiftint (hcl_t* hcl, hcl_oop_t x, hcl_oop_t y)
|
||||
|
||||
if (negx)
|
||||
{
|
||||
z = rshift_negative_bigint (hcl, x, shift);
|
||||
z = rshift_negative_bigint(hcl, x, shift);
|
||||
if (!z) return HCL_NULL;
|
||||
}
|
||||
else
|
||||
{
|
||||
z = clone_bigint (hcl, x, HCL_OBJ_GET_SIZE(x));
|
||||
z = clone_bigint(hcl, x, HCL_OBJ_GET_SIZE(x));
|
||||
if (!z) return HCL_NULL;
|
||||
rshift_unsigned_array (((hcl_oop_liword_t)z)->slot, HCL_OBJ_GET_SIZE(z), shift);
|
||||
}
|
||||
@ -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
|
||||
#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);
|
||||
|
||||
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))
|
||||
{
|
||||
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))
|
||||
{
|
||||
|
||||
@ -568,12 +568,7 @@ static hcl_oop_process_t make_process (hcl_t* hcl, hcl_oop_context_t c)
|
||||
return HCL_NULL;
|
||||
}
|
||||
|
||||
#if 0
|
||||
////////////////////
|
||||
//// HCL_OBJ_SET_FLAGS_PROC (proc, proc_flags); /* a special flag to indicate an object is a process instance */
|
||||
////////////////////
|
||||
#endif
|
||||
|
||||
HCL_OBJ_SET_FLAGS_PROC (proc, 1); /* a special flag to indicate an object is a process instance */
|
||||
proc->state = HCL_SMOOI_TO_OOP(HCL_PROCESS_STATE_SUSPENDED);
|
||||
|
||||
/* assign a process id to the process */
|
||||
|
||||
32
lib/gc.c
32
lib/gc.c
@ -622,7 +622,7 @@ static kernel_class_info_t kernel_classes[__KCI_MAX__] =
|
||||
KCI(KCI_LARGE_POSITIVE_INTEGER) {
|
||||
"LargePositiveInteger",
|
||||
KCI_NUMBER,
|
||||
0,
|
||||
HCL_BRAND_PBIGINT,
|
||||
HCL_CLASS_SELFSPEC_FLAG_LIMITED,
|
||||
0,
|
||||
0,
|
||||
@ -634,7 +634,7 @@ static kernel_class_info_t kernel_classes[__KCI_MAX__] =
|
||||
KCI(KCI_LARGE_NEGATIVE_INTEGER) {
|
||||
"LargeNegativeInteger",
|
||||
KCI_NUMBER,
|
||||
0,
|
||||
HCL_BRAND_NBIGINT,
|
||||
HCL_CLASS_SELFSPEC_FLAG_LIMITED,
|
||||
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
|
||||
* determine that it is an instance of process? */
|
||||
/* 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???*/
|
||||
if (HCL_UNLIKELY(HCL_OBJ_GET_FLAGS_PROC(oop)))
|
||||
{
|
||||
hcl_oop_process_t proc;
|
||||
|
||||
HCL_ASSERT (hcl, HCL_IS_PROCESS(hcl, oop));
|
||||
/* the stack in a process object doesn't need to be
|
||||
* scanned in full. the slots above the stack pointer
|
||||
* are garbages. */
|
||||
@ -886,13 +886,14 @@ static HCL_INLINE void gc_ms_scan_stack (hcl_t* hcl)
|
||||
|
||||
/* stack */
|
||||
ll = HCL_OOP_TO_SMOOI(proc->sp);
|
||||
|
||||
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]);
|
||||
|
||||
/* exception stack */
|
||||
ll = HCL_OOP_TO_SMOOI(proc->exsp);
|
||||
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]);
|
||||
|
||||
/* class stack */
|
||||
ll = HCL_OOP_TO_SMOOI(proc->clsp);
|
||||
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.
|
||||
* 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);
|
||||
if (HCL_UNLIKELY(!hcl->nil_process)) goto oops;
|
||||
/*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_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 */
|
||||
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)
|
||||
{
|
||||
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_allocoopobj(hcl, HCL_BRAND_PROCESS_SCHEDULER, HCL_PROCESS_SCHEDULER_NAMED_INSTVARS);*/
|
||||
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->total_count = HCL_SMOOI_TO_OOP(0);
|
||||
hcl->processor->runnable.count = HCL_SMOOI_TO_OOP(0);
|
||||
|
||||
57
lib/hcl.h
57
lib/hcl.h
@ -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_FLEXI_BITS (1) /* 30 */
|
||||
#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_MOVED_BITS 2
|
||||
#define HCL_OBJ_FLAGS_PROC_BITS 2
|
||||
#define HCL_OBJ_FLAGS_GCFIN_BITS 4
|
||||
#define HCL_OBJ_FLAGS_TRAILER_BITS 1
|
||||
#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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_NBIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_NBIGINT)
|
||||
#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_FPDEC(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FPDEC)
|
||||
/*#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_CLASSOF(hcl,v) == (hcl_oop_t)(hcl)->c_large_positive_integer)
|
||||
/*#define HCL_IS_NBIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_NBIGINT)*/
|
||||
#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_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_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_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_CDR(v) (((hcl_cons_t*)(v))->cdr)
|
||||
@ -2147,7 +2153,6 @@ typedef int (*hcl_dic_walker_t) (
|
||||
void* ctx
|
||||
);
|
||||
|
||||
|
||||
typedef int (*hcl_xchg_reader_t) (
|
||||
hcl_t* hcl,
|
||||
void* buf,
|
||||
@ -2974,14 +2979,6 @@ HCL_EXPORT hcl_oop_t hcl_makeprim (
|
||||
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_t* hcl,
|
||||
hcl_oow_t w
|
||||
|
||||
28
lib/obj.c
28
lib/obj.c
@ -286,30 +286,6 @@ hcl_oop_t hcl_hatchnil (hcl_t* hcl)
|
||||
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)
|
||||
{
|
||||
/* 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);
|
||||
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);
|
||||
|
||||
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->scale = HCL_SMOOI_TO_OOP(scale);
|
||||
HCL_OBJ_SET_CLASS (f, (hcl_oop_t)hcl->c_fixed_point_decimal);
|
||||
}
|
||||
|
||||
return (hcl_oop_t)f;
|
||||
|
||||
@ -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 */
|
||||
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;
|
||||
|
||||
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 */
|
||||
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;
|
||||
|
||||
for (j = 0; j < nwords; j++)
|
||||
|
||||
@ -47,4 +47,3 @@ if (== z1 101) { printf "OK: z1 is %d\n" z1 } \
|
||||
else { printf "ERROR: z1 is not 101 - %d\n" z1 }
|
||||
if (== z2 100) { printf "OK: z2 is %d\n" z2 } \
|
||||
else { printf "ERROR: z1 is not 100 - %d\n" z2 }
|
||||
|
||||
|
||||
19
t/ret-01.hcl
19
t/ret-01.hcl
@ -1,11 +1,11 @@
|
||||
defun repeat(n f) {
|
||||
fun repeat(n f) {
|
||||
while (> n 0) {
|
||||
f;
|
||||
set n (- n 1);
|
||||
};
|
||||
};
|
||||
|
||||
defun test-non-local-ret-1(k) {
|
||||
fun test-non-local-ret-1(k) {
|
||||
repeat 10 (fun() {
|
||||
set k (+ k 2);
|
||||
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" } \
|
||||
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
|
||||
set a (ff);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user