-- REPORT.A -- -- Grant of Unlimited Rights -- -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained -- unlimited rights in the software and documentation contained herein. -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making -- this public release, the Government intends to confer upon all -- recipients unlimited rights Equal to those held by the Government. -- These rights include rights to use, duplicate, release or disclose the -- released technical data and computer software in whole or in part, in -- any manner and for any purpose whatsoever, and to have or permit others -- to do so. -- -- DISCLAIMER -- -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A -- PARTICULAR PURPOSE OF SAID MATERIAL. --* -- -- PURPOSE: -- This Report package provides the mechanism for reporting the -- Pass/Fail/Not-Applicable results of executable (Classes A, C, -- D, E, and L) tests. -- It also provides the mechanism for guaranteeing that certain -- values become dynamic (not known at compile-time). -- This version can write an event trace file in the format required -- by the ACATS grading tools. Writing the event trace file requires -- that text files can be created and appended to. If that is not true -- for your target, set Generate_Event_Trace_File to False. -- CHANGE HISTORY: -- DCB 04/27/80 -- JRK 6/10/80 -- JRK 11/12/80 -- JRK 8/6/81 -- JRK 10/27/82 -- JRK 6/1/84 -- JRK 11/18/85 Added pragma Elaborate. -- PWB 07/29/87 Added Status Action_Required and -- procedure Special_Action. -- TBN 08/20/87 Added function Legal_File_Name. -- BCB 05/17/90 Modified to allow output to Direct_IO file. -- Added Time-Stamp. -- LDC 05/17/90 Removed output to Direct_IO file. -- WMC 08/11/92 Updated ACVC version string to "9X BASIC". -- DTN 07/05/92 Updated ACVC version string to -- "ACVC 2.0 JULY 6 1993 DRAFT". -- WMC 01/24/94 Modified Legal_File_Name to allow five possible -- file names (increated range of type file_name to 1..5). -- WMC 11/06/94 Updated ACVC version string to -- "ACVC 2.0 NOVEMBER 6 1994 DRAFT". -- DTN 12/04/94 Updated ACVC version string to -- "ACVC 2.0". -- KAS 06/19/95 Added function Ident_Wide_Char. -- KAS 06/19/95 Added function Ident_Wide_Str. -- DTN 11/21/95 Updated ACVC version string to "ACVC 2.0.1". -- DTN 12/14/95 Updated ACVC version string to "ACVC 2.1". -- EDS 12/17/97 Updated ACVC version string to "2.2". -- RLB 3/16/00 Updated ACATS version string to "2.3". -- Changed various strings to read "ACATS". -- RLB 3/22/01 Updated ACATS version string to "2.4". -- RLB 3/29/02 Updated ACATS version string to "2.5". -- RLB 3/06/07 Updated ACATS version string to "2.6". -- RLB 3/22/07 Updated ACATS version string to "3.0". -- RLB 1/24/14 Updated ACATS version string to "3.1". -- RLB 2/28/14 Updated ACATS version string to "4.0". -- RLB 2/29/16 Added optional .CSV event trace file. -- Converted file to modern format, uses Ada 2012 unit -- names. Note: The messages were left in all UPPER CASE -- in order to avoid breaking existing tools. -- RLB 3/24/16 Moved the event trace Boolean to the specification -- so it can be used by a future CZ test. -- RLB 4/27/16 Updated ACATS version string to "4.1". -- RLB 12/29/21 Moved the ACATS version string to a separate package, -- found in Version.A. -- package Report is subtype File_Num is Integer range 1..5; -- The Report routines. procedure Test -- This routine must be invoked at the start of -- a test, before any of the other report -- routines are invoked. It save the test -- name and outputs the name and description. ( Name : String; -- Test Name, e.g., "C23001A-AB". Descr : String -- Brief description og test, e.g., -- "Upper/lower case equivalence in " & -- "identifiers". ); procedure Failed -- Output a Failure message. Should be invoked -- separately to report the failure of each -- subtest within a test. ( Descr : String -- Brief description of what failed. -- Should be phrased as: -- "(Failed because) ...reason...". ); procedure Not_Applicable -- Output a Not-Applicable message. -- Should be invoked separately to report the -- non-applicability of each subtest within a -- test. ( Descr : String -- Brief description of what is -- Not-Applicable. Should be phrased as: -- "(Not-Applicable because)...reason...". ); procedure Special_Action -- Output a message describing special actions to -- be taken. Should be invoked separately to give -- each special action. ( Descr : String -- Brief description of action to be taken. ); procedure Comment -- Output a Comment message. ( Descr : String -- The message. ); procedure Result; -- This routine must be invoked at the end of a -- test. It outputs a message indicating whether -- the test as a whole has passed, failed, is -- Not-Applicable, or has tentatively passed -- pending special actions. -- The dynamic value routines. -- Even with static arguments, these functions will have dynamic -- results. function Ident_Int -- An identity function for type Integer. ( X : Integer -- The argument. ) return Integer; -- X. function Ident_Char -- An identity function for type -- Character. ( X : Character -- The argument. ) return Character; -- X. function Ident_Wide_Char -- An identity function for type -- Wide_Character. ( X : Wide_Character -- The argument. ) return Wide_Character; -- X. function Ident_Bool -- An identity function for type Boolean. ( X : Boolean -- The argument. ) return Boolean; -- X. function Ident_Str -- An identity function for type String. ( X : String -- The argument. ) return String; -- X. function Ident_Wide_Str -- An identity function for type Wide_String. ( X : Wide_String -- The argument. ) return Wide_String; -- X. function Equal -- A recursive Equality function for type -- Integer. ( X, Y : Integer -- The arguments. ) return Boolean; -- X = Y. -- Other utility routines. function Legal_File_Name -- A function to generate legal external file -- names. ( X : File_Num := 1; -- Determines first character of name. Nam : String := "" -- Determines rest of name. ) return String; -- The generated name. function Time_Stamp -- A function to generate the time and date to -- place in the output of an ACATS test. return String; -- The time and date. -- Event trace setting. Generate_Event_Trace_File : constant Boolean := False; -- ^^^^^ --- MODIFY HERE AS NEEDED -- Set to True to generate an event trace file (use with an -- implementation that provides a compilation option to produce -- an event trace file), and False to not generate such a file. end Report; with Ada.Text_IO, Ada.Calendar, Version; use Ada.Text_IO, Ada.Calendar; pragma Elaborate (Ada.Text_IO, Ada.Calendar); package body Report is type Status is (Pass, Fail, Does_Not_Apply, Action_Required, Unknown); type Time_Integer is range 0 .. 86_400; Test_Status : Status := Fail; Max_Name_Len : constant := 15; -- Maximum Test Name Length. Test_Name : String (1..Max_Name_Len); No_Name : constant String := "NO_NAME"; Test_Name_Len : Integer range 0..Max_Name_Len := 0; Event_Trace_File_Name : constant String := "etrace.csv"; -- This name will work on Windows and POSIX targets. -- Change it if it doesn't work. Max_Event_Message_Len : constant := 150; -- Limit event messages to this length. procedure Put_Msg (Msg : String) is -- Write message. Long messages are folded (and indented). Max_Len : constant Integer range 50..150 := 72; -- Maximum output -- line length. Indent : constant Integer := Test_Name_Len + 9; -- Amount to -- indent continuation lines. I : Integer := 0; -- Current Indentation. M : Integer := Msg'First; -- Start of message slice. N : Integer; -- End of message slice. begin loop if I + (Msg'Last-M+1) > Max_Len then N := M + (Max_Len-I) - 1; if Msg (N) /= ' ' then while N >= M and then Msg (N+1) /= ' ' loop N := N - 1; end loop; if N < M then N := M + (Max_Len-I) - 1; end if; end if; else N := Msg'Last; end if; Set_Col (Standard_Output, Ada.Text_IO.Count (I+1)); Put_Line (Standard_Output, Msg (M..N)); I := Indent; M := N + 1; while M <= Msg'Last and then Msg (M) = ' ' loop M := M + 1; end loop; exit when M > Msg'Last; end loop; end Put_Msg; function Inner_Time_Stamp (Full : in Boolean := False) return String is Time_Now : Ada.Calendar.Time; Dur_Second : Day_Duration; Year, Month, Day, Hour, Minute, Second, SubSecond : Time_Integer := 1; function Convert (Number : Time_Integer) return String is Str : String (1..2) := (others => '0'); Dec_Digit : constant String := "0123456789"; Num : Time_Integer := Number; begin if Num = 0 then return Str; else Num := Num mod 100; Str (2) := Dec_Digit (Integer (Num mod 10 + 1)); Num := Num / 10; Str (1) := Dec_Digit (Integer (Num + 1)); return Str; end if; end Convert; begin Time_Now := Ada.Calendar.Clock; -- Note: This entire routine except the above call could -- be replaced by a call to Ada.Calendar.Formatting.Image -- if we don't mind the 4 digit year, and that we couldn't -- use the result on an Ada 95 compiler. Split (Time_Now, Year_Number (Year), Month_Number (Month), Day_Number (Day), Dur_Second); if Full then -- Remove the fractional part without overflow (do this first -- so we don't round the seconds, and don't need a larger -- integer type [24-bits is not enough]): Second := Time_Integer'Max(Time_Integer(Dur_Second)-1, 0); Minute := Second / 60; -- Leave just seconds: Dur_Second := Dur_Second - Integer(Minute)*Day_Duration'(60.0); -- Multiply by 100: Dur_Second := Dur_Second * 100; SubSecond := Time_Integer(Dur_Second); SubSecond := SubSecond mod 100; -- Remove the fractional part: if Dur_Second <= Day_Duration(SubSecond) then -- The value is just the subseconds. Dur_Second := 0.0; else Dur_Second := Dur_Second - Day_Duration(SubSecond); end if; -- Put everything back the way it was: Dur_Second := Dur_Second / 100; Dur_Second := Dur_Second + Integer(Minute)*Day_Duration'(60.0); end if; Second := Time_Integer(Dur_Second); Hour := Second / 3600; Second := Second mod 3600; Minute := Second / 60; Second := Second mod 60; if Full then return (Convert (Time_Integer (Year)/100) & Convert (Time_Integer (Year)) & "-" & Convert (Time_Integer (Month)) & "-" & Convert (Time_Integer (Day)) & " " & Convert (Time_Integer (Hour)) & ":" & Convert (Time_Integer (Minute)) & ":" & Convert (Time_Integer (Second)) & '.' & Convert (Time_Integer (SubSecond))); else return (Convert (Time_Integer (Year)) & "-" & Convert (Time_Integer (Month)) & "-" & Convert (Time_Integer (Day)) & " " & Convert (Time_Integer (Hour)) & ":" & Convert (Time_Integer (Minute)) & ":" & Convert (Time_Integer (Second))); end if; end Inner_Time_Stamp; function Time_Stamp return String is begin return Inner_Time_Stamp; end Time_Stamp; procedure Put_Event_Trace (Event : in String; Msg : in String) is -- Put an event trace. File : Ada.Text_IO.File_Type; begin if not Generate_Event_Trace_File then return; -- Nothing to do, shouldn't get here. end if; begin Ada.Text_IO.Open (File, Name => Event_Trace_File_Name, Mode => Ada.Text_IO.Append_File); exception when Ada.Text_IO.Name_Error => -- The file doesn't exist, create it. Ada.Text_IO.Create (File, Name => Event_Trace_File_Name, Mode => Ada.Text_IO.Out_File); -- Write a header. This is not strictly necessary, -- but we do it as it makes it a lot easier to use -- the .CSV file in an spreadsheet. Ada.Text_IO.Put_Line (File, "Event,Timestamp,Name," & "Line,Position,Message"); end; Ada.Text_IO.Put (File, Event & ",""" & Inner_Time_Stamp(Full => True) & """,""" & Test_Name (1..Test_Name_Len) & """,,,"""); declare Msg_Copy : String := Msg; begin for I in Msg_Copy'range loop if Msg_Copy(I) = '"' then -- Can't have any double -- quotes in this string. Msg_Copy(I) := '''; end if; end loop; if Msg_Copy'Length <= Max_Event_Message_Len then Ada.Text_IO.Put_Line (File, Msg_Copy & """"); else -- Find a space near the end: for I in reverse Msg_Copy'First + Max_Event_Message_Len-20 .. Msg_Copy'First + Natural'Min(Max_Event_Message_Len+1,Msg_Copy'Length-1) loop if Msg_Copy(I) = ' ' then Ada.Text_IO.Put_Line (File, Msg_Copy (Msg_Copy'First .. I - 1) & """"); Ada.Text_IO.Close (File); return; -- Done. -- else continue looking. end if; end loop; -- No space obvious, so truncate it. Ada.Text_IO.Put_Line (File, Msg_Copy (Msg_Copy'First .. Msg_Copy'First + Natural'Min( Max_Event_Message_Len+1, Msg_Copy'Length)) & """"); end if; end; Ada.Text_IO.Close (File); end Put_Event_Trace; procedure Test (Name : String; Descr : String) is begin Test_Status := Pass; if Name'Length <= Max_Name_Len then Test_Name_Len := Name'Length; else Test_Name_Len := Max_Name_Len; end if; Test_Name (1..Test_Name_Len) := Name (Name'First .. Name'First+Test_Name_Len-1); Put_Msg (""); Put_Msg (",.,. " & Test_Name (1..Test_Name_Len) & " " & "ACATS " & Version.ACATS_Version & " " & Time_Stamp); Put_Msg ("---- " & Test_Name (1..Test_Name_Len) & " " & Descr & "."); if Generate_Event_Trace_File then Put_Event_Trace ("EXSTART", Descr); end if; end Test; procedure Comment (Descr : String) is begin Put_Msg (" - " & Test_Name (1..Test_Name_Len) & " " & Descr & "."); end Comment; procedure Failed (Descr : String) is begin Test_Status := Fail; Put_Msg (" * " & Test_Name (1..Test_Name_Len) & " " & Descr & "."); if Generate_Event_Trace_File then Put_Event_Trace ("EXFAIL", Descr); end if; end Failed; procedure Not_Applicable (Descr : String) is begin if Test_Status = Pass or Test_Status = Action_Required then Test_Status := Does_Not_Apply; end if; Put_Msg (" + " & Test_Name (1..Test_Name_Len) & " " & Descr & "."); if Generate_Event_Trace_File then Put_Event_Trace ("EXNA", Descr); end if; end Not_Applicable; procedure Special_Action (Descr : String) is begin if Test_Status = Pass then Test_Status := Action_Required; end if; Put_Msg (" ! " & Test_Name (1..Test_Name_Len) & " " & Descr & "."); if Generate_Event_Trace_File then Put_Event_Trace ("EXSACT", Descr); end if; end Special_Action; procedure Result is begin case Test_Status is when Pass => Put_Msg ("==== " & Test_Name (1..Test_Name_Len) & " PASSED ============================."); if Generate_Event_Trace_File then Put_Event_Trace ("EXEND", "Passed"); end if; when Does_Not_Apply => Put_Msg ("++++ " & Test_Name (1..Test_Name_Len) & " NOT-APPLICABLE ++++++++++++++++++++."); if Generate_Event_Trace_File then Put_Event_Trace ("EXEND", "Not-Applicable"); end if; when Action_Required => Put_Msg ("!!!! " & Test_Name (1..Test_Name_Len) & " TENTATIVELY PASSED !!!!!!!!!!!!!!!!."); Put_Msg ("!!!! " & (1..Test_Name_Len => ' ') & " SEE '!' COMMENTS FOR SPECIAL NOTES!!"); if Generate_Event_Trace_File then Put_Event_Trace ("EXEND", "Tentatively Passed"); end if; when others => Put_Msg ("**** " & Test_Name (1..Test_Name_Len) & " FAILED ****************************."); if Generate_Event_Trace_File then Put_Event_Trace ("EXEND", "Failed"); end if; end case; Test_Status := Fail; Test_Name_Len := No_Name'Length; Test_Name (1..Test_Name_Len) := No_Name; end Result; function Ident_Int (X : Integer) return Integer is begin if Equal (X, X) then -- Always equal. return X; -- Always executed. end if; return 0; -- Never executed. end Ident_Int; function Ident_Char (X : Character) return Character is begin if Equal (Character'Pos(X), Character'Pos(X)) then -- Always equal. return X; -- Always executed. end if; return '0'; -- Never executed. end Ident_Char; function Ident_Wide_Char (X : Wide_Character) return Wide_Character is begin if Equal (Wide_Character'Pos(X), Wide_Character'Pos(X)) then -- Always equal. return X; -- Always executed. end if; return '0'; -- Never executed. end Ident_Wide_Char; function Ident_Bool (X : Boolean) return Boolean is begin if Equal (Boolean'Pos(X), Boolean'Pos(X)) then -- Always equal. return X; -- Always executed. end if; return False; -- Never executed. end Ident_Bool; function Ident_Str (X : String) return String is begin if Equal (X'Length, X'Length) then -- Always equal. return X; -- Always executed. end if; return ""; -- Never executed. end Ident_Str; function Ident_Wide_Str (X : Wide_String) return Wide_String is begin if Equal (X'Length, X'Length) then -- Always equal. return X; -- Always executed. end if; return ""; -- Never executed. end Ident_Wide_Str; function Equal (X, Y : Integer) return Boolean is Rec_Limit : constant Integer range 1..100 := 3; -- Recursion limit. Z : Boolean; -- Result. begin if X < 0 then if Y < 0 then Z := Equal (-X, -Y); else Z := False; end if; elsif X > Rec_Limit then Z := Equal (Rec_Limit, Y-X+Rec_Limit); elsif X > 0 then Z := Equal (X-1, Y-1); else Z := Y = 0; end if; return Z; exception when others => return X = Y; end Equal; function Legal_File_Name (X : File_Num := 1; Nam : String := "") return String is Suffix : String (2..6); begin if Nam = "" then Suffix := Test_Name(3..7); else Suffix := Nam(3..7); end if; case X is when 1 => return ('X' & Suffix); when 2 => return ('Y' & Suffix); when 3 => return ('Z' & Suffix); when 4 => return ('V' & Suffix); when 5 => return ('W' & Suffix); end case; end Legal_File_Name; begin Test_Name_Len := No_Name'Length; Test_Name (1..Test_Name_Len) := No_Name; end Report;