1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
5 -- A L F A _ T E S T --
9 -- Copyright (C) 2011, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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:
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.
43 with Types; use Types;
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;
50 with GNAT.OS_Lib; use GNAT.OS_Lib;
52 procedure Alfa_Test is
54 Name1 : String_Access;
55 Outfile_1 : File_Type;
56 Name2 : String_Access;
57 Outfile_2 : File_Type;
61 -- Terminate execution
63 Diff_Exec : constant String_Access := Locate_Exec_On_Path ("diff");
64 Diff_Result : Integer;
69 if Argument_Count /= 1 then
70 Ada.Text_IO.Put_Line ("Usage: alfa_test FILE.ali");
74 Name1 := new String'(Argument (1) & ".1");
75 Name2 := new String'(Argument (1) & ".2");
77 Open (Infile, In_File, Argument (1));
78 Create (Outfile_1, Out_File, Name1.all);
79 Create (Outfile_2, Out_File, Name2.all);
81 -- Read input file till we get to first 'F' line
84 Output_Col : Positive := 1;
86 function Get_Char (F : File_Type) return Character;
87 -- Read one character from specified file
89 procedure Put_Char (F : File_Type; C : Character);
90 -- Write one character to specified file
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.
101 function Get_Char (F : File_Type) return Character is
102 Item : Stream_Element_Array (1 .. 1);
103 Last : Stream_Element_Offset;
106 Read (F, Item, Last);
111 return Character'Val (Item (1));
119 function Get_Output_Col return Positive is
128 procedure Put_Char (F : File_Type; C : Character) is
129 Item : Stream_Element_Array (1 .. 1);
132 if C /= CR and then C /= EOF then
136 Output_Col := ((Output_Col + 6) / 8) * 8 + 1;
138 Output_Col := Output_Col + 1;
141 Item (1) := Character'Pos (C);
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).
149 function Getc return Character;
150 function Nextc return Character;
157 function Getc return Character is
160 C := Get_Char (Infile);
161 Put_Char (Outfile_1, C);
169 function Nextc return Character is
173 C := Get_Char (Infile);
176 Set_Index (Infile, Index (Infile) - 1);
188 pragma Unreferenced (C);
193 -- Subprograms used by Put_Alfa, which write information to Outfile_2
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;
205 function Write_Info_Col return Positive is
207 return Get_Output_Col;
210 ---------------------
211 -- Write_Info_Char --
212 ---------------------
214 procedure Write_Info_Char (C : Character) is
216 Put_Char (Outfile_2, C);
219 -------------------------
220 -- Write_Info_Initiate --
221 -------------------------
223 procedure Write_Info_Initiate (Key : Character) is
225 Write_Info_Char (Key);
226 end Write_Info_Initiate;
232 procedure Write_Info_Nat (N : Nat) is
235 Write_Info_Nat (N / 10);
238 Write_Info_Char (Character'Val (48 + N mod 10));
241 --------------------------
242 -- Write_Info_Terminate --
243 --------------------------
245 procedure Write_Info_Terminate is
247 Write_Info_Char (LF);
248 end Write_Info_Terminate;
250 -- Local instantiations of Put_Alfa and Get_Alfa
252 procedure Get_Alfa_Info is new Get_Alfa;
253 procedure Put_Alfa_Info is new Put_Alfa;
255 -- Start of processing for Process
258 -- Loop to skip till first 'F' line
261 C := Get_Char (Infile);
266 elsif C = LF or else C = CR then
268 C := Get_Char (Infile);
269 exit when C /= LF and then C /= CR;
276 -- Position back to initial 'F' of first 'F' line
278 Set_Index (Infile, Index (Infile) - 1);
280 -- Read Alfa information to internal Alfa tables, also copying Alfa info
283 Initialize_Alfa_Tables;
286 -- Write Alfa information from internal Alfa tables to Outfile_2
290 -- Junk blank line (see comment at end of Lib.Writ)
292 Write_Info_Terminate;
299 -- Now Outfile_1 and Outfile_2 should be identical
302 Spawn (Diff_Exec.all,
303 Argument_String_To_List
304 ("-u " & Name1.all & " " & Name2.all).all);
306 if Diff_Result /= 0 then
307 Ada.Text_IO.Put_Line ("diff(1) exit status" & Diff_Result'Img);
310 OS_Exit (Diff_Result);