## time-guts.pkg
# Compiled by:
# src/lib/std/src/standard-core.sublib# Wrapped by:
# src/lib/std/time.pkg### "As for myself, I have no difficulty in believing
### that our newspapers will by & by contain news,
### not 24 hours old from Jupiter et al- mainly
### astronomical corrections & weather indications;
### with now & then a sarcastic fling at the only
### true religion."
###
### -- Mark Twain,
### Letter to W. D. Howells,
### 10/15/1881
stipulate
package ci = mythryl_callable_c_library_interface; # mythryl_callable_c_library_interface is from src/lib/std/src/unsafe/mythryl-callable-c-library-interface.pkgherein
package time_guts: (weak)
api {
include Time; # Time is from src/lib/std/src/time.api # export these for the benefit of, e.g., posix::times:
fractions_per_second: multiword_int::Int;
to_fractions: Time -> multiword_int::Int;
from_fractions: multiword_int::Int -> Time;
}
{
package pb = pre_basis; # pre_basis is from src/lib/std/src/pre-basis.pkg package lint = large_int_imp; # large_int_imp is from src/lib/std/src/bind-largeint-32.pkg package float = eight_byte_float_guts; # eight_byte_float_guts is from src/lib/std/src/eight-byte-float-guts.pkg package int = int_guts; # int_guts is from src/lib/std/src/bind-int-32.pkg package one_word_int = one_word_int_guts; # one_word_int_guts is from src/lib/std/src/one-word-int-guts.pkg package string = string_guts; # string_guts is from src/lib/std/src/string-guts.pkg # Get time type from type-only package:
include time; # src/lib/std/types-only/basis-time.pkg exception TIME;
infix val quot; # "quot" == "quotient"
my (quot) = lint::quot;
zero_time
=
pb::TIME { usec => 0 };
my fractions_per_second: multiword_int::Int
=
1000000;
fun to_fractions (pb::TIME { usec } )
=
usec;
fun from_fractions usec
=
(pb::TIME { usec } );
# Rounding is towards ZERO:
#
fun to_seconds (pb::TIME { usec } ) = usec quot 1000000;
fun to_milliseconds (pb::TIME { usec } ) = usec quot 1000;
fun to_microseconds (pb::TIME { usec } ) = usec;
fun to_nanoseconds (pb::TIME { usec } ) = usec * 1000;
fun from_seconds sec = pb::TIME { usec => sec * 1000000 };
fun from_milliseconds msec = pb::TIME { usec => msec * 1000 };
fun from_microseconds usec = pb::TIME { usec => usec };
fun from_nanoseconds nsec = pb::TIME { usec => nsec quot 1000 };
fun from_float_seconds rsec
=
pb::TIME { usec => float::to_multiword_int ieee_float::TO_ZERO (rsec * 1.0e6) };
fun to_float_seconds (pb::TIME { usec } )
=
float::from_multiword_int usec * 1.0e-6;
stipulate
my get_time_of_day: Void -> (one_word_int::Int, Int)
=
ci::find_c_function { lib_name => "time", fun_name => "timeofday" }; # timeofday def in src/c/lib/time/timeofday.c
herein
fun get_current_time_utc ()
=
{ (get_time_of_day ())
->
(seconds, microseconds);
from_microseconds
( 1000000 * one_word_int::to_multiword_int seconds
+ int::to_multiword_int microseconds
);
};
end;
my rounding_vector: Vector( lint::Int )
=
#[50000, 5000, 500, 50, 5];
# Format time as a string:
#
# eval: time::format 0 (time::get ());
#
# "1258134720"
#
# eval: time::format 4 (time::get ());
#
# "1258134742.5852"
#
# eval: time::format 6 (time::get ());
#
# "1258134732.273621"
#
fun format precision (pb::TIME { usec } )
=
{ my (neg, usec)
=
if (usec < 0) (TRUE, -usec);
else (FALSE, usec);
fi;
fun format_int i
=
lint::format number_string::DECIMAL i;
fun format_sec (neg, i)
=
format_int (neg ?? -i :: i);
fun is_even i
=
lint::rem (i, 2) == 0;
if (precision < 0)
#
raise exception exceptions_guts::SIZE; # exceptions_guts is from src/lib/std/src/exceptions-guts.pkg elif (precision == 0)
#
(multiword_int_guts::quot_rem (usec, 1000000))
->
(seconds, microseconds);
rounded_seconds
=
case (lint::compare (usec, 500000))
#
LESS => seconds;
#
GREATER => seconds + 1;
#
EQUAL => is_even seconds ?? seconds
:: seconds + 1;
esac;
format_sec (neg, rounded_seconds);
elif (precision >= 6)
#
(multiword_int_guts::quot_rem (usec, 1000000))
->
(seconds, microseconds);
cat [ format_sec (neg, seconds),
".",
number_string::pad_left '0' 6 (format_int microseconds),
number_string::pad_left '0' (precision - 6) ""
];
else
rnd = vector::get (rounding_vector, precision - 1);
(multiword_int_guts::quot_rem (usec, 2 * rnd))
->
(whole_part, fraction_part);
rounded_whole_part
=
case (lint::compare (fraction_part, rnd))
#
LESS => whole_part;
#
GREATER => whole_part + 1;
#
EQUAL => is_even whole_part ?? whole_part
:: whole_part + 1;
esac;
rscl = 2 * vector::get (rounding_vector, 5 - precision);
my (seconds, fractional_seconds)
=
multiword_int_guts::quot_rem (rounded_whole_part, rscl);
cat [ format_sec (neg, seconds),
".",
number_string::pad_left '0' precision (format_int fractional_seconds)
];
fi;
};
# Scan a time value.
# Supported syntax is:
#
# [+-~]?([0-9]+(.[0-9]+)? | .[0-9]+)
#
fun scan getc s
=
{ fun digv c
=
int::to_multiword_int (char::to_int c - char::to_int '0');
fun whole s
=
loop (s, 0, 0, fn _ = NULL)
where
fun loop (s, n, m, ret)
=
case (getc s)
NULL
=>
ret (n, s, m);
THE (c, s')
=>
if (char::is_digit c)
loop (s', 10 * n + digv c, m + 1, THE);
else
ret (n, s, m);
fi;
esac;
end;
fun time (negative, s)
=
{ fun pow10 p
=
multiword_int_guts::pow (10, p);
fun return (usec, s)
=
THE ( from_microseconds (negative ?? -usec
:: usec),
s
);
fun fractional (wh, s)
=
case (whole s)
THE (n, s, m)
=>
{ fun done fr
=
return (wh * 1000000 + fr, s);
if (m > 6 ) done (n / pow10 (m - 6));
elif (m < 6 ) done (n * pow10 (6 - m));
else done n;
fi;
};
NULL => NULL;
esac;
fun withwhole s
=
case (whole s)
NULL => NULL;
THE (wh, s', _)
=>
case (getc s')
THE ('.', s'')
=>
fractional (wh, s'');
_ =>
return (wh * 1000000, s');
esac;
esac;
case (getc s)
#
NULL => NULL;
THE ('.', s') => fractional (0, s');
_ => withwhole s;
esac;
}; # fun time
fun sign s
=
case (getc s)
#
NULL => NULL;
THE ('-', s') => time (TRUE, s');
THE ('+', s') => time (FALSE, s');
_ => time (FALSE, s);
esac;
sign (number_string::skip_ws getc s);
};
to_string = format 3;
from_string = pb::scan_string scan;
stipulate
fun binop usec_oper ( pb::TIME t1,
pb::TIME t2
)
=
usec_oper ( t1.usec,
t2.usec
);
herein
my (+) = binop (from_microseconds o (+) );
my (-) = binop (from_microseconds o (-) );
compare = binop lint::compare;
my (<) = binop (<) ;
my (<=) = binop (<=) ;
my (>) = binop (>) ;
my (>=) = binop (>=) ;
end;
}; # package time
end;