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 39with Get_Alfa; 40with Put_Alfa; 41 42with Alfa; use Alfa; 43with Types; use Types; 44 45with Ada.Command_Line; use Ada.Command_Line; 46with Ada.Streams; use Ada.Streams; 47with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; 48with Ada.Text_IO; 49 50with GNAT.OS_Lib; use GNAT.OS_Lib; 51 52procedure 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 68begin 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 314exception 315 when Stop => 316 null; 317end Alfa_Test; 318