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