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-2018, 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 -- Delete_C_File -- 297 ------------------- 298 299 procedure Delete_C_File is 300 Dummy : Boolean; 301 begin 302 Set_File_Name ("c"); 303 Delete_File (Name_Buffer (1 .. Name_Len), Dummy); 304 end Delete_C_File; 305 306 ------------------- 307 -- Delete_H_File -- 308 ------------------- 309 310 procedure Delete_H_File is 311 Dummy : Boolean; 312 begin 313 Set_File_Name ("h"); 314 Delete_File (Name_Buffer (1 .. Name_Len), Dummy); 315 end Delete_H_File; 316 317 --------------------------------- 318 -- Get_Output_Object_File_Name -- 319 --------------------------------- 320 321 function Get_Output_Object_File_Name return String is 322 begin 323 pragma Assert (Output_Object_File_Name /= null); 324 325 return Output_Object_File_Name.all; 326 end Get_Output_Object_File_Name; 327 328 ----------------------- 329 -- More_Source_Files -- 330 ----------------------- 331 332 function More_Source_Files return Boolean renames More_Files; 333 334 ---------------------- 335 -- Next_Main_Source -- 336 ---------------------- 337 338 function Next_Main_Source return File_Name_Type renames Next_Main_File; 339 340 ----------------------- 341 -- Read_Library_Info -- 342 ----------------------- 343 344 procedure Read_Library_Info 345 (Name : out File_Name_Type; 346 Text : out Text_Buffer_Ptr) 347 is 348 begin 349 Set_File_Name (ALI_Suffix.all); 350 351 -- Remove trailing NUL that comes from Set_File_Name above. This is 352 -- needed for consistency with names that come from Scan_ALI and thus 353 -- preventing repeated scanning of the same file. 354 355 pragma Assert (Name_Len > 1 and then Name_Buffer (Name_Len) = ASCII.NUL); 356 Name_Len := Name_Len - 1; 357 358 Name := Name_Find; 359 Text := Read_Library_Info (Name, Fatal_Err => False); 360 end Read_Library_Info; 361 362 ------------------- 363 -- Set_File_Name -- 364 ------------------- 365 366 procedure Set_File_Name (Ext : String) is 367 Dot_Index : Natural; 368 369 begin 370 Get_Name_String (Current_Main); 371 372 -- Find last dot since we replace the existing extension by .ali. The 373 -- initialization to Name_Len + 1 provides for simply adding the .ali 374 -- extension if the source file name has no extension. 375 376 Dot_Index := Name_Len + 1; 377 378 for J in reverse 1 .. Name_Len loop 379 if Name_Buffer (J) = '.' then 380 Dot_Index := J; 381 exit; 382 end if; 383 end loop; 384 385 -- Make sure that the output file name matches the source file name. 386 -- To compare them, remove file name directories and extensions. 387 388 if Output_Object_File_Name /= null then 389 390 -- Make sure there is a dot at Dot_Index. This may not be the case 391 -- if the source file name has no extension. 392 393 Name_Buffer (Dot_Index) := '.'; 394 395 -- If we are in multiple unit per file mode, then add ~nnn 396 -- extension to the name before doing the comparison. 397 398 if Multiple_Unit_Index /= 0 then 399 declare 400 Exten : constant String := Name_Buffer (Dot_Index .. Name_Len); 401 begin 402 Name_Len := Dot_Index - 1; 403 Add_Char_To_Name_Buffer (Multi_Unit_Index_Character); 404 Add_Nat_To_Name_Buffer (Multiple_Unit_Index); 405 Dot_Index := Name_Len + 1; 406 Add_Str_To_Name_Buffer (Exten); 407 end; 408 end if; 409 410 -- Remove extension preparing to replace it 411 412 declare 413 Name : String := Name_Buffer (1 .. Dot_Index); 414 First : Positive; 415 416 begin 417 Name_Buffer (1 .. Output_Object_File_Name'Length) := 418 Output_Object_File_Name.all; 419 420 -- Put two names in canonical case, to allow object file names 421 -- with upper-case letters on Windows. 422 423 Canonical_Case_File_Name (Name); 424 Canonical_Case_File_Name 425 (Name_Buffer (1 .. Output_Object_File_Name'Length)); 426 427 Dot_Index := 0; 428 for J in reverse Output_Object_File_Name'Range loop 429 if Name_Buffer (J) = '.' then 430 Dot_Index := J; 431 exit; 432 end if; 433 end loop; 434 435 -- Dot_Index should not be zero now (we check for extension 436 -- elsewhere). 437 438 pragma Assert (Dot_Index /= 0); 439 440 -- Look for first character of file name 441 442 First := Dot_Index; 443 while First > 1 444 and then Name_Buffer (First - 1) /= Directory_Separator 445 and then Name_Buffer (First - 1) /= '/' 446 loop 447 First := First - 1; 448 end loop; 449 450 -- Check name of object file is what we expect 451 452 if Name /= Name_Buffer (First .. Dot_Index) then 453 Fail ("incorrect object file name"); 454 end if; 455 end; 456 end if; 457 458 Name_Buffer (Dot_Index) := '.'; 459 Name_Buffer (Dot_Index + 1 .. Dot_Index + Ext'Length) := Ext; 460 Name_Buffer (Dot_Index + Ext'Length + 1) := ASCII.NUL; 461 Name_Len := Dot_Index + Ext'Length + 1; 462 end Set_File_Name; 463 464 --------------------------------- 465 -- Set_Output_Object_File_Name -- 466 --------------------------------- 467 468 procedure Set_Output_Object_File_Name (Name : String) is 469 Ext : constant String := Target_Object_Suffix; 470 NL : constant Natural := Name'Length; 471 EL : constant Natural := Ext'Length; 472 473 begin 474 -- Make sure that the object file has the expected extension 475 476 if NL <= EL 477 or else 478 (Name (NL - EL + Name'First .. Name'Last) /= Ext 479 and then Name (NL - 2 + Name'First .. Name'Last) /= ".o" 480 and then 481 (not Generate_C_Code 482 or else Name (NL - 2 + Name'First .. Name'Last) /= ".c")) 483 then 484 Fail ("incorrect object file extension"); 485 end if; 486 487 Output_Object_File_Name := new String'(Name); 488 end Set_Output_Object_File_Name; 489 490 ---------------- 491 -- Tree_Close -- 492 ---------------- 493 494 procedure Tree_Close is 495 Status : Boolean; 496 begin 497 Tree_Write_Terminate; 498 Close (Output_FD, Status); 499 500 if not Status then 501 Fail 502 ("error while closing tree file " 503 & Get_Name_String (Output_File_Name)); 504 end if; 505 end Tree_Close; 506 507 ----------------- 508 -- Tree_Create -- 509 ----------------- 510 511 procedure Tree_Create is 512 Dot_Index : Natural; 513 514 begin 515 Get_Name_String (Current_Main); 516 517 -- If an object file has been specified, then the ALI file 518 -- will be in the same directory as the object file; 519 -- so, we put the tree file in this same directory, 520 -- even though no object file needs to be generated. 521 522 if Output_Object_File_Name /= null then 523 Name_Len := Output_Object_File_Name'Length; 524 Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all; 525 end if; 526 527 Dot_Index := Name_Len + 1; 528 529 for J in reverse 1 .. Name_Len loop 530 if Name_Buffer (J) = '.' then 531 Dot_Index := J; 532 exit; 533 end if; 534 end loop; 535 536 -- Should be impossible to not have an extension 537 538 pragma Assert (Dot_Index /= 0); 539 540 -- Change extension to adt 541 542 Name_Buffer (Dot_Index) := '.'; 543 Name_Buffer (Dot_Index + 1) := 'a'; 544 Name_Buffer (Dot_Index + 2) := 'd'; 545 Name_Buffer (Dot_Index + 3) := 't'; 546 Name_Buffer (Dot_Index + 4) := ASCII.NUL; 547 Name_Len := Dot_Index + 3; 548 Create_File_And_Check (Output_FD, Binary); 549 550 Tree_Write_Initialize (Output_FD); 551 end Tree_Create; 552 553 ----------------------- 554 -- Write_Debug_Info -- 555 ----------------------- 556 557 procedure Write_Debug_Info (Info : String) renames Write_Info; 558 559 ------------------------ 560 -- Write_Library_Info -- 561 ------------------------ 562 563 procedure Write_Library_Info (Info : String) renames Write_Info; 564 565 --------------------- 566 -- Write_List_Info -- 567 --------------------- 568 569 procedure Write_List_Info (S : String) is 570 begin 571 Write_With_Check (S'Address, S'Length); 572 end Write_List_Info; 573 574 ------------------------ 575 -- Write_Repinfo_Line -- 576 ------------------------ 577 578 procedure Write_Repinfo_Line (Info : String) renames Write_Info; 579 580begin 581 Adjust_OS_Resource_Limits; 582 583 Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access; 584 Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access; 585 Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access; 586 587 Opt.Create_List_File_Access := Create_List_File'Access; 588 Opt.Write_List_Info_Access := Write_List_Info'Access; 589 Opt.Close_List_File_Access := Close_List_File'Access; 590 591 Set_Program (Compiler); 592end Osint.C; 593