## two-word-unt.pkg
#
# Two-word unt ("unsigned int") -- 64-bit unt on 32-bit architectures, 128-bit unt on 64-bit architectures.
# Compiled by:
# src/lib/std/src/standard-core.sublib# 64-bit word support
### "I am a Bear of very little brain,
### and long words bother me."
###
### -- Winnie the Pooh
stipulate
package it = inline_t; # inline_t is from src/lib/core/init/built-in.pkg package lms = list_mergesort; # list_mergesort is from src/lib/src/list-mergesort.pkg package nst = number_string; # number_string is from src/lib/std/src/number-string.pkg package pb = proto_basis; # proto_basis is from src/lib/std/src/proto-basis.pkgherein
package two_word_unt: (weak) Unt { # Unt is from src/lib/std/src/unt.api #
package u1 = one_word_unt_guts; # one_word_unt_guts is from src/lib/std/src/one-word-unt-guts.pkg Unt = two_word_unt::Unt;
extern = it::u2::extern;
intern = it::u2::intern;
unt_size = 64; # 64-bit issue: This will be 128 on 64-bit architectures.
fun unimplemented _
=
raise exception DIE "unimplemented";
to_large_unt = unimplemented; # XXX SUCKO FIXME
to_large_unt_x = unimplemented; # XXX SUCKO FIXME
from_large_unt = unimplemented; # XXX SUCKO FIXME
to_multiword_int = core_multiword_int::copy_inf64 o extern;
to_multiword_int_x = core_multiword_int::extend_inf64 o extern;
#
from_multiword_int = intern o core_multiword_int::trunc_inf64;
fun to_int w
=
case (extern w)
#
(0u0, lo) => u1::to_int lo;
_ => raise exception OVERFLOW;
esac;
fun to_int_x w = u1::to_int_x (#2 (extern w));
fun from_int i = intern (if (i < 0 ) 0uxffffffff; else 0u0;fi, u1::from_int i);
fun bitwise f (w1, w2)
=
{ my (hi1, lo1) = extern w1;
my (hi2, lo2) = extern w2;
#
intern (f (hi1, hi2), f (lo1, lo2));
};
bitwise_or = bitwise u1::bitwise_or;
bitwise_xor = bitwise u1::bitwise_xor;
bitwise_and = bitwise u1::bitwise_and;
fun bitwise_not w
=
{ (extern w) -> (hi, lo);
#
intern (u1::bitwise_not hi, u1::bitwise_not lo);
};
fun compare (w1, w2)
=
{ (extern w1) -> (hi1, lo1);
(extern w2) -> (hi2, lo2);
if (hi1 > hi2) GREATER;
elif (hi1 < hi2) LESS;
elif (lo1 > lo2) GREATER;
elif (lo1 < lo2) LESS;
else EQUAL;
fi;
};
fun (<<) (w64, w)
=
if (w >= 0u64 ) 0u0; # 64-bit issue.
elif (w > 0u32 ) intern (u1::(<<) (#2 (extern w64), w - 0u32), 0u0); # 64-bit issue.
elif (w == 0u32) intern (#2 (extern w64), 0u0); # 64-bit issue.
elif (w == 0u0 ) w64;
else
my (hi, lo) = extern w64;
intern (u1::bitwise_or (u1::(<<) (hi, w), u1::(>>) (lo, 0u32 - w)), # 64-bit issue.
u1::(<<) (lo, w));
fi;
fun (>>) (w64, w)
=
if (w >= 0u64) 0u0;
elif (w > 0u32 ) intern (0u0, u1::(>>) (#1 (extern w64), w - 0u32)); # 64-bit issue.
elif (w == 0u32) intern (0u0, #1 (extern w64)); # 64-bit issue.
elif (w == 0u0 ) w64;
else my (hi, lo) = extern w64;
intern (u1::(>>) (hi, w),
u1::bitwise_or (u1::(>>) (lo, w), u1::(<<) (hi, 0u32 - w))); # 64-bit issue.
fi;
fun (>>>) (w64, w)
=
if (w == 0u0) w64;
else
(extern w64) -> (hi, lo);
if (w >= 0u63 ) # 64-bit issue.
x = u1::(>>>) (hi, 0u31); # 64-bit issue.
intern (x, x);
elif (w > 0u32 ) # 64-bit issue.
intern (u1::(>>>) (hi, 0u31), u1::(>>>) (hi, w - 0u32)); # 64-bit issue.
elif (w == 0u32 )
intern (u1::(>>>) (hi, 0u31), hi); # 64-bit issue.
else
intern (u1::(>>>) (hi, w),
u1::bitwise_or (u1::(>>) (lo, w), u1::(<<) (hi, 0u32 - w))); # 64-bit issue.
fi;
fi;
fun min (w1: Unt, w2) = if (w1 > w2) w1; else w2; fi;
fun max (w1: Unt, w2) = if (w1 > w2) w1; else w2; fi;
fun to_string w
=
case (extern w)
#
(0u0, lo) => u1::to_string lo;
(hi, lo) =>
{ my (hi, lo) = extern w;
u1::to_string hi + (nst::pad_left '0' 8 (u1::to_string lo));
};
esac;
fun format nst::BINARY w
=>
case (extern w)
#
(0u0, lo)
=>
u1::format nst::BINARY lo;
#
(hi, lo)
=>
{ u1bin = u1::format nst::BINARY;
#
u1bin hi + (nst::pad_left '0' 32 (u1bin lo)); # 64-bit issue.
};
esac;
format nst::HEX w
=>
to_string w;
format rdx w
=>
multiword_int_guts::format rdx (to_multiword_int w); # Lazy way.
end;
# piggy-back on integer...
#
fun scan rdx rdr s
=
{ fun doword s
=
multiword_int_guts::scan rdx rdr s;
xok = rdx == nst::HEX;
fun startscan s0
=
case (rdr s0)
#
THE ('0', s1)
=>
{ fun wordor0 s
=
case (doword s)
#
NULL => THE (0, s1);
THE (i, s') => THE (i, s');
esac;
fun saww s
=
case (rdr s)
#
THE ('x', s')
=>
if xok wordor0 s';
else THE (0, s1);
fi;
_ => wordor0 s;
esac;
case (rdr s1)
#
THE ('w', s2) => saww s2;
#
THE ('x', s2)
=>
if xok wordor0 s2;
else THE (0, s1);
fi;
_ => doword s0;
esac;
};
_ => doword s0;
esac;
case (startscan s)
#
THE (i, s')
=>
if (i < 0 ) NULL;
elif (i > 0xffffffffffffffff) raise exception OVERFLOW; # 64-bit issue.
else THE (from_multiword_int i, s');
fi;
NULL => NULL;
esac;
};
from_string
=
pb::scan_string (scan nst::HEX);
my (*) : (Unt, Unt) -> Unt = (*);
my (+) : (Unt, Unt) -> Unt = (+);
my (-) : (Unt, Unt) -> Unt = (-);
my (/) : (Unt, Unt) -> Unt = (/);
my (%) : (Unt, Unt) -> Unt = (%);
my (-_) : Unt -> Unt = (-_);
my (<) : (Unt, Unt) -> Bool = (<);
my (<=) : (Unt, Unt) -> Bool = (<=);
my (>) : (Unt, Unt) -> Bool = (>);
my (>=) : (Unt, Unt) -> Bool = (>=);
fun sum unts
=
sum' (unts, 0u0)
where
fun sum' ( [], result) => result;
sum' (u ! rest, result) => sum' (rest, u + result);
end;
end;
fun product unts
=
product' (unts, 0u1)
where
fun product' ( [], result) => result;
product' (u ! rest, result) => product' (rest, u * result);
end;
end;
fun list_min [] => raise exception DIE "Cannot do list_min on empty list";
#
list_min (u ! unts)
=>
min' (unts, u: Unt)
where
fun min' ( [], result) => result;
min' (u ! rest, result) => min' (rest, u < result ?? u :: result);
end;
end;
end;
fun list_max [] => raise exception DIE "Cannot do list_max on empty list";
#
list_max (u ! unts)
=>
min' (unts, u: Unt)
where
fun min' ( [], result) => result;
min' (u ! rest, result) => min' (rest, u > result ?? u :: result);
end;
end;
end;
fun sort unts
=
lms::sort_list (>) unts;
fun sort_and_drop_duplicates unts
=
lms::sort_list_and_drop_duplicates compare unts;
};
end;