File : sco_test.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT SYSTEM UTILITIES --
4 -- --
5 -- S C O _ T E S T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2009-2012, 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_SCOs and
27 -- Put_SCOs units. To run it, compile any source file with switch -gnateS to
28 -- get an ALI file file.ALI containing SCO information. Then run this utility
29 -- using:
30
31 -- SCO_Test file.ali
32
33 -- This test will read the SCO information from the ALI file, and use Get_SCOs
34 -- to store this in binary form in the internal tables in SCOs. Then Put_SCO
35 -- is used to write the information from these tables back into text form.
36 -- This output is compared with the original SCO information in the ALI file
37 -- and the two should be identical. If not an error message is output.
38
39 with Get_SCOs;
40 with Put_SCOs;
41
42 with Opt; use Opt;
43 with Namet; use Namet;
44 with SCOs; use SCOs;
45 with Types; use Types;
46
47 with Ada.Command_Line; use Ada.Command_Line;
48 with Ada.Streams; use Ada.Streams;
49 with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
50 with Ada.Text_IO;
51
52 with GNAT.OS_Lib; use GNAT.OS_Lib;
53
54 procedure SCO_Test is
55 Infile : File_Type;
56 Name1 : String_Access;
57 Outfile_1 : File_Type;
58 Name2 : String_Access;
59 Outfile_2 : File_Type;
60 C : Character;
61
62 Stop : exception;
63 -- Terminate execution
64
65 Diff_Exec : constant String_Access := Locate_Exec_On_Path ("diff");
66 Diff_Result : Integer;
67
68 use ASCII;
69
70 begin
71 if Argument_Count /= 1 then
72 Ada.Text_IO.Put_Line ("Usage: sco_test FILE.ali");
73 raise Stop;
74 end if;
75
76 -- Use ALI file name in argument as base for temporary file names, so
77 -- that the diff output (if any) contains an indication of that file name.
78 -- This also allows several parallel instances of SCO_Test to run in the
79 -- same directory without clobbering each other.
80
81 Name1 := new String'(Argument (1) & ".1");
82 Name2 := new String'(Argument (1) & ".2");
83
84 Open (Infile, In_File, Argument (1));
85 Create (Outfile_1, Out_File, Name1.all);
86 Create (Outfile_2, Out_File, Name2.all);
87
88 -- Read input file till we get to first 'C' line
89
90 Process : declare
91 function Get_Char (F : File_Type) return Character;
92 -- Read one character from specified file
93
94 procedure Put_Char (F : File_Type; C : Character);
95 -- Write one character to specified file
96
97 Last_C : Character := ASCII.NUL;
98 -- Last character written to Outfile_1, to suppress blank lines
99
100 --------------
101 -- Get_Char --
102 --------------
103
104 function Get_Char (F : File_Type) return Character is
105 Item : Stream_Element_Array (1 .. 1);
106 Last : Stream_Element_Offset;
107
108 begin
109 Read (F, Item, Last);
110
111 if Last /= 1 then
112 return Types.EOF;
113 else
114 return Character'Val (Item (1));
115 end if;
116 end Get_Char;
117
118 --------------
119 -- Put_Char --
120 --------------
121
122 procedure Put_Char (F : File_Type; C : Character) is
123 Item : Stream_Element_Array (1 .. 1);
124 begin
125 if C /= CR and then C /= EOF then
126 Item (1) := Character'Pos (C);
127 Write (F, Item);
128 end if;
129 end Put_Char;
130
131 -- Subprograms used by Get_SCO (these also copy the output to Outfile_1
132 -- for later comparison with the output generated by Put_SCO).
133
134 function Getc return Character;
135 function Nextc return Character;
136 procedure Skipc;
137
138 ----------
139 -- Getc --
140 ----------
141
142 function Getc return Character is
143 C : Character;
144 begin
145 C := Get_Char (Infile);
146
147 -- Put C to Outfile_1, except when seeing multiple successive LF
148
149 if Last_C /= ASCII.LF or else C /= ASCII.LF then
150 Put_Char (Outfile_1, C);
151 Last_C := C;
152 end if;
153 return C;
154 end Getc;
155
156 -----------
157 -- Nextc --
158 -----------
159
160 function Nextc return Character is
161 C : Character;
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_SCOs, which write information to Outfile_2
184
185 procedure Write_Info_Char (C : Character);
186 procedure Write_Info_Initiate (Key : Character);
187 procedure Write_Info_Name (Nam : Name_Id);
188 procedure Write_Info_Nat (N : Nat);
189 procedure Write_Info_Terminate;
190
191 ---------------------
192 -- Write_Info_Char --
193 ---------------------
194
195 procedure Write_Info_Char (C : Character) is
196 begin
197 Put_Char (Outfile_2, C);
198 end Write_Info_Char;
199
200 -------------------------
201 -- Write_Info_Initiate --
202 -------------------------
203
204 procedure Write_Info_Initiate (Key : Character) is
205 begin
206 Write_Info_Char (Key);
207 end Write_Info_Initiate;
208
209 ---------------------
210 -- Write_Info_Name --
211 ---------------------
212
213 procedure Write_Info_Name (Nam : Name_Id) is
214 begin
215 Get_Name_String (Nam);
216 for J in 1 .. Name_Len loop
217 Write_Info_Char (Name_Buffer (J));
218 end loop;
219 end Write_Info_Name;
220
221 --------------------
222 -- Write_Info_Nat --
223 --------------------
224
225 procedure Write_Info_Nat (N : Nat) is
226 begin
227 if N > 9 then
228 Write_Info_Nat (N / 10);
229 end if;
230
231 Write_Info_Char (Character'Val (48 + N mod 10));
232 end Write_Info_Nat;
233
234 --------------------------
235 -- Write_Info_Terminate --
236 --------------------------
237
238 procedure Write_Info_Terminate is
239 begin
240 Write_Info_Char (LF);
241 end Write_Info_Terminate;
242
243 -- Local instantiations of Put_SCOs and Get_SCOs
244
245 procedure Get_SCO_Info is new Get_SCOs;
246 procedure Put_SCO_Info is new Put_SCOs;
247
248 -- Start of processing for Process
249
250 begin
251 -- Loop to skip till first C line
252
253 loop
254 C := Get_Char (Infile);
255
256 if C = EOF then
257 raise Stop;
258
259 elsif C = LF or else C = CR then
260 loop
261 C := Get_Char (Infile);
262 exit when C /= LF and then C /= CR;
263 end loop;
264
265 exit when C = 'C';
266 end if;
267 end loop;
268
269 -- Position back to initial C of first C line
270
271 Set_Index (Infile, Index (Infile) - 1);
272
273 -- Read SCOS to internal SCO tables, also copying SCO info to Outfile_1
274
275 SCOs.Initialize;
276 Get_SCO_Info;
277
278 -- Write SCOs, including instance table information, from internal SCO
279 -- tables to Outfile_2
280
281 Generate_SCO_Instance_Table := True;
282 Put_SCO_Info;
283
284 -- Note: when copying the original ALI file to Outfile_1, we remove
285 -- blank lines. So, when generating Outfile_2, we must likewise omit
286 -- the trailing blank line that normally appears in ALI files (see
287 -- comment at end of lib-writ.adb).
288
289 -- Flush to disk
290
291 Close (Outfile_1);
292 Close (Outfile_2);
293
294 -- Now Outfile_1 and Outfile_2 should be identical
295
296 Diff_Result :=
297 Spawn (Diff_Exec.all,
298 Argument_String_To_List
299 ("-u " & Name1.all & " " & Name2.all).all);
300
301 if Diff_Result /= 0 then
302 Ada.Text_IO.Put_Line ("diff(1) exit status" & Diff_Result'Img);
303 end if;
304
305 OS_Exit (Diff_Result);
306
307 end Process;
308
309 exception
310 when Stop =>
311 null;
312 end SCO_Test;