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