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 procedure ALFA_Test is
  51    Infile    : File_Type;
  52    Outfile_1 : File_Type;
  53    Outfile_2 : File_Type;
  54    C         : Character;
  55
  56    Stop : exception;
  57    --  Terminate execution
  58
  59    use ASCII;
  60
  61 begin
  62    if Argument_Count /= 1 then
  63       Ada.Text_IO.Put_Line ("Usage: alfa_test FILE.ali");
  64       raise Stop;
  65    end if;
  66
  67    Create (Outfile_1, Out_File, "log1");
  68    Create (Outfile_2, Out_File, "log2");
  69    Open   (Infile,    In_File,  Argument (1));
  70
  71    --  Read input file till we get to first 'F' line
  72
  73    Process : declare
  74       Output_Col : Positive := 1;
  75
  76       function Get_Char (F : File_Type) return Character;
  77       --  Read one character from specified  file
  78
  79       procedure Put_Char (F : File_Type; C : Character);
  80       --  Write one character to specified file
  81
  82       function Get_Output_Col return Positive;
  83       --  Return current column in output file, where each line starts at
  84       --  column 1 and terminate with LF, and HT is at columns 1, 9, etc.
  85       --  All output is supposed to be carried through Put_Char.
  86
  87       --------------
  88       -- Get_Char --
  89       --------------
  90
  91       function Get_Char (F : File_Type) return Character is
  92          Item : Stream_Element_Array (1 .. 1);
  93          Last : Stream_Element_Offset;
  94
  95       begin
  96          Read (F, Item, Last);
  97
  98          if Last /= 1 then
  99             return Types.EOF;
 100          else
 101             return Character'Val (Item (1));
 102          end if;
 103       end Get_Char;
 104
 105       --------------------
 106       -- Get_Output_Col --
 107       --------------------
 108
 109       function Get_Output_Col return Positive is
 110       begin
 111          return Output_Col;
 112       end Get_Output_Col;
 113
 114       --------------
 115       -- Put_Char --
 116       --------------
 117
 118       procedure Put_Char (F : File_Type; C : Character) is
 119          Item : Stream_Element_Array (1 .. 1);
 120
 121       begin
 122          if C /= CR and then C /= EOF then
 123             if C = LF then
 124                Output_Col := 1;
 125             elsif C = HT then
 126                Output_Col := ((Output_Col + 6) / 8) * 8 + 1;
 127             else
 128                Output_Col := Output_Col + 1;
 129             end if;
 130
 131             Item (1) := Character'Pos (C);
 132             Write (F, Item);
 133          end if;
 134       end Put_Char;
 135
 136       --  Subprograms used by Get_ALFA (these also copy the output to Outfile_1
 137       --  for later comparison with the output generated by Put_ALFA).
 138
 139       function  Getc  return Character;
 140       function  Nextc return Character;
 141       procedure Skipc;
 142
 143       ----------
 144       -- Getc --
 145       ----------
 146
 147       function Getc  return Character is
 148          C : Character;
 149       begin
 150          C := Get_Char (Infile);
 151          Put_Char (Outfile_1, C);
 152          return C;
 153       end Getc;
 154
 155       -----------
 156       -- Nextc --
 157       -----------
 158
 159       function Nextc return Character is
 160          C : Character;
 161
 162       begin
 163          C := Get_Char (Infile);
 164
 165          if C /= EOF then
 166             Set_Index (Infile, Index (Infile) - 1);
 167          end if;
 168
 169          return C;
 170       end Nextc;
 171
 172       -----------
 173       -- Skipc --
 174       -----------
 175
 176       procedure Skipc is
 177          C : Character;
 178          pragma Unreferenced (C);
 179       begin
 180          C := Getc;
 181       end Skipc;
 182
 183       --  Subprograms used by Put_ALFA, which write information to Outfile_2
 184
 185       function Write_Info_Col return Positive;
 186       procedure Write_Info_Char (C : Character);
 187       procedure Write_Info_Initiate (Key : Character);
 188       procedure Write_Info_Nat (N : Nat);
 189       procedure Write_Info_Terminate;
 190
 191       --------------------
 192       -- Write_Info_Col --
 193       --------------------
 194
 195       function Write_Info_Col return Positive is
 196       begin
 197          return Get_Output_Col;
 198       end Write_Info_Col;
 199
 200       ---------------------
 201       -- Write_Info_Char --
 202       ---------------------
 203
 204       procedure Write_Info_Char (C : Character) is
 205       begin
 206          Put_Char (Outfile_2, C);
 207       end Write_Info_Char;
 208
 209       -------------------------
 210       -- Write_Info_Initiate --
 211       -------------------------
 212
 213       procedure Write_Info_Initiate (Key : Character) is
 214       begin
 215          Write_Info_Char (Key);
 216       end Write_Info_Initiate;
 217
 218       --------------------
 219       -- Write_Info_Nat --
 220       --------------------
 221
 222       procedure Write_Info_Nat (N : Nat) is
 223       begin
 224          if N > 9 then
 225             Write_Info_Nat (N / 10);
 226          end if;
 227
 228          Write_Info_Char (Character'Val (48 + N mod 10));
 229       end Write_Info_Nat;
 230
 231       --------------------------
 232       -- Write_Info_Terminate --
 233       --------------------------
 234
 235       procedure Write_Info_Terminate is
 236       begin
 237          Write_Info_Char (LF);
 238       end Write_Info_Terminate;
 239
 240       --  Local instantiations of Put_ALFA and Get_ALFA
 241
 242       procedure Get_ALFA_Info is new Get_ALFA;
 243       procedure Put_ALFA_Info is new Put_ALFA;
 244
 245    --  Start of processing for Process
 246
 247    begin
 248       --  Loop to skip till first 'F' line
 249
 250       loop
 251          C := Get_Char (Infile);
 252
 253          if C = EOF then
 254             raise Stop;
 255
 256          elsif C = LF or else C = CR then
 257             loop
 258                C := Get_Char (Infile);
 259                exit when C /= LF and then C /= CR;
 260             end loop;
 261
 262             exit when C = 'F';
 263          end if;
 264       end loop;
 265
 266       --  Position back to initial 'F' of first 'F' line
 267
 268       Set_Index (Infile, Index (Infile) - 1);
 269
 270       --  Read ALFA information to internal ALFA tables, also copying ALFA info
 271       --  to Outfile_1.
 272
 273       Initialize_ALFA_Tables;
 274       Get_ALFA_Info;
 275
 276       --  Write ALFA information from internal ALFA tables to Outfile_2
 277
 278       Put_ALFA_Info;
 279
 280       --  Junk blank line (see comment at end of Lib.Writ)
 281
 282       Write_Info_Terminate;
 283
 284       --  Now Outfile_1 and Outfile_2 should be identical
 285
 286       Compare_Files : declare
 287          Line : Natural;
 288          Col  : Natural;
 289          C1   : Character;
 290          C2   : Character;
 291
 292       begin
 293          Reset (Outfile_1, In_File);
 294          Reset (Outfile_2, In_File);
 295
 296          --  Loop to compare the two files
 297
 298          Line := 1;
 299          Col  := 1;
 300          loop
 301             C1 := Get_Char (Outfile_1);
 302             C2 := Get_Char (Outfile_2);
 303             exit when C1 = EOF or else C1 /= C2;
 304
 305             if C1 = LF then
 306                Line := Line + 1;
 307                Col  := 1;
 308             else
 309                Col := Col + 1;
 310             end if;
 311          end loop;
 312
 313          --  If we reached the end of file, then the files were identical,
 314          --  otherwise, we have a failure in the comparison.
 315
 316          if C1 = EOF then
 317             --  Success: exit silently
 318
 319             null;
 320
 321          else
 322             Ada.Text_IO.Put_Line
 323               (Argument (1) & ": failure, files log1 and log2 differ at line"
 324                & Line'Img & " column" & Col'Img);
 325          end if;
 326       end Compare_Files;
 327    end Process;
 328
 329 exception
 330    when Stop =>
 331       null;
 332 end ALFA_Test;