1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- O S I N T - C -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2014, 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 26with Opt; use Opt; 27with Tree_IO; use Tree_IO; 28 29package body Osint.C is 30 31 Output_Object_File_Name : String_Ptr; 32 -- Argument of -o compiler option, if given. This is needed to verify 33 -- consistency with the ALI file name. 34 35 procedure Adjust_OS_Resource_Limits; 36 pragma Import (C, Adjust_OS_Resource_Limits, 37 "__gnat_adjust_os_resource_limits"); 38 -- Procedure to make system specific adjustments to make GNAT run better 39 40 function Create_Auxiliary_File 41 (Src : File_Name_Type; 42 Suffix : String) return File_Name_Type; 43 -- Common processing for Create_List_File, Create_Repinfo_File and 44 -- Create_Debug_File. Src is the file name used to create the required 45 -- output file and Suffix is the desired suffix (dg/rep/xxx for debug/ 46 -- repinfo/list file where xxx is specified extension. 47 48 ---------------------- 49 -- Close_Debug_File -- 50 ---------------------- 51 52 procedure Close_Debug_File is 53 Status : Boolean; 54 55 begin 56 Close (Output_FD, Status); 57 58 if not Status then 59 Fail 60 ("error while closing expanded source file " 61 & Get_Name_String (Output_File_Name)); 62 end if; 63 end Close_Debug_File; 64 65 --------------------- 66 -- Close_List_File -- 67 --------------------- 68 69 procedure Close_List_File is 70 Status : Boolean; 71 72 begin 73 Close (Output_FD, Status); 74 75 if not Status then 76 Fail 77 ("error while closing list file " 78 & Get_Name_String (Output_File_Name)); 79 end if; 80 end Close_List_File; 81 82 ------------------------------- 83 -- Close_Output_Library_Info -- 84 ------------------------------- 85 86 procedure Close_Output_Library_Info is 87 Status : Boolean; 88 89 begin 90 Close (Output_FD, Status); 91 92 if not Status then 93 Fail 94 ("error while closing ALI file " 95 & Get_Name_String (Output_File_Name)); 96 end if; 97 end Close_Output_Library_Info; 98 99 ------------------------ 100 -- Close_Repinfo_File -- 101 ------------------------ 102 103 procedure Close_Repinfo_File is 104 Status : Boolean; 105 106 begin 107 Close (Output_FD, Status); 108 109 if not Status then 110 Fail 111 ("error while closing representation info file " 112 & Get_Name_String (Output_File_Name)); 113 end if; 114 end Close_Repinfo_File; 115 116 --------------------------- 117 -- Create_Auxiliary_File -- 118 --------------------------- 119 120 function Create_Auxiliary_File 121 (Src : File_Name_Type; 122 Suffix : String) return File_Name_Type 123 is 124 Result : File_Name_Type; 125 126 begin 127 Get_Name_String (Src); 128 129 Name_Buffer (Name_Len + 1) := '.'; 130 Name_Len := Name_Len + 1; 131 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; 132 Name_Len := Name_Len + Suffix'Length; 133 134 if Output_Object_File_Name /= null then 135 for Index in reverse Output_Object_File_Name'Range loop 136 if Output_Object_File_Name (Index) = Directory_Separator then 137 declare 138 File_Name : constant String := Name_Buffer (1 .. Name_Len); 139 begin 140 Name_Len := Index - Output_Object_File_Name'First + 1; 141 Name_Buffer (1 .. Name_Len) := 142 Output_Object_File_Name 143 (Output_Object_File_Name'First .. Index); 144 Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) := 145 File_Name; 146 Name_Len := Name_Len + File_Name'Length; 147 end; 148 149 exit; 150 end if; 151 end loop; 152 end if; 153 154 Result := Name_Find; 155 Name_Buffer (Name_Len + 1) := ASCII.NUL; 156 Create_File_And_Check (Output_FD, Text); 157 return Result; 158 end Create_Auxiliary_File; 159 160 ----------------------- 161 -- Create_Debug_File -- 162 ----------------------- 163 164 function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is 165 begin 166 return Create_Auxiliary_File (Src, "dg"); 167 end Create_Debug_File; 168 169 ---------------------- 170 -- Create_List_File -- 171 ---------------------- 172 173 procedure Create_List_File (S : String) is 174 F : File_Name_Type; 175 pragma Warnings (Off, F); 176 begin 177 if S (S'First) = '.' then 178 F := Create_Auxiliary_File (Current_Main, S (S'First + 1 .. S'Last)); 179 180 else 181 Name_Buffer (1 .. S'Length) := S; 182 Name_Len := S'Length + 1; 183 Name_Buffer (Name_Len) := ASCII.NUL; 184 Create_File_And_Check (Output_FD, Text); 185 end if; 186 end Create_List_File; 187 188 -------------------------------- 189 -- Create_Output_Library_Info -- 190 -------------------------------- 191 192 procedure Create_Output_Library_Info is 193 Dummy : Boolean; 194 begin 195 Set_Library_Info_Name; 196 Delete_File (Name_Buffer (1 .. Name_Len), Dummy); 197 Create_File_And_Check (Output_FD, Text); 198 end Create_Output_Library_Info; 199 200 ------------------------------ 201 -- Open_Output_Library_Info -- 202 ------------------------------ 203 204 procedure Open_Output_Library_Info is 205 begin 206 Set_Library_Info_Name; 207 Open_File_To_Append_And_Check (Output_FD, Text); 208 end Open_Output_Library_Info; 209 210 ------------------------- 211 -- Create_Repinfo_File -- 212 ------------------------- 213 214 procedure Create_Repinfo_File (Src : String) is 215 Discard : File_Name_Type; 216 pragma Warnings (Off, Discard); 217 begin 218 Name_Buffer (1 .. Src'Length) := Src; 219 Name_Len := Src'Length; 220 Discard := Create_Auxiliary_File (Name_Find, "rep"); 221 return; 222 end Create_Repinfo_File; 223 224 --------------------------- 225 -- Debug_File_Eol_Length -- 226 --------------------------- 227 228 function Debug_File_Eol_Length return Nat is 229 begin 230 -- There has to be a cleaner way to do this ??? 231 232 if Directory_Separator = '/' then 233 return 1; 234 else 235 return 2; 236 end if; 237 end Debug_File_Eol_Length; 238 239 --------------------------------- 240 -- Get_Output_Object_File_Name -- 241 --------------------------------- 242 243 function Get_Output_Object_File_Name return String is 244 begin 245 pragma Assert (Output_Object_File_Name /= null); 246 247 return Output_Object_File_Name.all; 248 end Get_Output_Object_File_Name; 249 250 ----------------------- 251 -- More_Source_Files -- 252 ----------------------- 253 254 function More_Source_Files return Boolean renames More_Files; 255 256 ---------------------- 257 -- Next_Main_Source -- 258 ---------------------- 259 260 function Next_Main_Source return File_Name_Type renames Next_Main_File; 261 262 ----------------------- 263 -- Read_Library_Info -- 264 ----------------------- 265 266 -- Version with default file name 267 268 procedure Read_Library_Info 269 (Name : out File_Name_Type; 270 Text : out Text_Buffer_Ptr) 271 is 272 begin 273 Set_Library_Info_Name; 274 Name := Name_Find; 275 Text := Read_Library_Info (Name, Fatal_Err => False); 276 end Read_Library_Info; 277 278 --------------------------- 279 -- Set_Library_Info_Name -- 280 --------------------------- 281 282 procedure Set_Library_Info_Name is 283 Dot_Index : Natural; 284 285 begin 286 Get_Name_String (Current_Main); 287 288 -- Find last dot since we replace the existing extension by .ali. The 289 -- initialization to Name_Len + 1 provides for simply adding the .ali 290 -- extension if the source file name has no extension. 291 292 Dot_Index := Name_Len + 1; 293 294 for J in reverse 1 .. Name_Len loop 295 if Name_Buffer (J) = '.' then 296 Dot_Index := J; 297 exit; 298 end if; 299 end loop; 300 301 -- Make sure that the output file name matches the source file name. 302 -- To compare them, remove file name directories and extensions. 303 304 if Output_Object_File_Name /= null then 305 306 -- Make sure there is a dot at Dot_Index. This may not be the case 307 -- if the source file name has no extension. 308 309 Name_Buffer (Dot_Index) := '.'; 310 311 -- If we are in multiple unit per file mode, then add ~nnn 312 -- extension to the name before doing the comparison. 313 314 if Multiple_Unit_Index /= 0 then 315 declare 316 Exten : constant String := Name_Buffer (Dot_Index .. Name_Len); 317 begin 318 Name_Len := Dot_Index - 1; 319 Add_Char_To_Name_Buffer (Multi_Unit_Index_Character); 320 Add_Nat_To_Name_Buffer (Multiple_Unit_Index); 321 Dot_Index := Name_Len + 1; 322 Add_Str_To_Name_Buffer (Exten); 323 end; 324 end if; 325 326 -- Remove extension preparing to replace it 327 328 declare 329 Name : String := Name_Buffer (1 .. Dot_Index); 330 First : Positive; 331 332 begin 333 Name_Buffer (1 .. Output_Object_File_Name'Length) := 334 Output_Object_File_Name.all; 335 336 -- Put two names in canonical case, to allow object file names 337 -- with upper-case letters on Windows. 338 339 Canonical_Case_File_Name (Name); 340 Canonical_Case_File_Name 341 (Name_Buffer (1 .. Output_Object_File_Name'Length)); 342 343 Dot_Index := 0; 344 for J in reverse Output_Object_File_Name'Range loop 345 if Name_Buffer (J) = '.' then 346 Dot_Index := J; 347 exit; 348 end if; 349 end loop; 350 351 -- Dot_Index should not be zero now (we check for extension 352 -- elsewhere). 353 354 pragma Assert (Dot_Index /= 0); 355 356 -- Look for first character of file name 357 358 First := Dot_Index; 359 while First > 1 360 and then Name_Buffer (First - 1) /= Directory_Separator 361 and then Name_Buffer (First - 1) /= '/' 362 loop 363 First := First - 1; 364 end loop; 365 366 -- Check name of object file is what we expect 367 368 if Name /= Name_Buffer (First .. Dot_Index) then 369 Fail ("incorrect object file name"); 370 end if; 371 end; 372 end if; 373 374 Name_Buffer (Dot_Index) := '.'; 375 Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all; 376 Name_Buffer (Dot_Index + 4) := ASCII.NUL; 377 Name_Len := Dot_Index + 3; 378 end Set_Library_Info_Name; 379 380 --------------------------------- 381 -- Set_Output_Object_File_Name -- 382 --------------------------------- 383 384 procedure Set_Output_Object_File_Name (Name : String) is 385 Ext : constant String := Target_Object_Suffix; 386 NL : constant Natural := Name'Length; 387 EL : constant Natural := Ext'Length; 388 389 begin 390 -- Make sure that the object file has the expected extension 391 392 if NL <= EL 393 or else 394 (Name (NL - EL + Name'First .. Name'Last) /= Ext 395 and then Name (NL - 2 + Name'First .. Name'Last) /= ".o") 396 then 397 Fail ("incorrect object file extension"); 398 end if; 399 400 Output_Object_File_Name := new String'(Name); 401 end Set_Output_Object_File_Name; 402 403 ---------------- 404 -- Tree_Close -- 405 ---------------- 406 407 procedure Tree_Close is 408 Status : Boolean; 409 begin 410 Tree_Write_Terminate; 411 Close (Output_FD, Status); 412 413 if not Status then 414 Fail 415 ("error while closing tree file " 416 & Get_Name_String (Output_File_Name)); 417 end if; 418 end Tree_Close; 419 420 ----------------- 421 -- Tree_Create -- 422 ----------------- 423 424 procedure Tree_Create is 425 Dot_Index : Natural; 426 427 begin 428 Get_Name_String (Current_Main); 429 430 -- If an object file has been specified, then the ALI file 431 -- will be in the same directory as the object file; 432 -- so, we put the tree file in this same directory, 433 -- even though no object file needs to be generated. 434 435 if Output_Object_File_Name /= null then 436 Name_Len := Output_Object_File_Name'Length; 437 Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all; 438 end if; 439 440 Dot_Index := Name_Len + 1; 441 442 for J in reverse 1 .. Name_Len loop 443 if Name_Buffer (J) = '.' then 444 Dot_Index := J; 445 exit; 446 end if; 447 end loop; 448 449 -- Should be impossible to not have an extension 450 451 pragma Assert (Dot_Index /= 0); 452 453 -- Change extension to adt 454 455 Name_Buffer (Dot_Index) := '.'; 456 Name_Buffer (Dot_Index + 1) := 'a'; 457 Name_Buffer (Dot_Index + 2) := 'd'; 458 Name_Buffer (Dot_Index + 3) := 't'; 459 Name_Buffer (Dot_Index + 4) := ASCII.NUL; 460 Name_Len := Dot_Index + 3; 461 Create_File_And_Check (Output_FD, Binary); 462 463 Tree_Write_Initialize (Output_FD); 464 end Tree_Create; 465 466 ----------------------- 467 -- Write_Debug_Info -- 468 ----------------------- 469 470 procedure Write_Debug_Info (Info : String) renames Write_Info; 471 472 ------------------------ 473 -- Write_Library_Info -- 474 ------------------------ 475 476 procedure Write_Library_Info (Info : String) renames Write_Info; 477 478 --------------------- 479 -- Write_List_Info -- 480 --------------------- 481 482 procedure Write_List_Info (S : String) is 483 begin 484 Write_With_Check (S'Address, S'Length); 485 end Write_List_Info; 486 487 ------------------------ 488 -- Write_Repinfo_Line -- 489 ------------------------ 490 491 procedure Write_Repinfo_Line (Info : String) renames Write_Info; 492 493begin 494 Adjust_OS_Resource_Limits; 495 496 Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access; 497 Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access; 498 Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access; 499 500 Opt.Create_List_File_Access := Create_List_File'Access; 501 Opt.Write_List_Info_Access := Write_List_Info'Access; 502 Opt.Close_List_File_Access := Close_List_File'Access; 503 504 Set_Program (Compiler); 505end Osint.C; 506