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