## two-word-int.pkg
#
# 64-bit integers on 32-bit architectures, 128-bit integers on 64-bit architectures.
# Compiled by:
# src/lib/std/src/standard-core.sublib### "The difference between the right word
### and the almost right word is the difference
### between lightning and a lightning bug."
###
### -- Mark Twain
stipulate
package lms = list_mergesort; # list_mergesort is from src/lib/src/list-mergesort.pkg package pb = proto_basis; # proto_basis is from src/lib/std/src/proto-basis.pkg package rt = runtime; # runtime is from src/lib/core/init/runtime.pkg package ti = inline_t::ti; # "ti" == "tagged_int".
herein
package two_word_int: (weak) Int { # Int is from src/lib/std/src/int.api # # inline_t is from src/lib/core/init/built-in.pkg Int = two_word_int::Int;
# "i2" == "two-word int": 64-bits on 32-bit architectures, 128-bits on 64-bit architectures.
extern = inline_t::i2::extern;
intern = inline_t::i2::intern;
precision = THE 64; # 64-bit issue -- this will be 128 on 64-bit architectures.
my min_int_val: Int = -0x8000000000000000; # 64-bit issue.
my min_int: Null_Or( Int ) = THE min_int_val;
my max_int: Null_Or( Int ) = THE 0x7fffffffffffffff; # 64-bit issue.
to_multiword_int = core_multiword_int::extend_inf64 o core_two_word_int::extern;
from_multiword_int = core_two_word_int::intern o core_multiword_int::test_inf64;
fun negbit hi = one_word_unt_guts::bitwise_and (hi, 0ux80000000); # 64-bit issue.
fun isneg hi = negbit hi != 0u0;
fun to_int i
=
{ mask = 0uxc0000000; # 64-bit issue.
#
case (extern i)
#
(0u0, lo)
=>
if (one_word_unt_guts::bitwise_and (lo, mask) == 0u0)
#
one_word_unt_guts::to_int lo;
else
raise exception rt::OVERFLOW;
fi;
#
(0uxffffffff, lo) # 64-bit issue.
=>
if (one_word_unt_guts::bitwise_and (lo, mask) == mask)
#
one_word_unt_guts::to_int_x lo;
else
raise exception rt::OVERFLOW;
fi;
_ => raise exception rt::OVERFLOW;
esac;
};
fun from_int tagged_int
=
{ i32 = one_word_int_guts::from_int tagged_int;
#
hi = if (i32 < 0) 0uxffffffff; # 64-bit issue.
else 0u0;
fi;
#
intern (hi, inline_t::u1::copyf_int1 i32);
};
fun quot (x, y)
=
from_multiword_int (multiword_int_guts::quot (to_multiword_int x, to_multiword_int y));
fun rem (x, y)
=
x - quot (x, y) * y;
fun sign 0 => 0;
sign i => if (isneg (#1 (extern i))) -1;
else 1;
fi;
end;
fun same_sign (x, y)
=
sign x == sign y;
fun min (x: Int, y) = if (x < y) x; else y; fi;
fun max (x: Int, y) = if (x > y) x; else y; fi;
fun compare (x, y)
=
{ my (hi1, lo1) = extern x;
my (hi2, lo2) = extern y;
fun normal () # same-sign case
=
if (hi1 < hi2) LESS;
elif (hi1 > hi2) GREATER;
elif (lo1 < lo2) LESS;
elif (lo1 > lo2) GREATER;
else EQUAL;
fi;
if (isneg hi1)
if (isneg hi2 ) normal ();
else LESS;
fi;
elif (isneg hi2 ) GREATER;
else normal ();
fi;
};
fun format rdx i
=
multiword_int_guts::format rdx (to_multiword_int i);
to_string = format number_string::DECIMAL;
fun scan rdx rdr s
=
case (multiword_int_guts::scan rdx rdr s)
#
THE (i, s')
=>
if (i < -0x80000000 or i > 0x7fffffff) # 64-bit issue.
#
raise exception rt::OVERFLOW;
else
THE (intern (core_multiword_int::trunc_inf64 i), s');
fi;
NULL => NULL;
esac;
from_string
=
pb::scan_string (scan number_string::HEX);
my (-_) : Int -> Int = (-_);
my neg : Int -> Int = (-_);
my (+) : (Int, Int) -> Int = (+);
my (-) : (Int, Int) -> Int = (-);
my (*) : (Int, Int) -> Int = (*);
my (/) : (Int, Int) -> Int = (/);
my (%) : (Int, Int) -> Int = (%);
my abs : Int -> Int = abs;
my (<) : (Int, Int) -> Bool = (<);
my (<=) : (Int, Int) -> Bool = (<=);
my (>) : (Int, Int) -> Bool = (>);
my (>=) : (Int, Int) -> Bool = (>=);
fun 0! => 1;
n! => n * (n - 1)! ;
end;
fun is_prime p # A very simple and naive primality tester. 2009-09-02 CrT.
=
{ p = abs(p); # Try to do something reasonable with negative numbers.
if (p < 4) TRUE; # Call zero prime.
elif (p % 2 == 0) FALSE; # Special-case even numbers to halve our loop time.
else
# Test all odd numbers less than sqrt(p):
loop 3
where
fun loop i
=
if (p % i == 0) FALSE;
elif (i*i >= p) TRUE;
else loop (i + 2);
fi;
end;
fi;
};
fun factors n
=
factors' (n, 2, [])
where
fun factors' (n, p, results)
=
if (p*p > n)
#
reverse (n ! results);
elif (n % p == 0)
factors' (n/p, p, p ! results);
else
factors' (n, p+1, results);
fi;
end;
fun sum ints
=
sum' (ints, 0)
where
fun sum' ( [], result) => result;
sum' (i ! rest, result) => sum' (rest, i + result);
end;
end;
fun product ints
=
product' (ints, 1)
where
fun product' ( [], result) => result;
product' (i ! rest, result) => product' (rest, i * result);
end;
end;
fun list_min [] => raise exception DIE "Cannot do list_min on empty list";
#
list_min (i ! ints)
=>
min' (ints, i: Int)
where
fun min' ( [], result) => result;
min' (i ! rest, result) => min' (rest, i < result ?? i :: result);
end;
end;
end;
fun list_max [] => raise exception DIE "Cannot do list_max on empty list";
#
list_max (i ! ints)
=>
min' (ints, i: Int)
where
fun min' ( [], result) => result;
min' (i ! rest, result) => min' (rest, i > result ?? i :: result);
end;
end;
end;
fun sort ints
=
lms::sort_list (>) ints;
fun sort_and_drop_duplicates ints
=
lms::sort_list_and_drop_duplicates compare ints;
fun mean [] => 0; # Would throwing an exception be better? In graphics, at least, often it is better to just gloss over the occasional special case...
mean ints => sum ints / from_int (length ints);
end;
fun median []
=>
0; # As above, arbitrary, possibly should throw exception.
median ints
=>
{ len = length ints;
ints = lms::sort_list (>) ints;
#
i1 = ti::div (len, 2);
i2 = ti::(-) (i1, 1);
if (is_odd(len))
#
# Return middle element:
#
list::nth (ints, i1);
else
# Return average of the two middle elements:
#
n1 = list::nth (ints, i1);
n2 = list::nth (ints, i2);
(n1 + n2) / 2;
fi;
}
where
fun is_odd(i) = (ti::bitwise_and(i, 1) == 1);
end;
end;
};
end;