## 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 pb = proto_basis; # proto_basis is from src/lib/std/src/proto-basis.pkg package li = large_int_imp; # large_int_imp is from src/lib/std/src/bind-largeint-32.pkg package f8 = eight_byte_float_guts; # eight_byte_float_guts is from src/lib/std/src/eight-byte-float-guts.pkg package ig = int_guts; # int_guts is from src/lib/std/src/int-guts.pkg package i1w = one_word_int_guts; # one_word_int_guts is from src/lib/std/src/one-word-int-guts.pkg package mwi = multiword_int; # multiword_int is from src/lib/std/types-only/basis-structs.pkg package nst = number_string; # number_string is from src/lib/std/src/number-string.pkg# package sg = string_guts; # string_guts is from src/lib/std/src/string-guts.pkg package g2d = exceptions_guts; # exceptions_guts is from src/lib/std/src/exceptions-guts.pkg #
package ci = mythryl_callable_c_library_interface; # mythryl_callable_c_library_interface is from src/lib/std/src/unsafe/mythryl-callable-c-library-interface.pkg #
fun cfun fun_name # For background see Note[1] in src/lib/std/src/unsafe/mythryl-callable-c-library-interface.pkg =
ci::find_c_function'' { lib_name => "time", fun_name };
herein
package time_guts: (weak)
api {
include api Time; # Time is from src/lib/std/src/time.api # export these for the benefit of, e.g., posix::times:
fractions_per_second: mwi::Int;
to_fractions: Time -> mwi::Int;
from_fractions: mwi::Int -> Time;
# The below stuff may need to move to src/lib/std/src/time.api # but we'll try here first:
#######################################################################
# Below stuff is intended only for one-time use during
# booting, to switch from direct to indirect syscalls: # For background see Note[1] in src/lib/std/src/unsafe/mythryl-callable-c-library-interface.pkg #
timeofday__syscall: Void -> (i1w::Int, Int);
set__timeofday__ref: ( { lib_name: String, fun_name: String, io_call: (Void -> (i1w::Int, Int)) }
-> (Void -> (i1w::Int, Int))
)
-> Void;
}
{
# Get time type from type-only package:
include package time; # src/lib/std/types-only/basis-time.pkg exception TIME;
infix my quot; # "quot" == "quotient"
(quot) = li::quot;
zero_time
=
pb::TIME { usec => 0 };
fractions_per_second = 1000000 : mwi::Int;
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 (inline_t::in::from_int 1000000);
fun to_milliseconds (pb::TIME { usec } ) = usec quot (inline_t::in::from_int 1000);
fun to_microseconds (pb::TIME { usec } ) = usec;
fun to_nanoseconds (pb::TIME { usec } ) = usec * (inline_t::in::from_int 1000);
fun from_seconds sec = pb::TIME { usec => sec * (inline_t::in::from_int 1000000) };
fun from_milliseconds msec = pb::TIME { usec => msec * (inline_t::in::from_int 1000) };
fun from_microseconds usec = pb::TIME { usec => usec };
fun from_nanoseconds nsec = pb::TIME { usec => nsec quot (inline_t::in::from_int 1000) };
fun from_float_seconds rsec
=
pb::TIME { usec => f8::to_multiword_int ieee_float::TO_ZERO (rsec * 1.0e6) };
fun to_float_seconds (pb::TIME { usec } )
=
f8::from_multiword_int usec * 1.0e-6;
(cfun "timeofday")
->
( timeofday__syscall: Void -> (i1w::Int, Int), # timeofday def in src/c/lib/time/timeofday.c
timeofday__ref,
set__timeofday__ref
);
fun get_current_time_utc ()
=
{ (*timeofday__ref ())
->
(seconds, microseconds);
from_microseconds
( (inline_t::in::from_int 1000000) * i1w::to_multiword_int seconds
+ ig::to_multiword_int microseconds
);
};
rounding_vector
=
#[50000, 5000, 500, 50, 5]
:
Vector( li::Int );
# 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
=
li::format nst::DECIMAL i;
fun format_sec (neg, i)
=
format_int (neg ?? -i :: i);
fun is_even i
=
li::rem (i, 2) == 0;
if (precision < 0)
#
raise exception g2d::SIZE;
elif (precision == 0)
#
(multiword_int_guts::quot_rem (usec, 1000000))
->
(seconds, microseconds);
rounded_seconds
=
case (li::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),
".",
nst::pad_left '0' 6 (format_int microseconds),
nst::pad_left '0' (precision - 6) ""
];
else
rnd = vector::get (rounding_vector, precision - 1);
(multiword_int_guts::quot_rem (usec, (inline_t::in::from_int 2) * rnd))
->
(whole_part, fraction_part);
rounded_whole_part
=
case (li::compare (fraction_part, rnd))
#
LESS => whole_part;
#
GREATER => whole_part + 1;
#
EQUAL => is_even whole_part ?? whole_part
:: whole_part + 1;
esac;
rscl = (inline_t::in::from_int 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),
".",
nst::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
=
ig::to_multiword_int (char::to_int c - char::to_int '0');
fun whole s
=
loop (s, 0, 0, \\ _ = 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', (inline_t::in::from_int 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 * (inline_t::in::from_int 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 * (inline_t::in::from_int 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 (nst::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 li::compare;
my (<) = binop (<) ;
my (<=) = binop (<=) ;
my (>) = binop (>) ;
my (>=) = binop (>=) ;
end;
}; # package time
end;