|
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: 13312 (0x3400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Dates, seg_05095b
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
with Calendar;
use Calendar;
with Text_Io;
package body Dates is
Number : constant array (0 .. 99) of String (1 .. 2) :=
("00", "01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11",
"12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22",
"23", "24", "25", "26", "27", "28", "29", "30", "31", "32", "33",
"34", "35", "36", "37", "38", "39", "40", "41", "42", "43", "44",
"45", "46", "47", "48", "49", "50", "51", "52", "53", "54", "55",
"56", "57", "58", "59", "60", "61", "62", "63", "64", "65", "66",
"67", "68", "69", "70", "71", "72", "73", "74", "75", "76", "77",
"78", "79", "80", "81", "82", "83", "84", "85", "86", "87", "88",
"89", "90", "91", "92", "93", "94", "95", "96", "97", "98", "99");
Max_C : constant Integer := 20;
No_Holiday_Name : constant String := "unnamed holiday ";
Known_Sunday : constant String := "11/29/87";
type Holiday_Rec;
type A_Holiday is access Holiday_Rec;
type Holiday_Rec is
record
Name : String (1 .. Max_C);
Julian_Date : Days;
Next : A_Holiday;
end record;
Holidays : A_Holiday := null;
function Is_Holiday (X : Days) return Boolean is
H : A_Holiday := Holidays;
begin
while H /= null loop
if X = H.Julian_Date then
return True;
end if;
H := H.Next;
end loop;
return False;
end Is_Holiday;
function Is_Weekend (X : Days) return Boolean is
Some_Sunday : Days;
begin
Some_Sunday := Julian_Day_Of (Get_Mmddyy (Known_Sunday));
return (Some_Sunday mod 7) = (X mod 7) or else
(Some_Sunday mod 7) = ((X + 1) mod 7);
end Is_Weekend;
function Kind_Of_Day (T : Time) return Day_Kind is
Day : Days := Julian_Day_Of (T);
begin
if Is_Holiday (Day) then
return Holiday;
elsif Is_Weekend (Day) then
return Weekend_Day;
else
return Work_Days;
end if;
end Kind_Of_Day;
function Day_Of_Week (T : Time) return Days_Of_Week is
Some_Sunday : Days;
T_Days : Days := Julian_Day_Of (T);
begin
Some_Sunday := Julian_Day_Of (Get_Mmddyy (Known_Sunday));
return Days_Of_Week'Val ((T_Days - Some_Sunday) mod 7);
end Day_Of_Week;
function Plus (T : Time; D : Days; Days : Day_Kind := Work_Days)
return Time is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
X : Dates.Days;
Incr : Integer;
Total : Dates.Days;
begin
if D < 0 then
Incr := -1;
Total := -D;
else
Incr := +1;
Total := D;
end if;
X := Julian_Day_Of (T);
for I in 1 .. Total loop
X := X + Incr;
if Days = Work_Days then
while Is_Holiday (X) or else Is_Weekend (X) loop
X := X + Incr;
end loop;
elsif Days = Week_Days then
while Is_Weekend (X) loop
X := X + Incr;
end loop;
end if;
end loop;
Date_From_Julian_Day (X, Year, Month, Day);
return Time_Of (Year, Month, Day, Seconds (T));
end Plus;
function Minus (T : Time; D : Days; Days : Day_Kind := Work_Days)
return Time is
begin
return Plus (T, -D, Days);
end Minus;
function Minus (T1 : Time; T2 : Time; Days : Day_Kind := Work_Days)
return Dates.Days is
Incr : Integer;
Total : Dates.Days := 0;
Earlier_Time, Later_Time : Time;
begin
if T1 < T2 then
Incr := -1;
Earlier_Time := T1;
Later_Time := T2;
else
Incr := +1;
Earlier_Time := T2;
Later_Time := T1;
end if;
for X in Julian_Day_Of (Earlier_Time) .. Julian_Day_Of (Later_Time) loop
if Days = Work_Days then
if not Is_Holiday (X) and then not Is_Weekend (X) then
Total := Total + Incr;
end if;
elsif Days = Week_Days then
if not Is_Weekend (X) then
Total := Total + Incr;
end if;
else
Total := Total + Incr;
end if;
end loop;
return Total;
end Minus;
function Julian_Day_Of (T : Time) return Days is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Seconds : Day_Duration;
J, M, Y, C, Ya : Integer;
begin
Split (T, Year, Month, Day, Seconds);
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 : Days;
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;
function Get_Mmddyy (S : String) return Time is
I, J, Year, Month, Day : Integer;
begin
I := S'First;
while S (I) /= '/' loop
I := I + 1;
end loop;
Month := Integer'Value (S (S'First .. I - 1));
J := I + 1;
while S (J) /= '/' loop
J := J + 1;
end loop;
Day := Integer'Value (S (I + 1 .. J - 1));
Year := Integer'Value (S (J + 1 .. S'Last));
return Calendar.Time_Of (Year + 1900, Month, Day);
exception
when others =>
raise Calendar.Time_Error;
end Get_Mmddyy;
function Put_Mmddyy (T : Time) return String is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Seconds : Day_Duration;
J, M, Y, C, Ya : Integer;
begin
Split (T, Year, Month, Day, Seconds);
return Number (Month) & '/' & Number (Day) & '/' & Number (Year - 1900);
end Put_Mmddyy;
function Get_Ddmmyy (S : String) return Time is
I, J, Year, Month, Day : Integer;
begin
I := S'First;
while S (I) /= '/' loop
I := I + 1;
end loop;
Day := Integer'Value (S (S'First .. I - 1));
J := I + 1;
while S (J) /= '/' loop
J := J + 1;
end loop;
Month := Integer'Value (S (I + 1 .. J - 1));
Year := Integer'Value (S (J + 1 .. S'Last));
return Calendar.Time_Of (Year + 1900, Month, Day);
exception
when others =>
raise Calendar.Time_Error;
end Get_Ddmmyy;
function Put_Ddmmyy (T : Time) return String is
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Seconds : Day_Duration;
J, M, Y, C, Ya : Integer;
begin
Split (T, Year, Month, Day, Seconds);
return Number (Day) & '/' & Number (Month) & '/' & Number (Year - 1900);
end Put_Ddmmyy;
procedure Set_Holidays (File_Name : String) is
F : Text_Io.File_Type;
Line : String (1 .. 1024);
Len : Integer := 0;
N : A_Holiday;
begin
Text_Io.Open (F, Text_Io.In_File, File_Name);
loop
Text_Io.Get_Line (F, Line, Len);
for I in 1 .. Len loop
if Line (I) = ':' then
Holidays :=
new Holiday_Rec'
(No_Holiday_Name,
Julian_Day_Of (Get_Mmddyy (Line (1 .. I - 1))),
Holidays);
for J in I + 1 .. Len loop
if Line (J) /= ' ' then
if Len - J + 1 > Max_C then
Len := J + 11;
end if;
Holidays.Name (1 .. Len - J + 1) := Line (J .. Len);
goto Next_Line;
end if;
end loop;
end if;
end loop;
Holidays :=
new Holiday_Rec'
(No_Holiday_Name,
Julian_Day_Of (Get_Mmddyy (Line (1 .. Len))), Holidays);
<<Next_Line>> null;
end loop;
exception
when Text_Io.End_Error =>
Text_Io.Close (F);
when others =>
Text_Io.Put_Line ("ERROR reading holidays file " & File_Name);
if Len > 0 then
Text_Io.Put_Line (" at line:" & Line (1 .. Len));
Text_Io.Put_Line
(" expected mm/dd/yy: (12 char max) holiday name");
end if;
end Set_Holidays;
function Get_Hrmnsc (S : String) return Duration is
Hours, Minutes, Secs, I, J : Integer;
Part_Secs : Duration := 0.0;
begin
I := S'First;
while S (I) /= ':' loop
I := I + 1;
end loop;
Hours := Integer'Value (S (S'First .. I - 1));
J := I + 1;
while S (J) /= ':' loop
J := J + 1;
end loop;
Minutes := Integer'Value (S (I + 1 .. J - 1));
I := J + 1;
while I <= S'Last and then S (I) /= '.' loop
I := I + 1;
end loop;
Secs := Integer'Value (S (J + 1 .. I - 1));
J := I + 1;
while J <= S'Last and then S (J) /= ' ' loop
J := J + 1;
end loop;
if J - 1 <= S'Last then
Part_Secs := Duration (Float (Integer'Value (S (I + 1 .. J - 1))) /
Float (10 ** (J - I - 1)));
end if;
return Duration (Hours * 3600 + Minutes * 60 + Secs) + Part_Secs;
exception
when others =>
raise Calendar.Time_Error;
end Get_Hrmnsc;
function Put_Hrmnsc (T : Duration) return String is
Hours, Minutes, Secs, Part_Secs : Integer;
begin
Secs := Integer (T - Duration'(0.5)); -- Allow for rounding up
Part_Secs := Integer ((T - Duration (Secs)) * 100);
if Part_Secs >= 100 then
Part_Secs := Part_Secs - 100;
Secs := Secs + 1;
end if;
Hours := Secs / 3600;
Minutes := (Secs mod 3600) / 60;
Secs := Secs mod 60;
return Number (Hours) & ':' & Number (Minutes) & ':' &
Number (Secs) & '.' & Number (Part_Secs);
end Put_Hrmnsc;
end Dates;
nblk1=c
nid=0
hdr6=18
[0x00] rec0=16 rec1=00 rec2=01 rec3=02a
[0x01] rec0=21 rec1=00 rec2=02 rec3=026
[0x02] rec0=22 rec1=00 rec2=03 rec3=01a
[0x03] rec0=1e rec1=00 rec2=04 rec3=014
[0x04] rec0=1e rec1=00 rec2=05 rec3=04e
[0x05] rec0=1e rec1=00 rec2=06 rec3=020
[0x06] rec0=22 rec1=00 rec2=07 rec3=00a
[0x07] rec0=1e rec1=00 rec2=08 rec3=026
[0x08] rec0=1a rec1=00 rec2=09 rec3=044
[0x09] rec0=19 rec1=00 rec2=0a rec3=008
[0x0a] rec0=1d rec1=00 rec2=0b rec3=024
[0x0b] rec0=17 rec1=00 rec2=0c rec3=000
tail 0x2154af66a878e789d9ac2 0x42a00088462060003