gcc/ada/osint-c.adb

   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
  26 with Opt;     use Opt;
  27 with Tree_IO; use Tree_IO;
  28
  29 package 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
 493 begin
 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);
 505 end Osint.C;