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