diff options
Diffstat (limited to 'gcc-4.7/gcc/ada/alfa_test.adb')
| -rw-r--r-- | gcc-4.7/gcc/ada/alfa_test.adb | 317 |
1 files changed, 317 insertions, 0 deletions
diff --git a/gcc-4.7/gcc/ada/alfa_test.adb b/gcc-4.7/gcc/ada/alfa_test.adb new file mode 100644 index 000000000..9e3f78d64 --- /dev/null +++ b/gcc-4.7/gcc/ada/alfa_test.adb @@ -0,0 +1,317 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; |