|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 8467 (0x2113)
Types: TextFile
Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦0f1737f92⟧
└─⟦this⟧
with system;
with v_i_time;
package body CALENDAR is
type time_float is digits 9;
package local_time is
function clock return time;
seconds_from_gmt: time_float;
function daylight_savings(year, julian_day: integer) return time_float;
end;
seconds_per_day : constant := 86400.0;
function is_leap_year(year: year_number) return boolean is
begin
return year mod 4 = 0;
end;
function days_in_month(month: month_number; of_year: year_number)
return day_number is
begin
case month is
when 1 | 3 | 5 | 7..8 | 10 | 12 => return 31;
when 2 =>
if is_leap_year(of_year) then return 29;
else return 28;
end if;
when others => return 30;
end case;
end;
function clock return time is
begin
return local_time.clock;
end;
function year (date: time) return year_number is
year : year_number;
month : month_number;
day : day_number;
seconds: day_duration;
begin
split(date, year, month, day, seconds);
return year;
end;
function month (date: time) return month_number is
year : year_number;
month : month_number;
day : day_number;
seconds: day_duration;
begin
split(date, year, month, day, seconds);
return month;
end;
function day (date: time) return day_number is
year : year_number;
month : month_number;
day : day_number;
seconds: day_duration;
begin
split(date, year, month, day, seconds);
return day;
end;
function seconds(date: time) return day_duration is
year : year_number;
month : month_number;
day : day_number;
seconds: day_duration;
begin
split(date, year, month, day, seconds);
return seconds;
end;
function julian_day_of(year : year_number;
month : month_number;
day : day_number) return integer is
j, m, y, c, ya: integer;
begin
if month > 2 then
m := month - 3;
y := year;
else
m := month + 9;
y := year - 1;
end if;
c := y / 100;
ya := y - 100 * c;
return (146097*c)/4 + (1461*ya)/4 + (153*m+2)/5 + day + 1721119;
end julian_day_of;
procedure date_from_julian_day(jday: integer;
year : out year_number;
month : out month_number;
day : out day_number) is
j: integer := jday - 1721119;
y: integer := (4*j-1)/146097;
d, m: integer;
begin
j := 4*j - 1 - 146097 * y;
d := j / 4;
j := (4*d+3)/1461;
d := 4*d + 3 - 1461*j;
d := (d+4) / 4;
m := (5*d-3)/153;
d := 5*d - 3 - 153*m;
day := (d+5) / 5;
y := 100*y + j;
if m < 10 then
month := m + 3;
year := y;
else
month := m - 9;
year := y + 1;
end if;
end date_from_julian_day;
procedure split (date : in time;
year : out year_number;
month : out month_number;
day : out day_number;
seconds: out day_duration) is
s: time_float := time_float(date.sec);
jday: integer := date.julian_day;
y: integer;
begin
s := time_float(date.sec) - local_time.seconds_from_gmt;
if s < 0.0 then
jday := jday - 1;
s := s + seconds_per_day;
end if;
date_from_julian_day(jday, y, month, day);
s := s + local_time.daylight_savings(y, jday);
if s >= seconds_per_day then
jday := jday + 1;
s := s - seconds_per_day;
date_from_julian_day(jday, y, month, day);
end if;
seconds := duration(s);
year := y;
end;
function time_of(year : year_number;
month : month_number;
day : day_number;
seconds: day_duration := 0.0) return time is
date: time;
s: time_float := time_float(seconds);
begin
if day > days_in_month(month, year) then
raise time_error;
end if;
date.julian_day := julian_day_of(year, month, day);
if s >= seconds_per_day then
date.julian_day := date.julian_day + 1;
s := s - seconds_per_day;
end if;
s := s - local_time.daylight_savings(year, date.julian_day);
if s < 0.0 then
date.julian_day := date.julian_day - 1;
s := s + seconds_per_day;
end if;
s := time_float(s) + local_time.seconds_from_gmt;
if s >= seconds_per_day then
date.julian_day := date.julian_day + 1;
s := s - seconds_per_day;
end if;
date.sec := duration(s);
-- date is now converted to GMT, normalized
return date;
end;
function "+"(a, b: integer) return integer is
begin
if a < 0 and then b < 0 then
if (integer'first - a - b) > 0 then
raise time_error;
end if;
elsif a > 0 and then b > 0 then
if (integer'last - a - b) < 0 then
raise time_error;
end if;
end if;
return standard."+"(a, b);
end;
function "+" (left: time; right: duration) return time is
date: time;
check: year_number;
secs: duration;
begin
date.julian_day := left.julian_day;
begin
secs := left.sec + right;
exception
when numeric_error | constraint_error =>
secs := (left.sec - seconds_per_day) + right;
date.julian_day := date.julian_day + 1;
end;
date.sec := secs;
if date.sec < 0.0 or else date.sec >= seconds_per_day then
while date.sec >= seconds_per_day loop
date.julian_day := date.julian_day + 1;
date.sec := date.sec - seconds_per_day;
end loop;
while date.sec < 0.0 loop
date.julian_day := date.julian_day - 1;
date.sec := date.sec + seconds_per_day;
end loop;
end if;
check := year(date);
return date;
exception
when others =>
raise time_error;
end;
function "+" (left: duration;right: time) return time is
begin
return right + left;
end;
function "-" (left: time; right: duration) return time is
begin
return left + (- right);
end;
function "-" (left: time; right: time) return duration is
day_diff : integer := left.julian_day - right.julian_day;
diff: duration := left.sec + (-right.sec);
begin
return duration(day_diff * integer(seconds_per_day)) + diff;
exception
when numeric_error | constraint_error =>
raise time_error;
end;
function "<" (left, right: time) return boolean is
begin
return left.julian_day < right.julian_day OR ELSE
(left.julian_day = right.julian_day and then left.sec < right.sec);
end;
function "<=" (left, right: time) return boolean is
begin
return left.julian_day < right.julian_day OR ELSE
(left.julian_day = right.julian_day and then left.sec <= right.sec);
end;
function ">" (left, right: time) return boolean is
begin
return left.julian_day > right.julian_day OR ELSE
(left.julian_day = right.julian_day and then left.sec > right.sec);
end;
function ">=" (left, right: time) return boolean is
begin
return left.julian_day > right.julian_day OR ELSE
(left.julian_day = right.julian_day and then left.sec >= right.sec);
end;
procedure set_clock(date: time;
timer_support_arg: system.address := system.NO_ADDR)
is
begin
v_i_time.set_time(date.julian_day, date.sec, timer_support_arg);
end;
pragma external_name(set_clock, "__SET_CLOCK");
procedure delay_until(date: time) is
begin
v_i_time.delay_until(date.julian_day, date.sec);
end;
pragma external_name(delay_until, "__DELAY_UNTIL");
package body local_time is separate;
end