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-2003 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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
  36    --  verify 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
  42    --  run better.
  43
  44    function Create_Auxiliary_File
  45      (Src    : File_Name_Type;
  46       Suffix : String)
  47       return   File_Name_Type;
  48    --  Common processing for Creat_Repinfo_File and Create_Debug_File.
  49    --  Src is the file name used to create the required output file and
  50    --  Suffix is the desired suffic (dg/rep for debug/repinfo file).
  51
  52    procedure Set_Library_Info_Name;
  53    --  Sets a default ali file name from the main compiler source name.
  54    --  This is used by Create_Output_Library_Info, and by the version of
  55    --  Read_Library_Info that takes a default file name.
  56
  57    ----------------------
  58    -- Close_Debug_File --
  59    ----------------------
  60
  61    procedure Close_Debug_File is
  62       Status : Boolean;
  63    begin
  64       Close (Output_FD, Status);
  65
  66       if not Status then
  67          Fail
  68            ("error while closing expanded source file ",
  69             Get_Name_String (Output_File_Name));
  70       end if;
  71    end Close_Debug_File;
  72
  73    -------------------------------
  74    -- Close_Output_Library_Info --
  75    -------------------------------
  76
  77    procedure Close_Output_Library_Info is
  78       Status : Boolean;
  79    begin
  80       Close (Output_FD, Status);
  81
  82       if not Status then
  83          Fail
  84            ("error while closing ALI file ",
  85             Get_Name_String (Output_File_Name));
  86       end if;
  87    end Close_Output_Library_Info;
  88
  89    ------------------------
  90    -- Close_Repinfo_File --
  91    ------------------------
  92
  93    procedure Close_Repinfo_File is
  94       Status : Boolean;
  95    begin
  96       Close (Output_FD, Status);
  97
  98       if not Status then
  99          Fail
 100            ("error while closing representation info file ",
 101             Get_Name_String (Output_File_Name));
 102       end if;
 103    end Close_Repinfo_File;
 104
 105    ---------------------------
 106    -- Create_Auxiliary_File --
 107    ---------------------------
 108
 109    function Create_Auxiliary_File
 110      (Src    : File_Name_Type;
 111       Suffix : String)
 112       return   File_Name_Type
 113    is
 114       Result : File_Name_Type;
 115
 116    begin
 117       Get_Name_String (Src);
 118
 119       if Hostparm.OpenVMS then
 120          Name_Buffer (Name_Len + 1) := '_';
 121       else
 122          Name_Buffer (Name_Len + 1) := '.';
 123       end if;
 124
 125       Name_Len := Name_Len + 1;
 126       Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 127       Name_Len := Name_Len + Suffix'Length;
 128
 129       if Output_Object_File_Name /= null then
 130
 131          for Index in reverse Output_Object_File_Name'Range loop
 132
 133             if Output_Object_File_Name (Index) = Directory_Separator then
 134                declare
 135                   File_Name : constant String := Name_Buffer (1 .. Name_Len);
 136
 137                begin
 138                   Name_Len := Index - Output_Object_File_Name'First + 1;
 139                   Name_Buffer (1 .. Name_Len) :=
 140                     Output_Object_File_Name
 141                       (Output_Object_File_Name'First .. Index);
 142                   Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) :=
 143                     File_Name;
 144                   Name_Len := Name_Len + File_Name'Length;
 145                end;
 146
 147                exit;
 148             end if;
 149          end loop;
 150       end if;
 151
 152       Result := Name_Find;
 153       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 154       Create_File_And_Check (Output_FD, Text);
 155       return Result;
 156    end Create_Auxiliary_File;
 157
 158    -----------------------
 159    -- Create_Debug_File --
 160    -----------------------
 161
 162    function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is
 163    begin
 164       return Create_Auxiliary_File (Src, "dg");
 165    end Create_Debug_File;
 166
 167    --------------------------------
 168    -- Create_Output_Library_Info --
 169    --------------------------------
 170
 171    procedure Create_Output_Library_Info is
 172    begin
 173       Set_Library_Info_Name;
 174       Create_File_And_Check (Output_FD, Text);
 175    end Create_Output_Library_Info;
 176
 177    --------------------------
 178    -- Creat_Repinfo_File --
 179    --------------------------
 180
 181    procedure Creat_Repinfo_File (Src : File_Name_Type) is
 182       S : constant File_Name_Type := Create_Auxiliary_File (Src, "rep");
 183       pragma Warnings (Off, S);
 184
 185    begin
 186       return;
 187    end Creat_Repinfo_File;
 188
 189    ---------------------------
 190    -- Debug_File_Eol_Length --
 191    ---------------------------
 192
 193    function Debug_File_Eol_Length return Nat is
 194    begin
 195       --  There has to be a cleaner way to do this! ???
 196
 197       if Directory_Separator = '/' then
 198          return 1;
 199       else
 200          return 2;
 201       end if;
 202    end Debug_File_Eol_Length;
 203
 204    -----------------------
 205    -- More_Source_Files --
 206    -----------------------
 207
 208    function More_Source_Files return Boolean renames More_Files;
 209
 210    ----------------------
 211    -- Next_Main_Source --
 212    ----------------------
 213
 214    function Next_Main_Source return File_Name_Type renames Next_Main_File;
 215
 216    -----------------------
 217    -- Read_Library_Info --
 218    -----------------------
 219
 220    --  Version with default file name
 221
 222    procedure Read_Library_Info
 223      (Name : out File_Name_Type;
 224       Text : out Text_Buffer_Ptr)
 225    is
 226    begin
 227       Set_Library_Info_Name;
 228       Name := Name_Find;
 229       Text := Read_Library_Info (Name, Fatal_Err => False);
 230    end Read_Library_Info;
 231
 232    ---------------------------
 233    -- Set_Library_Info_Name --
 234    ---------------------------
 235
 236    procedure Set_Library_Info_Name is
 237       Dot_Index : Natural;
 238
 239    begin
 240       Get_Name_String (Current_Main);
 241
 242       --  Find last dot since we replace the existing extension by .ali. The
 243       --  initialization to Name_Len + 1 provides for simply adding the .ali
 244       --  extension if the source file name has no extension.
 245
 246       Dot_Index := Name_Len + 1;
 247
 248       for J in reverse 1 .. Name_Len loop
 249          if Name_Buffer (J) = '.' then
 250             Dot_Index := J;
 251             exit;
 252          end if;
 253       end loop;
 254
 255       --  Make sure that the output file name matches the source file name.
 256       --  To compare them, remove file name directories and extensions.
 257
 258       if Output_Object_File_Name /= null then
 259          --  Make sure there is a dot at Dot_Index. This may not be the case
 260          --  if the source file name has no extension.
 261
 262          Name_Buffer (Dot_Index) := '.';
 263
 264          declare
 265             Name : constant String  := Name_Buffer (1 .. Dot_Index);
 266             Len  : constant Natural := Dot_Index;
 267
 268          begin
 269             Name_Buffer (1 .. Output_Object_File_Name'Length)
 270                := Output_Object_File_Name.all;
 271             Dot_Index := 0;
 272
 273             for J in reverse Output_Object_File_Name'Range loop
 274                if Name_Buffer (J) = '.' then
 275                   Dot_Index := J;
 276                   exit;
 277                end if;
 278             end loop;
 279
 280             pragma Assert (Dot_Index /= 0);
 281             --  We check for the extension elsewhere
 282
 283             if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then
 284                Fail ("incorrect object file name");
 285             end if;
 286          end;
 287       end if;
 288
 289       Name_Buffer (Dot_Index) := '.';
 290       Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all;
 291       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
 292       Name_Len := Dot_Index + 3;
 293    end Set_Library_Info_Name;
 294
 295    ---------------------------------
 296    -- Set_Output_Object_File_Name --
 297    ---------------------------------
 298
 299    procedure Set_Output_Object_File_Name (Name : String) is
 300       Ext : constant String := Object_Suffix;
 301       NL  : constant Natural := Name'Length;
 302       EL  : constant Natural := Ext'Length;
 303
 304    begin
 305       --  Make sure that the object file has the expected extension.
 306
 307       if NL <= EL
 308          or else
 309           (Name (NL - EL + Name'First .. Name'Last) /= Ext
 310              and then Name (NL - 2 + Name'First .. Name'Last) /= ".o")
 311       then
 312          Fail ("incorrect object file extension");
 313       end if;
 314
 315       Output_Object_File_Name := new String'(Name);
 316    end Set_Output_Object_File_Name;
 317
 318    ----------------
 319    -- Tree_Close --
 320    ----------------
 321
 322    procedure Tree_Close is
 323       Status : Boolean;
 324    begin
 325       Tree_Write_Terminate;
 326       Close (Output_FD, Status);
 327
 328       if not Status then
 329          Fail
 330            ("error while closing tree file ",
 331             Get_Name_String (Output_File_Name));
 332       end if;
 333    end Tree_Close;
 334
 335    -----------------
 336    -- Tree_Create --
 337    -----------------
 338
 339    procedure Tree_Create is
 340       Dot_Index : Natural;
 341
 342    begin
 343       Get_Name_String (Current_Main);
 344
 345       --  If an object file has been specified, then the ALI file
 346       --  will be in the same directory as the object file;
 347       --  so, we put the tree file in this same directory,
 348       --  even though no object file needs to be generated.
 349
 350       if Output_Object_File_Name /= null then
 351          Name_Len := Output_Object_File_Name'Length;
 352          Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
 353       end if;
 354
 355       Dot_Index := Name_Len + 1;
 356
 357       for J in reverse 1 .. Name_Len loop
 358          if Name_Buffer (J) = '.' then
 359             Dot_Index := J;
 360             exit;
 361          end if;
 362       end loop;
 363
 364       --  Should be impossible to not have an extension
 365
 366       pragma Assert (Dot_Index /= 0);
 367
 368       --  Change exctension to adt
 369
 370       Name_Buffer (Dot_Index) := '.';
 371       Name_Buffer (Dot_Index + 1) := 'a';
 372       Name_Buffer (Dot_Index + 2) := 'd';
 373       Name_Buffer (Dot_Index + 3) := 't';
 374       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
 375       Name_Len := Dot_Index + 3;
 376       Create_File_And_Check (Output_FD, Binary);
 377
 378       Tree_Write_Initialize (Output_FD);
 379    end Tree_Create;
 380
 381    -----------------------
 382    -- Write_Debug_Info --
 383    -----------------------
 384
 385    procedure Write_Debug_Info (Info : String) renames Write_Info;
 386
 387    ------------------------
 388    -- Write_Library_Info --
 389    ------------------------
 390
 391    procedure Write_Library_Info (Info : String) renames Write_Info;
 392
 393    ------------------------
 394    -- Write_Repinfo_Line --
 395    ------------------------
 396
 397    procedure Write_Repinfo_Line (Info : String) renames Write_Info;
 398
 399 begin
 400
 401    Adjust_OS_Resource_Limits;
 402    Opt.Creat_Repinfo_File_Access := Creat_Repinfo_File'Access;
 403    Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
 404    Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
 405
 406    Set_Program (Compiler);
 407
 408 end Osint.C;