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-2011, 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 Hostparm;
  27 with Opt;      use Opt;
  28 with Tree_IO;  use Tree_IO;
  29
  30 package body Osint.C is
  31
  32    Output_Object_File_Name : String_Ptr;
  33    --  Argument of -o compiler option, if given. This is needed to verify
  34    --  consistency with the ALI file name.
  35
  36    procedure Adjust_OS_Resource_Limits;
  37    pragma Import (C, Adjust_OS_Resource_Limits,
  38                   "__gnat_adjust_os_resource_limits");
  39    --  Procedure to make system specific adjustments to make GNAT run better
  40
  41    function Create_Auxiliary_File
  42      (Src    : File_Name_Type;
  43       Suffix : String) return File_Name_Type;
  44    --  Common processing for Create_List_File, Create_Repinfo_File and
  45    --  Create_Debug_File. Src is the file name used to create the required
  46    --  output file and Suffix is the desired suffix (dg/rep/xxx for debug/
  47    --  repinfo/list file where xxx is specified extension.
  48
  49    ----------------------
  50    -- Close_Debug_File --
  51    ----------------------
  52
  53    procedure Close_Debug_File is
  54       Status : Boolean;
  55
  56    begin
  57       Close (Output_FD, Status);
  58
  59       if not Status then
  60          Fail
  61            ("error while closing expanded source file "
  62             & Get_Name_String (Output_File_Name));
  63       end if;
  64    end Close_Debug_File;
  65
  66    ---------------------
  67    -- Close_List_File --
  68    ---------------------
  69
  70    procedure Close_List_File is
  71       Status : Boolean;
  72
  73    begin
  74       Close (Output_FD, Status);
  75
  76       if not Status then
  77          Fail
  78            ("error while closing list file "
  79             & Get_Name_String (Output_File_Name));
  80       end if;
  81    end Close_List_File;
  82
  83    -------------------------------
  84    -- Close_Output_Library_Info --
  85    -------------------------------
  86
  87    procedure Close_Output_Library_Info is
  88       Status : Boolean;
  89
  90    begin
  91       Close (Output_FD, Status);
  92
  93       if not Status then
  94          Fail
  95            ("error while closing ALI file "
  96             & Get_Name_String (Output_File_Name));
  97       end if;
  98    end Close_Output_Library_Info;
  99
 100    ------------------------
 101    -- Close_Repinfo_File --
 102    ------------------------
 103
 104    procedure Close_Repinfo_File is
 105       Status : Boolean;
 106
 107    begin
 108       Close (Output_FD, Status);
 109
 110       if not Status then
 111          Fail
 112            ("error while closing representation info file "
 113             & Get_Name_String (Output_File_Name));
 114       end if;
 115    end Close_Repinfo_File;
 116
 117    ---------------------------
 118    -- Create_Auxiliary_File --
 119    ---------------------------
 120
 121    function Create_Auxiliary_File
 122      (Src    : File_Name_Type;
 123       Suffix : String) return File_Name_Type
 124    is
 125       Result : File_Name_Type;
 126
 127    begin
 128       Get_Name_String (Src);
 129
 130       if Hostparm.OpenVMS then
 131          Name_Buffer (Name_Len + 1) := '_';
 132       else
 133          Name_Buffer (Name_Len + 1) := '.';
 134       end if;
 135
 136       Name_Len := Name_Len + 1;
 137       Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 138       Name_Len := Name_Len + Suffix'Length;
 139
 140       if Output_Object_File_Name /= null then
 141          for Index in reverse Output_Object_File_Name'Range loop
 142             if Output_Object_File_Name (Index) = Directory_Separator then
 143                declare
 144                   File_Name : constant String := Name_Buffer (1 .. Name_Len);
 145                begin
 146                   Name_Len := Index - Output_Object_File_Name'First + 1;
 147                   Name_Buffer (1 .. Name_Len) :=
 148                     Output_Object_File_Name
 149                       (Output_Object_File_Name'First .. Index);
 150                   Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) :=
 151                     File_Name;
 152                   Name_Len := Name_Len + File_Name'Length;
 153                end;
 154
 155                exit;
 156             end if;
 157          end loop;
 158       end if;
 159
 160       Result := Name_Find;
 161       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 162       Create_File_And_Check (Output_FD, Text);
 163       return Result;
 164    end Create_Auxiliary_File;
 165
 166    -----------------------
 167    -- Create_Debug_File --
 168    -----------------------
 169
 170    function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is
 171    begin
 172       return Create_Auxiliary_File (Src, "dg");
 173    end Create_Debug_File;
 174
 175    ----------------------
 176    -- Create_List_File --
 177    ----------------------
 178
 179    procedure Create_List_File (S : String) is
 180       F : File_Name_Type;
 181       pragma Warnings (Off, F);
 182    begin
 183       if S (S'First) = '.' then
 184          F := Create_Auxiliary_File (Current_Main, S (S'First + 1 .. S'Last));
 185
 186       else
 187          Name_Buffer (1 .. S'Length) := S;
 188          Name_Len := S'Length + 1;
 189          Name_Buffer (Name_Len) := ASCII.NUL;
 190          Create_File_And_Check (Output_FD, Text);
 191       end if;
 192    end Create_List_File;
 193
 194    --------------------------------
 195    -- Create_Output_Library_Info --
 196    --------------------------------
 197
 198    procedure Create_Output_Library_Info is
 199       Dummy : Boolean;
 200       pragma Unreferenced (Dummy);
 201
 202    begin
 203       Set_Library_Info_Name;
 204       Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
 205       Create_File_And_Check (Output_FD, Text);
 206    end Create_Output_Library_Info;
 207
 208    -------------------------
 209    -- Create_Repinfo_File --
 210    -------------------------
 211
 212    procedure Create_Repinfo_File (Src : String) is
 213       Discard : File_Name_Type;
 214       pragma Warnings (Off, Discard);
 215    begin
 216       Name_Buffer (1 .. Src'Length) := Src;
 217       Name_Len := Src'Length;
 218       Discard := Create_Auxiliary_File (Name_Find, "rep");
 219       return;
 220    end Create_Repinfo_File;
 221
 222    ---------------------------
 223    -- Debug_File_Eol_Length --
 224    ---------------------------
 225
 226    function Debug_File_Eol_Length return Nat is
 227    begin
 228       --  There has to be a cleaner way to do this! ???
 229
 230       if Directory_Separator = '/' then
 231          return 1;
 232       else
 233          return 2;
 234       end if;
 235    end Debug_File_Eol_Length;
 236
 237    ---------------------------------
 238    -- Get_Output_Object_File_Name --
 239    ---------------------------------
 240
 241    function Get_Output_Object_File_Name return String is
 242    begin
 243       pragma Assert (Output_Object_File_Name /= null);
 244
 245       return Output_Object_File_Name.all;
 246    end Get_Output_Object_File_Name;
 247
 248    -----------------------
 249    -- More_Source_Files --
 250    -----------------------
 251
 252    function More_Source_Files return Boolean renames More_Files;
 253
 254    ----------------------
 255    -- Next_Main_Source --
 256    ----------------------
 257
 258    function Next_Main_Source return File_Name_Type renames Next_Main_File;
 259
 260    -----------------------
 261    -- Read_Library_Info --
 262    -----------------------
 263
 264    --  Version with default file name
 265
 266    procedure Read_Library_Info
 267      (Name : out File_Name_Type;
 268       Text : out Text_Buffer_Ptr)
 269    is
 270    begin
 271       Set_Library_Info_Name;
 272       Name := Name_Find;
 273       Text := Read_Library_Info (Name, Fatal_Err => False);
 274    end Read_Library_Info;
 275
 276    ---------------------------
 277    -- Set_Library_Info_Name --
 278    ---------------------------
 279
 280    procedure Set_Library_Info_Name is
 281       Dot_Index : Natural;
 282
 283    begin
 284       Get_Name_String (Current_Main);
 285
 286       --  Find last dot since we replace the existing extension by .ali. The
 287       --  initialization to Name_Len + 1 provides for simply adding the .ali
 288       --  extension if the source file name has no extension.
 289
 290       Dot_Index := Name_Len + 1;
 291
 292       for J in reverse 1 .. Name_Len loop
 293          if Name_Buffer (J) = '.' then
 294             Dot_Index := J;
 295             exit;
 296          end if;
 297       end loop;
 298
 299       --  Make sure that the output file name matches the source file name.
 300       --  To compare them, remove file name directories and extensions.
 301
 302       if Output_Object_File_Name /= null then
 303
 304          --  Make sure there is a dot at Dot_Index. This may not be the case
 305          --  if the source file name has no extension.
 306
 307          Name_Buffer (Dot_Index) := '.';
 308
 309          --  If we are in multiple unit per file mode, then add ~nnn
 310          --  extension to the name before doing the comparison.
 311
 312          if Multiple_Unit_Index /= 0 then
 313             declare
 314                Exten : constant String := Name_Buffer (Dot_Index .. Name_Len);
 315             begin
 316                Name_Len := Dot_Index - 1;
 317                Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
 318                Add_Nat_To_Name_Buffer (Multiple_Unit_Index);
 319                Dot_Index := Name_Len + 1;
 320                Add_Str_To_Name_Buffer (Exten);
 321             end;
 322          end if;
 323
 324          --  Remove extension preparing to replace it
 325
 326          declare
 327             Name  : String  := Name_Buffer (1 .. Dot_Index);
 328             First : Positive;
 329
 330          begin
 331             Name_Buffer (1 .. Output_Object_File_Name'Length) :=
 332               Output_Object_File_Name.all;
 333
 334             --  Put two names in canonical case, to allow object file names
 335             --  with upper-case letters on Windows.
 336
 337             Canonical_Case_File_Name (Name);
 338             Canonical_Case_File_Name
 339               (Name_Buffer (1 .. Output_Object_File_Name'Length));
 340
 341             Dot_Index := 0;
 342             for J in reverse Output_Object_File_Name'Range loop
 343                if Name_Buffer (J) = '.' then
 344                   Dot_Index := J;
 345                   exit;
 346                end if;
 347             end loop;
 348
 349             --  Dot_Index should not be zero now (we check for extension
 350             --  elsewhere).
 351
 352             pragma Assert (Dot_Index /= 0);
 353
 354             --  Look for first character of file name
 355
 356             First := Dot_Index;
 357             while First > 1
 358               and then Name_Buffer (First - 1) /= Directory_Separator
 359               and then Name_Buffer (First - 1) /= '/'
 360             loop
 361                First := First - 1;
 362             end loop;
 363
 364             --  Check name of object file is what we expect
 365
 366             if Name /= Name_Buffer (First .. Dot_Index) then
 367                Fail ("incorrect object file name");
 368             end if;
 369          end;
 370       end if;
 371
 372       Name_Buffer (Dot_Index) := '.';
 373       Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all;
 374       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
 375       Name_Len := Dot_Index + 3;
 376    end Set_Library_Info_Name;
 377
 378    ---------------------------------
 379    -- Set_Output_Object_File_Name --
 380    ---------------------------------
 381
 382    procedure Set_Output_Object_File_Name (Name : String) is
 383       Ext : constant String  := Target_Object_Suffix;
 384       NL  : constant Natural := Name'Length;
 385       EL  : constant Natural := Ext'Length;
 386
 387    begin
 388       --  Make sure that the object file has the expected extension
 389
 390       if NL <= EL
 391          or else
 392           (Name (NL - EL + Name'First .. Name'Last) /= Ext
 393              and then Name (NL - 2 + Name'First .. Name'Last) /= ".o")
 394       then
 395          Fail ("incorrect object file extension");
 396       end if;
 397
 398       Output_Object_File_Name := new String'(Name);
 399    end Set_Output_Object_File_Name;
 400
 401    ----------------
 402    -- Tree_Close --
 403    ----------------
 404
 405    procedure Tree_Close is
 406       Status : Boolean;
 407    begin
 408       Tree_Write_Terminate;
 409       Close (Output_FD, Status);
 410
 411       if not Status then
 412          Fail
 413            ("error while closing tree file "
 414             & Get_Name_String (Output_File_Name));
 415       end if;
 416    end Tree_Close;
 417
 418    -----------------
 419    -- Tree_Create --
 420    -----------------
 421
 422    procedure Tree_Create is
 423       Dot_Index : Natural;
 424
 425    begin
 426       Get_Name_String (Current_Main);
 427
 428       --  If an object file has been specified, then the ALI file
 429       --  will be in the same directory as the object file;
 430       --  so, we put the tree file in this same directory,
 431       --  even though no object file needs to be generated.
 432
 433       if Output_Object_File_Name /= null then
 434          Name_Len := Output_Object_File_Name'Length;
 435          Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
 436       end if;
 437
 438       Dot_Index := Name_Len + 1;
 439
 440       for J in reverse 1 .. Name_Len loop
 441          if Name_Buffer (J) = '.' then
 442             Dot_Index := J;
 443             exit;
 444          end if;
 445       end loop;
 446
 447       --  Should be impossible to not have an extension
 448
 449       pragma Assert (Dot_Index /= 0);
 450
 451       --  Change extension to adt
 452
 453       Name_Buffer (Dot_Index) := '.';
 454       Name_Buffer (Dot_Index + 1) := 'a';
 455       Name_Buffer (Dot_Index + 2) := 'd';
 456       Name_Buffer (Dot_Index + 3) := 't';
 457       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
 458       Name_Len := Dot_Index + 3;
 459       Create_File_And_Check (Output_FD, Binary);
 460
 461       Tree_Write_Initialize (Output_FD);
 462    end Tree_Create;
 463
 464    -----------------------
 465    -- Write_Debug_Info --
 466    -----------------------
 467
 468    procedure Write_Debug_Info (Info : String) renames Write_Info;
 469
 470    ------------------------
 471    -- Write_Library_Info --
 472    ------------------------
 473
 474    procedure Write_Library_Info (Info : String) renames Write_Info;
 475
 476    ---------------------
 477    -- Write_List_Info --
 478    ---------------------
 479
 480    procedure Write_List_Info (S : String) is
 481    begin
 482       Write_With_Check (S'Address, S'Length);
 483    end Write_List_Info;
 484
 485    ------------------------
 486    -- Write_Repinfo_Line --
 487    ------------------------
 488
 489    procedure Write_Repinfo_Line (Info : String) renames Write_Info;
 490
 491 begin
 492    Adjust_OS_Resource_Limits;
 493
 494    Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access;
 495    Opt.Write_Repinfo_Line_Access  := Write_Repinfo_Line'Access;
 496    Opt.Close_Repinfo_File_Access  := Close_Repinfo_File'Access;
 497
 498    Opt.Create_List_File_Access := Create_List_File'Access;
 499    Opt.Write_List_Info_Access  := Write_List_Info'Access;
 500    Opt.Close_List_File_Access  := Close_List_File'Access;
 501
 502    Set_Program (Compiler);
 503 end Osint.C;