## core-two-word-unt.pkg
## Author: Matthias Blume (blume@tti-c.org)
# Compiled by:
# src/lib/core/init/init.cmi
# Basic (simulated) 64-bit word support.
### "I don't think there ever was a lazy man in this world.
###
### "Every man has some sort of gift, and he prizes that gift
### beyond all others. He may be a professional billiard-player,
### or a Paderewski, or a poet -- I don't care what it is.
###
### "But whatever it is, he takes a native delight in exploiting that gift,
### and you will find it is difficult to beguile him away from it.
###
### "Well, there are thousands of other interests occupying other men,
### but those interests don't appeal to the special tastes of
### the billiard champion or Paderewski. They are set down, therefore,
### as too lazy to do that or do this -- to do, in short what they have
### no taste or inclination to do.
###
### "In that sense, then I am phenomenally lazy.
###
### "But when it comes to writing a book--I am not lazy.
### My family find it difficult to dig me out of my chair."
###
### -- Mark Twain,
### quoted in Sydney Morning Herald,
### 9/17/1895
package core_two_word_unt {
# # inline is from src/lib/compiler/front/semantic/symbolmapstack/base-types-and-ops.pkg stipulate
infix my o; (o) = inline::compose;
not = inline::not_macro;
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;
fun lift1' f = f o inline::u64p;
fun lift1 f = inline::p64u o lift1' f;
fun lift2' f (x, y) = f (inline::u64p x, inline::u64p y);
fun lift2 f = inline::p64u o lift2' f;
fun split16 w32
=
(w32 >> 0u16, w32 & 0uxffff);
fun neg64 (hi, 0u0) => (inline::u1_negate hi, 0u0);
neg64 (hi, lo ) => (inline::u1_bitwise_not hi, inline::u1_negate lo);
end;
fun add64 ((hi1, lo1), (hi2, lo2))
=
{ lo = lo1 + lo2;
hi = hi1 + hi2;
( lo < lo1 ?? hi + 0u1
:: hi,
lo
);
};
fun sub64 ((hi1, lo1), (hi2, lo2))
=
{ lo = lo1 - lo2;
hi = hi1 - hi2;
( lo1 < lo ?? hi - 0u1
:: hi,
lo
);
};
fun mul64 ((hi1, lo1), (hi2, lo2))
=
{ my ((a1, b1), (c1, d1)) = (split16 hi1, split16 lo1);
my ((a2, b2), (c2, d2)) = (split16 hi2, split16 lo2);
dd = d1 * d2;
my (cd, dc) = (c1 * d2, d1 * c2);
my (bd, cc, db) = (b1 * d2, c1 * c2, d1 * b2);
my (ad, bc, cb, da) = (a1 * d2, b1 * c2, c1 * b2, d1 * a2);
diag0 = dd;
diag1 = cd + dc;
diag1carry = if (diag1 < cd ) 0ux10000; else 0u0;fi;
diag2 = bd + cc + db;
diag3 = ad + bc + cb + da;
lo = diag0 + (diag1 << 0u16);
locarry = if (lo < diag0 ) 0u1; else 0u0;fi;
hi = (diag1 >> 0u16) + diag2 + (diag3 << 0u16)
+ locarry + diag1carry;
(hi, lo);
};
stipulate
package cii = core_multiword_int;
up = cii::copy_inf64;
dn = cii::trunc_inf64;
herein
# This is even more inefficient
# than doing it the hard way,
# but I am lazy... XXX BUGGO FIXME
#
fun div64 (x, y)
=
dn (cii::div (up x, up 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))
=
hi1 < hi2 or (inline::u1_eq (hi1, hi2) and lo1 < lo2);
gt64 = lt64 o swap;
le64 = not o gt64;
ge64 = not o lt64;
herein
extern = inline::u64p;
intern = inline::p64u;
(-_) = lift1 neg64;
neg = lift1 neg64;
(+) = lift2 add64;
(-) = lift2 sub64;
(*) = lift2 mul64;
div = lift2 div64;
mod = lift2 mod64;
(<) = lift2' lt64;
<= = lift2' le64;
> = lift2' gt64;
>= = lift2' ge64;
end;
};