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-2016, 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    -- 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
 580 begin
 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);
 592 end Osint.C;