Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                          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;