------------------------------------------------------------------------------ -- -- -- GNAT SYSTEM UTILITIES -- -- -- -- A L F A _ T E S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -- This utility program is used to test proper operation of the Get_Alfa and -- Put_Alfa units. To run it, compile any source file with switch -gnatd.E or -- -gnatd.F to get an ALI file file.ALI containing Alfa information. Then run -- this utility using: -- Alfa_Test file.ali -- This test will read the Alfa information from the ALI file, and use -- Get_Alfa to store this in binary form in the internal tables in Alfa. Then -- Put_Alfa is used to write the information from these tables back into text -- form. This output is compared with the original Alfa information in the ALI -- file and the two should be identical. If not an error message is output. with Get_Alfa; with Put_Alfa; with Alfa; use Alfa; with Types; use Types; with Ada.Command_Line; use Ada.Command_Line; with Ada.Streams; use Ada.Streams; with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; with Ada.Text_IO; with GNAT.OS_Lib; use GNAT.OS_Lib; procedure Alfa_Test is Infile : File_Type; Name1 : String_Access; Outfile_1 : File_Type; Name2 : String_Access; Outfile_2 : File_Type; C : Character; Stop : exception; -- Terminate execution Diff_Exec : constant String_Access := Locate_Exec_On_Path ("diff"); Diff_Result : Integer; use ASCII; begin if Argument_Count /= 1 then Ada.Text_IO.Put_Line ("Usage: alfa_test FILE.ali"); raise Stop; end if; Name1 := new String'(Argument (1) & ".1"); Name2 := new String'(Argument (1) & ".2"); Open (Infile, In_File, Argument (1)); Create (Outfile_1, Out_File, Name1.all); Create (Outfile_2, Out_File, Name2.all); -- Read input file till we get to first 'F' line Process : declare Output_Col : Positive := 1; function Get_Char (F : File_Type) return Character; -- Read one character from specified file procedure Put_Char (F : File_Type; C : Character); -- Write one character to specified file function Get_Output_Col return Positive; -- Return current column in output file, where each line starts at -- column 1 and terminate with LF, and HT is at columns 1, 9, etc. -- All output is supposed to be carried through Put_Char. -------------- -- Get_Char -- -------------- function Get_Char (F : File_Type) return Character is Item : Stream_Element_Array (1 .. 1); Last : Stream_Element_Offset; begin Read (F, Item, Last); if Last /= 1 then return Types.EOF; else return Character'Val (Item (1)); end if; end Get_Char; -------------------- -- Get_Output_Col -- -------------------- function Get_Output_Col return Positive is begin return Output_Col; end Get_Output_Col; -------------- -- Put_Char -- -------------- procedure Put_Char (F : File_Type; C : Character) is Item : Stream_Element_Array (1 .. 1); begin if C /= CR and then C /= EOF then if C = LF then Output_Col := 1; elsif C = HT then Output_Col := ((Output_Col + 6) / 8) * 8 + 1; else Output_Col := Output_Col + 1; end if; Item (1) := Character'Pos (C); Write (F, Item); end if; end Put_Char; -- Subprograms used by Get_Alfa (these also copy the output to Outfile_1 -- for later comparison with the output generated by Put_Alfa). function Getc return Character; function Nextc return Character; procedure Skipc; ---------- -- Getc -- ---------- function Getc return Character is C : Character; begin C := Get_Char (Infile); Put_Char (Outfile_1, C); return C; end Getc; ----------- -- Nextc -- ----------- function Nextc return Character is C : Character; begin C := Get_Char (Infile); if C /= EOF then Set_Index (Infile, Index (Infile) - 1); end if; return C; end Nextc; ----------- -- Skipc -- ----------- procedure Skipc is C : Character; pragma Unreferenced (C); begin C := Getc; end Skipc; -- Subprograms used by Put_Alfa, which write information to Outfile_2 function Write_Info_Col return Positive; procedure Write_Info_Char (C : Character); procedure Write_Info_Initiate (Key : Character); procedure Write_Info_Nat (N : Nat); procedure Write_Info_Terminate; -------------------- -- Write_Info_Col -- -------------------- function Write_Info_Col return Positive is begin return Get_Output_Col; end Write_Info_Col; --------------------- -- Write_Info_Char -- --------------------- procedure Write_Info_Char (C : Character) is begin Put_Char (Outfile_2, C); end Write_Info_Char; ------------------------- -- Write_Info_Initiate -- ------------------------- procedure Write_Info_Initiate (Key : Character) is begin Write_Info_Char (Key); end Write_Info_Initiate; -------------------- -- Write_Info_Nat -- -------------------- procedure Write_Info_Nat (N : Nat) is begin if N > 9 then Write_Info_Nat (N / 10); end if; Write_Info_Char (Character'Val (48 + N mod 10)); end Write_Info_Nat; -------------------------- -- Write_Info_Terminate -- -------------------------- procedure Write_Info_Terminate is begin Write_Info_Char (LF); end Write_Info_Terminate; -- Local instantiations of Put_Alfa and Get_Alfa procedure Get_Alfa_Info is new Get_Alfa; procedure Put_Alfa_Info is new Put_Alfa; -- Start of processing for Process begin -- Loop to skip till first 'F' line loop C := Get_Char (Infile); if C = EOF then raise Stop; elsif C = LF or else C = CR then loop C := Get_Char (Infile); exit when C /= LF and then C /= CR; end loop; exit when C = 'F'; end if; end loop; -- Position back to initial 'F' of first 'F' line Set_Index (Infile, Index (Infile) - 1); -- Read Alfa information to internal Alfa tables, also copying Alfa info -- to Outfile_1. Initialize_Alfa_Tables; Get_Alfa_Info; -- Write Alfa information from internal Alfa tables to Outfile_2 Put_Alfa_Info; -- Junk blank line (see comment at end of Lib.Writ) Write_Info_Terminate; -- Flush to disk Close (Outfile_1); Close (Outfile_2); -- Now Outfile_1 and Outfile_2 should be identical Diff_Result := Spawn (Diff_Exec.all, Argument_String_To_List ("-u " & Name1.all & " " & Name2.all).all); if Diff_Result /= 0 then Ada.Text_IO.Put_Line ("diff(1) exit status" & Diff_Result'Img); end if; OS_Exit (Diff_Result); end Process; exception when Stop => null; end Alfa_Test;