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    -- 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       Name := Name_Find;
 351       Text := Read_Library_Info (Name, Fatal_Err => False);
 352    end Read_Library_Info;
 353
 354    -------------------
 355    -- Set_File_Name --
 356    -------------------
 357
 358    procedure Set_File_Name (Ext : String) is
 359       Dot_Index : Natural;
 360
 361    begin
 362       Get_Name_String (Current_Main);
 363
 364       --  Find last dot since we replace the existing extension by .ali. The
 365       --  initialization to Name_Len + 1 provides for simply adding the .ali
 366       --  extension if the source file name has no extension.
 367
 368       Dot_Index := Name_Len + 1;
 369
 370       for J in reverse 1 .. Name_Len loop
 371          if Name_Buffer (J) = '.' then
 372             Dot_Index := J;
 373             exit;
 374          end if;
 375       end loop;
 376
 377       --  Make sure that the output file name matches the source file name.
 378       --  To compare them, remove file name directories and extensions.
 379
 380       if Output_Object_File_Name /= null then
 381
 382          --  Make sure there is a dot at Dot_Index. This may not be the case
 383          --  if the source file name has no extension.
 384
 385          Name_Buffer (Dot_Index) := '.';
 386
 387          --  If we are in multiple unit per file mode, then add ~nnn
 388          --  extension to the name before doing the comparison.
 389
 390          if Multiple_Unit_Index /= 0 then
 391             declare
 392                Exten : constant String := Name_Buffer (Dot_Index .. Name_Len);
 393             begin
 394                Name_Len := Dot_Index - 1;
 395                Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
 396                Add_Nat_To_Name_Buffer (Multiple_Unit_Index);
 397                Dot_Index := Name_Len + 1;
 398                Add_Str_To_Name_Buffer (Exten);
 399             end;
 400          end if;
 401
 402          --  Remove extension preparing to replace it
 403
 404          declare
 405             Name  : String  := Name_Buffer (1 .. Dot_Index);
 406             First : Positive;
 407
 408          begin
 409             Name_Buffer (1 .. Output_Object_File_Name'Length) :=
 410               Output_Object_File_Name.all;
 411
 412             --  Put two names in canonical case, to allow object file names
 413             --  with upper-case letters on Windows.
 414
 415             Canonical_Case_File_Name (Name);
 416             Canonical_Case_File_Name
 417               (Name_Buffer (1 .. Output_Object_File_Name'Length));
 418
 419             Dot_Index := 0;
 420             for J in reverse Output_Object_File_Name'Range loop
 421                if Name_Buffer (J) = '.' then
 422                   Dot_Index := J;
 423                   exit;
 424                end if;
 425             end loop;
 426
 427             --  Dot_Index should not be zero now (we check for extension
 428             --  elsewhere).
 429
 430             pragma Assert (Dot_Index /= 0);
 431
 432             --  Look for first character of file name
 433
 434             First := Dot_Index;
 435             while First > 1
 436               and then Name_Buffer (First - 1) /= Directory_Separator
 437               and then Name_Buffer (First - 1) /= '/'
 438             loop
 439                First := First - 1;
 440             end loop;
 441
 442             --  Check name of object file is what we expect
 443
 444             if Name /= Name_Buffer (First .. Dot_Index) then
 445                Fail ("incorrect object file name");
 446             end if;
 447          end;
 448       end if;
 449
 450       Name_Buffer (Dot_Index) := '.';
 451       Name_Buffer (Dot_Index + 1 .. Dot_Index + Ext'Length) := Ext;
 452       Name_Buffer (Dot_Index + Ext'Length + 1) := ASCII.NUL;
 453       Name_Len := Dot_Index + Ext'Length + 1;
 454    end Set_File_Name;
 455
 456    ---------------------------------
 457    -- Set_Output_Object_File_Name --
 458    ---------------------------------
 459
 460    procedure Set_Output_Object_File_Name (Name : String) is
 461       Ext : constant String  := Target_Object_Suffix;
 462       NL  : constant Natural := Name'Length;
 463       EL  : constant Natural := Ext'Length;
 464
 465    begin
 466       --  Make sure that the object file has the expected extension
 467
 468       if NL <= EL
 469          or else
 470           (Name (NL - EL + Name'First .. Name'Last) /= Ext
 471              and then Name (NL - 2 + Name'First .. Name'Last) /= ".o"
 472              and then
 473                (not Generate_C_Code
 474                   or else Name (NL - 2 + Name'First .. Name'Last) /= ".c"))
 475       then
 476          Fail ("incorrect object file extension");
 477       end if;
 478
 479       Output_Object_File_Name := new String'(Name);
 480    end Set_Output_Object_File_Name;
 481
 482    ----------------
 483    -- Tree_Close --
 484    ----------------
 485
 486    procedure Tree_Close is
 487       Status : Boolean;
 488    begin
 489       Tree_Write_Terminate;
 490       Close (Output_FD, Status);
 491
 492       if not Status then
 493          Fail
 494            ("error while closing tree file "
 495             & Get_Name_String (Output_File_Name));
 496       end if;
 497    end Tree_Close;
 498
 499    -----------------
 500    -- Tree_Create --
 501    -----------------
 502
 503    procedure Tree_Create is
 504       Dot_Index : Natural;
 505
 506    begin
 507       Get_Name_String (Current_Main);
 508
 509       --  If an object file has been specified, then the ALI file
 510       --  will be in the same directory as the object file;
 511       --  so, we put the tree file in this same directory,
 512       --  even though no object file needs to be generated.
 513
 514       if Output_Object_File_Name /= null then
 515          Name_Len := Output_Object_File_Name'Length;
 516          Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
 517       end if;
 518
 519       Dot_Index := Name_Len + 1;
 520
 521       for J in reverse 1 .. Name_Len loop
 522          if Name_Buffer (J) = '.' then
 523             Dot_Index := J;
 524             exit;
 525          end if;
 526       end loop;
 527
 528       --  Should be impossible to not have an extension
 529
 530       pragma Assert (Dot_Index /= 0);
 531
 532       --  Change extension to adt
 533
 534       Name_Buffer (Dot_Index) := '.';
 535       Name_Buffer (Dot_Index + 1) := 'a';
 536       Name_Buffer (Dot_Index + 2) := 'd';
 537       Name_Buffer (Dot_Index + 3) := 't';
 538       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
 539       Name_Len := Dot_Index + 3;
 540       Create_File_And_Check (Output_FD, Binary);
 541
 542       Tree_Write_Initialize (Output_FD);
 543    end Tree_Create;
 544
 545    -----------------------
 546    -- Write_Debug_Info --
 547    -----------------------
 548
 549    procedure Write_Debug_Info (Info : String) renames Write_Info;
 550
 551    ------------------------
 552    -- Write_Library_Info --
 553    ------------------------
 554
 555    procedure Write_Library_Info (Info : String) renames Write_Info;
 556
 557    ---------------------
 558    -- Write_List_Info --
 559    ---------------------
 560
 561    procedure Write_List_Info (S : String) is
 562    begin
 563       Write_With_Check (S'Address, S'Length);
 564    end Write_List_Info;
 565
 566    ------------------------
 567    -- Write_Repinfo_Line --
 568    ------------------------
 569
 570    procedure Write_Repinfo_Line (Info : String) renames Write_Info;
 571
 572 begin
 573    Adjust_OS_Resource_Limits;
 574
 575    Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access;
 576    Opt.Write_Repinfo_Line_Access  := Write_Repinfo_Line'Access;
 577    Opt.Close_Repinfo_File_Access  := Close_Repinfo_File'Access;
 578
 579    Opt.Create_List_File_Access := Create_List_File'Access;
 580    Opt.Write_List_Info_Access  := Write_List_Info'Access;
 581    Opt.Close_List_File_Access  := Close_List_File'Access;
 582
 583    Set_Program (Compiler);
 584 end Osint.C;