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-2018, 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       if List_Representation_Info_To_JSON then
 277          Discard := Create_Auxiliary_File (Name_Find, "json");
 278       else
 279          Discard := Create_Auxiliary_File (Name_Find, "rep");
 280       end if;
 281    end Create_Repinfo_File;
 282
 283    ---------------------------
 284    -- Debug_File_Eol_Length --
 285    ---------------------------
 286
 287    function Debug_File_Eol_Length return Nat is
 288    begin
 289       --  There has to be a cleaner way to do this ???
 290
 291       if Directory_Separator = '/' then
 292          return 1;
 293       else
 294          return 2;
 295       end if;
 296    end Debug_File_Eol_Length;
 297
 298    -------------------
 299    -- Delete_C_File --
 300    -------------------
 301
 302    procedure Delete_C_File is
 303       Dummy : Boolean;
 304    begin
 305       Set_File_Name ("c");
 306       Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
 307    end Delete_C_File;
 308
 309    -------------------
 310    -- Delete_H_File --
 311    -------------------
 312
 313    procedure Delete_H_File is
 314       Dummy : Boolean;
 315    begin
 316       Set_File_Name ("h");
 317       Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
 318    end Delete_H_File;
 319
 320    ---------------------------------
 321    -- Get_Output_Object_File_Name --
 322    ---------------------------------
 323
 324    function Get_Output_Object_File_Name return String is
 325    begin
 326       pragma Assert (Output_Object_File_Name /= null);
 327
 328       return Output_Object_File_Name.all;
 329    end Get_Output_Object_File_Name;
 330
 331    -----------------------
 332    -- More_Source_Files --
 333    -----------------------
 334
 335    function More_Source_Files return Boolean renames More_Files;
 336
 337    ----------------------
 338    -- Next_Main_Source --
 339    ----------------------
 340
 341    function Next_Main_Source return File_Name_Type renames Next_Main_File;
 342
 343    -----------------------
 344    -- Read_Library_Info --
 345    -----------------------
 346
 347    procedure Read_Library_Info
 348      (Name : out File_Name_Type;
 349       Text : out Text_Buffer_Ptr)
 350    is
 351    begin
 352       Set_File_Name (ALI_Suffix.all);
 353
 354       --  Remove trailing NUL that comes from Set_File_Name above. This is
 355       --  needed for consistency with names that come from Scan_ALI and thus
 356       --  preventing repeated scanning of the same file.
 357
 358       pragma Assert (Name_Len > 1 and then Name_Buffer (Name_Len) = ASCII.NUL);
 359       Name_Len := Name_Len - 1;
 360
 361       Name := Name_Find;
 362       Text := Read_Library_Info (Name, Fatal_Err => False);
 363    end Read_Library_Info;
 364
 365    -------------------
 366    -- Set_File_Name --
 367    -------------------
 368
 369    procedure Set_File_Name (Ext : String) is
 370       Dot_Index : Natural;
 371
 372    begin
 373       Get_Name_String (Current_Main);
 374
 375       --  Find last dot since we replace the existing extension by .ali. The
 376       --  initialization to Name_Len + 1 provides for simply adding the .ali
 377       --  extension if the source file name has no extension.
 378
 379       Dot_Index := Name_Len + 1;
 380
 381       for J in reverse 1 .. Name_Len loop
 382          if Name_Buffer (J) = '.' then
 383             Dot_Index := J;
 384             exit;
 385          end if;
 386       end loop;
 387
 388       --  Make sure that the output file name matches the source file name.
 389       --  To compare them, remove file name directories and extensions.
 390
 391       if Output_Object_File_Name /= null then
 392
 393          --  Make sure there is a dot at Dot_Index. This may not be the case
 394          --  if the source file name has no extension.
 395
 396          Name_Buffer (Dot_Index) := '.';
 397
 398          --  If we are in multiple unit per file mode, then add ~nnn
 399          --  extension to the name before doing the comparison.
 400
 401          if Multiple_Unit_Index /= 0 then
 402             declare
 403                Exten : constant String := Name_Buffer (Dot_Index .. Name_Len);
 404             begin
 405                Name_Len := Dot_Index - 1;
 406                Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
 407                Add_Nat_To_Name_Buffer (Multiple_Unit_Index);
 408                Dot_Index := Name_Len + 1;
 409                Add_Str_To_Name_Buffer (Exten);
 410             end;
 411          end if;
 412
 413          --  Remove extension preparing to replace it
 414
 415          declare
 416             Name  : String  := Name_Buffer (1 .. Dot_Index);
 417             First : Positive;
 418
 419          begin
 420             Name_Buffer (1 .. Output_Object_File_Name'Length) :=
 421               Output_Object_File_Name.all;
 422
 423             --  Put two names in canonical case, to allow object file names
 424             --  with upper-case letters on Windows.
 425
 426             Canonical_Case_File_Name (Name);
 427             Canonical_Case_File_Name
 428               (Name_Buffer (1 .. Output_Object_File_Name'Length));
 429
 430             Dot_Index := 0;
 431             for J in reverse Output_Object_File_Name'Range loop
 432                if Name_Buffer (J) = '.' then
 433                   Dot_Index := J;
 434                   exit;
 435                end if;
 436             end loop;
 437
 438             --  Dot_Index should not be zero now (we check for extension
 439             --  elsewhere).
 440
 441             pragma Assert (Dot_Index /= 0);
 442
 443             --  Look for first character of file name
 444
 445             First := Dot_Index;
 446             while First > 1
 447               and then Name_Buffer (First - 1) /= Directory_Separator
 448               and then Name_Buffer (First - 1) /= '/'
 449             loop
 450                First := First - 1;
 451             end loop;
 452
 453             --  Check name of object file is what we expect
 454
 455             if Name /= Name_Buffer (First .. Dot_Index) then
 456                Fail ("incorrect object file name");
 457             end if;
 458          end;
 459       end if;
 460
 461       Name_Buffer (Dot_Index) := '.';
 462       Name_Buffer (Dot_Index + 1 .. Dot_Index + Ext'Length) := Ext;
 463       Name_Buffer (Dot_Index + Ext'Length + 1) := ASCII.NUL;
 464       Name_Len := Dot_Index + Ext'Length + 1;
 465    end Set_File_Name;
 466
 467    ---------------------------------
 468    -- Set_Output_Object_File_Name --
 469    ---------------------------------
 470
 471    procedure Set_Output_Object_File_Name (Name : String) is
 472       Ext : constant String  := Target_Object_Suffix;
 473       NL  : constant Natural := Name'Length;
 474       EL  : constant Natural := Ext'Length;
 475
 476    begin
 477       --  Make sure that the object file has the expected extension
 478
 479       if NL <= EL
 480          or else
 481           (Name (NL - EL + Name'First .. Name'Last) /= Ext
 482              and then Name (NL - 2 + Name'First .. Name'Last) /= ".o"
 483              and then
 484                (not Generate_C_Code
 485                   or else Name (NL - 2 + Name'First .. Name'Last) /= ".c"))
 486       then
 487          Fail ("incorrect object file extension");
 488       end if;
 489
 490       Output_Object_File_Name := new String'(Name);
 491    end Set_Output_Object_File_Name;
 492
 493    ----------------
 494    -- Tree_Close --
 495    ----------------
 496
 497    procedure Tree_Close is
 498       Status : Boolean;
 499    begin
 500       Tree_Write_Terminate;
 501       Close (Output_FD, Status);
 502
 503       if not Status then
 504          Fail
 505            ("error while closing tree file "
 506             & Get_Name_String (Output_File_Name));
 507       end if;
 508    end Tree_Close;
 509
 510    -----------------
 511    -- Tree_Create --
 512    -----------------
 513
 514    procedure Tree_Create is
 515       Dot_Index : Natural;
 516
 517    begin
 518       Get_Name_String (Current_Main);
 519
 520       --  If an object file has been specified, then the ALI file
 521       --  will be in the same directory as the object file;
 522       --  so, we put the tree file in this same directory,
 523       --  even though no object file needs to be generated.
 524
 525       if Output_Object_File_Name /= null then
 526          Name_Len := Output_Object_File_Name'Length;
 527          Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
 528       end if;
 529
 530       Dot_Index := Name_Len + 1;
 531
 532       for J in reverse 1 .. Name_Len loop
 533          if Name_Buffer (J) = '.' then
 534             Dot_Index := J;
 535             exit;
 536          end if;
 537       end loop;
 538
 539       --  Should be impossible to not have an extension
 540
 541       pragma Assert (Dot_Index /= 0);
 542
 543       --  Change extension to adt
 544
 545       Name_Buffer (Dot_Index) := '.';
 546       Name_Buffer (Dot_Index + 1) := 'a';
 547       Name_Buffer (Dot_Index + 2) := 'd';
 548       Name_Buffer (Dot_Index + 3) := 't';
 549       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
 550       Name_Len := Dot_Index + 3;
 551       Create_File_And_Check (Output_FD, Binary);
 552
 553       Tree_Write_Initialize (Output_FD);
 554    end Tree_Create;
 555
 556    -----------------------
 557    -- Write_Debug_Info --
 558    -----------------------
 559
 560    procedure Write_Debug_Info (Info : String) renames Write_Info;
 561
 562    ------------------------
 563    -- Write_Library_Info --
 564    ------------------------
 565
 566    procedure Write_Library_Info (Info : String) renames Write_Info;
 567
 568    ---------------------
 569    -- Write_List_Info --
 570    ---------------------
 571
 572    procedure Write_List_Info (S : String) is
 573    begin
 574       Write_With_Check (S'Address, S'Length);
 575    end Write_List_Info;
 576
 577    ------------------------
 578    -- Write_Repinfo_Line --
 579    ------------------------
 580
 581    procedure Write_Repinfo_Line (Info : String) renames Write_Info;
 582
 583 begin
 584    Adjust_OS_Resource_Limits;
 585
 586    Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access;
 587    Opt.Write_Repinfo_Line_Access  := Write_Repinfo_Line'Access;
 588    Opt.Close_Repinfo_File_Access  := Close_Repinfo_File'Access;
 589
 590    Opt.Create_List_File_Access := Create_List_File'Access;
 591    Opt.Write_List_Info_Access  := Write_List_Info'Access;
 592    Opt.Close_List_File_Access  := Close_List_File'Access;
 593
 594    Set_Program (Compiler);
 595 end Osint.C;