gcc/ada/alfa_test.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                          GNAT SYSTEM UTILITIES                           --
   4 --                                                                          --
   5 --                            A L F A _ T E S T                             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2011, Free Software Foundation, Inc.            --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 --  This utility program is used to test proper operation of the Get_Alfa and
  27 --  Put_Alfa units. To run it, compile any source file with switch -gnatd.E or
  28 --  -gnatd.F to get an ALI file file.ALI containing Alfa information. Then run
  29 --  this utility using:
  30
  31 --     Alfa_Test file.ali
  32
  33 --  This test will read the Alfa information from the ALI file, and use
  34 --  Get_Alfa to store this in binary form in the internal tables in Alfa. Then
  35 --  Put_Alfa is used to write the information from these tables back into text
  36 --  form. This output is compared with the original Alfa information in the ALI
  37 --  file and the two should be identical. If not an error message is output.
  38
  39 with Get_Alfa;
  40 with Put_Alfa;
  41
  42 with Alfa;  use Alfa;
  43 with Types; use Types;
  44
  45 with Ada.Command_Line;      use Ada.Command_Line;
  46 with Ada.Streams;           use Ada.Streams;
  47 with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
  48 with Ada.Text_IO;
  49
  50 with GNAT.OS_Lib; use GNAT.OS_Lib;
  51
  52 procedure Alfa_Test is
  53    Infile    : File_Type;
  54    Name1     : String_Access;
  55    Outfile_1 : File_Type;
  56    Name2     : String_Access;
  57    Outfile_2 : File_Type;
  58    C         : Character;
  59
  60    Stop : exception;
  61    --  Terminate execution
  62
  63    Diff_Exec   : constant String_Access := Locate_Exec_On_Path ("diff");
  64    Diff_Result : Integer;
  65
  66    use ASCII;
  67
  68 begin
  69    if Argument_Count /= 1 then
  70       Ada.Text_IO.Put_Line ("Usage: alfa_test FILE.ali");
  71       raise Stop;
  72    end if;
  73
  74    Name1 := new String'(Argument (1) & ".1");
  75    Name2 := new String'(Argument (1) & ".2");
  76
  77    Open   (Infile,    In_File,  Argument (1));
  78    Create (Outfile_1, Out_File, Name1.all);
  79    Create (Outfile_2, Out_File, Name2.all);
  80
  81    --  Read input file till we get to first 'F' line
  82
  83    Process : declare
  84       Output_Col : Positive := 1;
  85
  86       function Get_Char (F : File_Type) return Character;
  87       --  Read one character from specified  file
  88
  89       procedure Put_Char (F : File_Type; C : Character);
  90       --  Write one character to specified file
  91
  92       function Get_Output_Col return Positive;
  93       --  Return current column in output file, where each line starts at
  94       --  column 1 and terminate with LF, and HT is at columns 1, 9, etc.
  95       --  All output is supposed to be carried through Put_Char.
  96
  97       --------------
  98       -- Get_Char --
  99       --------------
 100
 101       function Get_Char (F : File_Type) return Character is
 102          Item : Stream_Element_Array (1 .. 1);
 103          Last : Stream_Element_Offset;
 104
 105       begin
 106          Read (F, Item, Last);
 107
 108          if Last /= 1 then
 109             return Types.EOF;
 110          else
 111             return Character'Val (Item (1));
 112          end if;
 113       end Get_Char;
 114
 115       --------------------
 116       -- Get_Output_Col --
 117       --------------------
 118
 119       function Get_Output_Col return Positive is
 120       begin
 121          return Output_Col;
 122       end Get_Output_Col;
 123
 124       --------------
 125       -- Put_Char --
 126       --------------
 127
 128       procedure Put_Char (F : File_Type; C : Character) is
 129          Item : Stream_Element_Array (1 .. 1);
 130
 131       begin
 132          if C /= CR and then C /= EOF then
 133             if C = LF then
 134                Output_Col := 1;
 135             elsif C = HT then
 136                Output_Col := ((Output_Col + 6) / 8) * 8 + 1;
 137             else
 138                Output_Col := Output_Col + 1;
 139             end if;
 140
 141             Item (1) := Character'Pos (C);
 142             Write (F, Item);
 143          end if;
 144       end Put_Char;
 145
 146       --  Subprograms used by Get_Alfa (these also copy the output to Outfile_1
 147       --  for later comparison with the output generated by Put_Alfa).
 148
 149       function  Getc  return Character;
 150       function  Nextc return Character;
 151       procedure Skipc;
 152
 153       ----------
 154       -- Getc --
 155       ----------
 156
 157       function Getc  return Character is
 158          C : Character;
 159       begin
 160          C := Get_Char (Infile);
 161          Put_Char (Outfile_1, C);
 162          return C;
 163       end Getc;
 164
 165       -----------
 166       -- Nextc --
 167       -----------
 168
 169       function Nextc return Character is
 170          C : Character;
 171
 172       begin
 173          C := Get_Char (Infile);
 174
 175          if C /= EOF then
 176             Set_Index (Infile, Index (Infile) - 1);
 177          end if;
 178
 179          return C;
 180       end Nextc;
 181
 182       -----------
 183       -- Skipc --
 184       -----------
 185
 186       procedure Skipc is
 187          C : Character;
 188          pragma Unreferenced (C);
 189       begin
 190          C := Getc;
 191       end Skipc;
 192
 193       --  Subprograms used by Put_Alfa, which write information to Outfile_2
 194
 195       function Write_Info_Col return Positive;
 196       procedure Write_Info_Char (C : Character);
 197       procedure Write_Info_Initiate (Key : Character);
 198       procedure Write_Info_Nat (N : Nat);
 199       procedure Write_Info_Terminate;
 200
 201       --------------------
 202       -- Write_Info_Col --
 203       --------------------
 204
 205       function Write_Info_Col return Positive is
 206       begin
 207          return Get_Output_Col;
 208       end Write_Info_Col;
 209
 210       ---------------------
 211       -- Write_Info_Char --
 212       ---------------------
 213
 214       procedure Write_Info_Char (C : Character) is
 215       begin
 216          Put_Char (Outfile_2, C);
 217       end Write_Info_Char;
 218
 219       -------------------------
 220       -- Write_Info_Initiate --
 221       -------------------------
 222
 223       procedure Write_Info_Initiate (Key : Character) is
 224       begin
 225          Write_Info_Char (Key);
 226       end Write_Info_Initiate;
 227
 228       --------------------
 229       -- Write_Info_Nat --
 230       --------------------
 231
 232       procedure Write_Info_Nat (N : Nat) is
 233       begin
 234          if N > 9 then
 235             Write_Info_Nat (N / 10);
 236          end if;
 237
 238          Write_Info_Char (Character'Val (48 + N mod 10));
 239       end Write_Info_Nat;
 240
 241       --------------------------
 242       -- Write_Info_Terminate --
 243       --------------------------
 244
 245       procedure Write_Info_Terminate is
 246       begin
 247          Write_Info_Char (LF);
 248       end Write_Info_Terminate;
 249
 250       --  Local instantiations of Put_Alfa and Get_Alfa
 251
 252       procedure Get_Alfa_Info is new Get_Alfa;
 253       procedure Put_Alfa_Info is new Put_Alfa;
 254
 255    --  Start of processing for Process
 256
 257    begin
 258       --  Loop to skip till first 'F' line
 259
 260       loop
 261          C := Get_Char (Infile);
 262
 263          if C = EOF then
 264             raise Stop;
 265
 266          elsif C = LF or else C = CR then
 267             loop
 268                C := Get_Char (Infile);
 269                exit when C /= LF and then C /= CR;
 270             end loop;
 271
 272             exit when C = 'F';
 273          end if;
 274       end loop;
 275
 276       --  Position back to initial 'F' of first 'F' line
 277
 278       Set_Index (Infile, Index (Infile) - 1);
 279
 280       --  Read Alfa information to internal Alfa tables, also copying Alfa info
 281       --  to Outfile_1.
 282
 283       Initialize_Alfa_Tables;
 284       Get_Alfa_Info;
 285
 286       --  Write Alfa information from internal Alfa tables to Outfile_2
 287
 288       Put_Alfa_Info;
 289
 290       --  Junk blank line (see comment at end of Lib.Writ)
 291
 292       Write_Info_Terminate;
 293
 294       --  Flush to disk
 295
 296       Close (Outfile_1);
 297       Close (Outfile_2);
 298
 299       --  Now Outfile_1 and Outfile_2 should be identical
 300
 301       Diff_Result :=
 302         Spawn (Diff_Exec.all,
 303                Argument_String_To_List
 304                  ("-u " & Name1.all & " " & Name2.all).all);
 305
 306       if Diff_Result /= 0 then
 307          Ada.Text_IO.Put_Line ("diff(1) exit status" & Diff_Result'Img);
 308       end if;
 309
 310       OS_Exit (Diff_Result);
 311
 312    end Process;
 313
 314 exception
 315    when Stop =>
 316       null;
 317 end Alfa_Test;