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-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
  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_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       then
 451          Fail ("incorrect object file extension");
 452       end if;
 453
 454       Output_Object_File_Name := new String'(Name);
 455    end Set_Output_Object_File_Name;
 456
 457    ----------------
 458    -- Tree_Close --
 459    ----------------
 460
 461    procedure Tree_Close is
 462       Status : Boolean;
 463    begin
 464       Tree_Write_Terminate;
 465       Close (Output_FD, Status);
 466
 467       if not Status then
 468          Fail
 469            ("error while closing tree file "
 470             & Get_Name_String (Output_File_Name));
 471       end if;
 472    end Tree_Close;
 473
 474    -----------------
 475    -- Tree_Create --
 476    -----------------
 477
 478    procedure Tree_Create is
 479       Dot_Index : Natural;
 480
 481    begin
 482       Get_Name_String (Current_Main);
 483
 484       --  If an object file has been specified, then the ALI file
 485       --  will be in the same directory as the object file;
 486       --  so, we put the tree file in this same directory,
 487       --  even though no object file needs to be generated.
 488
 489       if Output_Object_File_Name /= null then
 490          Name_Len := Output_Object_File_Name'Length;
 491          Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
 492       end if;
 493
 494       Dot_Index := Name_Len + 1;
 495
 496       for J in reverse 1 .. Name_Len loop
 497          if Name_Buffer (J) = '.' then
 498             Dot_Index := J;
 499             exit;
 500          end if;
 501       end loop;
 502
 503       --  Should be impossible to not have an extension
 504
 505       pragma Assert (Dot_Index /= 0);
 506
 507       --  Change extension to adt
 508
 509       Name_Buffer (Dot_Index) := '.';
 510       Name_Buffer (Dot_Index + 1) := 'a';
 511       Name_Buffer (Dot_Index + 2) := 'd';
 512       Name_Buffer (Dot_Index + 3) := 't';
 513       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
 514       Name_Len := Dot_Index + 3;
 515       Create_File_And_Check (Output_FD, Binary);
 516
 517       Tree_Write_Initialize (Output_FD);
 518    end Tree_Create;
 519
 520    -----------------------
 521    -- Write_Debug_Info --
 522    -----------------------
 523
 524    procedure Write_Debug_Info (Info : String) renames Write_Info;
 525
 526    ------------------------
 527    -- Write_Library_Info --
 528    ------------------------
 529
 530    procedure Write_Library_Info (Info : String) renames Write_Info;
 531
 532    ---------------------
 533    -- Write_List_Info --
 534    ---------------------
 535
 536    procedure Write_List_Info (S : String) is
 537    begin
 538       Write_With_Check (S'Address, S'Length);
 539    end Write_List_Info;
 540
 541    ------------------------
 542    -- Write_Repinfo_Line --
 543    ------------------------
 544
 545    procedure Write_Repinfo_Line (Info : String) renames Write_Info;
 546
 547 begin
 548    Adjust_OS_Resource_Limits;
 549
 550    Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access;
 551    Opt.Write_Repinfo_Line_Access  := Write_Repinfo_Line'Access;
 552    Opt.Close_Repinfo_File_Access  := Close_Repinfo_File'Access;
 553
 554    Opt.Create_List_File_Access := Create_List_File'Access;
 555    Opt.Write_List_Info_Access  := Write_List_Info'Access;
 556    Opt.Close_List_File_Access  := Close_List_File'Access;
 557
 558    Set_Program (Compiler);
 559 end Osint.C;