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