## core-two-word-int.pkg
## Author: Matthias Blume (blume@tti-c.org)
# Compiled by:
# src/lib/core/init/init.cmi
# Basic (simulated) 64-bit integer support.
### "But we are all that way:
### when we know a thing
### we have only scorn for other people
### who don't happen to know it."
###
### -- Mark Twain,
### Personal Recollections of Joan of Arc
package core_two_word_int {
#
stipulate
# inline is from src/lib/compiler/front/semantic/symbolmapstack/base-types-and-ops.pkg package cii = core_multiword_int;
infix my o; (o) = inline::compose;
infix my 80 * ; (*) = inline::u1_mul;
infix my 70 + - ; (+) = inline::u1_add; (-) = inline::u1_subtract;
infix my 60 << >> >>> ; (<<) = inline::u1_lshift; (>>) = inline::u1_rshiftl;
infix my 60 & ; (&) = inline::u1_bitwise_and;
infix my 50 < ; (<) = inline::u1_lt;
infix my 50 != ; (!=) = inline::u1_ne;
infix my 50 ==== ; (====) = inline::u1_eq;
not = inline::not_macro;
(-_) = inline::u1_negate;
neg = inline::u1_negate;
(^_) = inline::u1_bitwise_not;
fun lift1' f = f o inline::i64p;
fun lift1 f = inline::p64i o lift1' f;
fun lift2' f (x, y) = f (inline::i64p x, inline::i64p y);
fun lift2 f = inline::p64i o lift2' f;
fun neg64 (0ux80000000, 0u0) => raise exception runtime::OVERFLOW;
neg64 (hi, 0u0) => (-hi, 0u0);
neg64 (hi, lo) => (^hi, -lo);
end;
fun negbit hi = hi & 0ux80000000;
fun isneg hi = negbit hi != 0u0;
fun add64 ((hi1, lo1), (hi2, lo2))
=
{ hi = hi1 + hi2;
lo = lo1 + lo2;
hi = if (lo < lo1) hi + 0u1;
else hi;
fi;
nb1 = negbit hi1;
if (nb1 != negbit hi2
or nb1 ==== negbit hi)
(hi, lo);
else
raise exception runtime::OVERFLOW;
fi;
};
fun sub64 ((hi1, lo1), (hi2, lo2))
=
{ hi = hi1 - hi2;
lo = lo1 - lo2;
hi = if (lo1 < lo) hi - 0u1;
else hi;
fi;
nb1 = negbit hi1;
if (nb1 ==== negbit hi2
or nb1 ==== negbit hi)
(hi, lo);
else
raise exception runtime::OVERFLOW;
fi;
};
# I am definitely too lazy to do
# this the pedestrian way, so
# here we go: XXX BUGGO FIXME
#
fun mul64 (x, y)
=
cii::test_inf64 ((cii::(*)) (cii::extend_inf64 x, cii::extend_inf64 y));
fun div64 (_, (0u0, 0u0)) => raise exception runtime::DIVIDE_BY_ZERO;
div64 (x, (0u0, 0u1)) => x;
div64 (x, (0uxffffffff, 0uxffffffff)) => neg64 x;
div64 (x, y) =>
# Again, the easy way out...
cii::trunc_inf64 (cii::div (cii::extend_inf64 x, cii::extend_inf64 y));
end;
fun mod64 (x, y)
=
sub64 (x, mul64 (div64 (x, y), y));
fun swap (x, y) = (y, x);
fun lt64 ((hi1, lo1), (hi2, lo2))
=
{ fun normal ()
=
hi1 < hi2 or (hi1 ==== hi2 and lo1 < lo2);
if (isneg hi1)
if (isneg hi2) normal ();
else TRUE;
fi;
else
normal ();
fi;
};
gt64 = lt64 o swap;
le64 = not o gt64;
ge64 = not o lt64;
fun abs64 (hi, lo)
=
if (isneg hi) neg64 (hi, lo);
else (hi, lo);
fi;
herein
extern = inline::i64p;
intern = inline::p64i;
neg = lift1 neg64;
(-_) = lift1 neg64;
(+) = lift2 add64;
(-) = lift2 sub64;
(*) = lift2 mul64;
div = lift2 div64;
mod = lift2 mod64;
(<) = lift2' lt64;
<= = lift2' le64;
> = lift2' gt64;
>= = lift2' ge64;
abs = lift1 abs64;
end;
};