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 --                                                                          --
  10 --          Copyright (C) 2001 Free Software Foundation, Inc.               --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Hostparm;
  29 with Namet;    use Namet;
  30 with Opt;      use Opt;
  31 with Tree_IO;  use Tree_IO;
  32
  33 package body Osint.C is
  34
  35    Output_Object_File_Name : String_Ptr;
  36    --  Argument of -o compiler option, if given. This is needed to
  37    --  verify consistency with the ALI file name.
  38
  39    procedure Adjust_OS_Resource_Limits;
  40    pragma Import (C, Adjust_OS_Resource_Limits,
  41                   "__gnat_adjust_os_resource_limits");
  42    --  Procedure to make system specific adjustments to make GNAT
  43    --  run better.
  44
  45    function Create_Auxiliary_File
  46      (Src    : File_Name_Type;
  47       Suffix : String)
  48       return   File_Name_Type;
  49    --  Common processing for Creat_Repinfo_File and Create_Debug_File.
  50    --  Src is the file name used to create the required output file and
  51    --  Suffix is the desired suffic (dg/rep for debug/repinfo file).
  52
  53    procedure Set_Library_Info_Name;
  54    --  Sets a default ali file name from the main compiler source name.
  55    --  This is used by Create_Output_Library_Info, and by the version of
  56    --  Read_Library_Info that takes a default file name.
  57
  58    ----------------------
  59    -- Close_Debug_File --
  60    ----------------------
  61
  62    procedure Close_Debug_File is
  63    begin
  64       Close (Output_FD);
  65    end Close_Debug_File;
  66
  67    -------------------------------
  68    -- Close_Output_Library_Info --
  69    -------------------------------
  70
  71    procedure Close_Output_Library_Info is
  72    begin
  73       Close (Output_FD);
  74    end Close_Output_Library_Info;
  75
  76    ------------------------
  77    -- Close_Repinfo_File --
  78    ------------------------
  79
  80    procedure Close_Repinfo_File is
  81    begin
  82       Close (Output_FD);
  83    end Close_Repinfo_File;
  84
  85    ---------------------------
  86    -- Create_Auxiliary_File --
  87    ---------------------------
  88
  89    function Create_Auxiliary_File
  90      (Src    : File_Name_Type;
  91       Suffix : String)
  92       return   File_Name_Type
  93    is
  94       Result : File_Name_Type;
  95
  96    begin
  97       Get_Name_String (Src);
  98
  99       if Hostparm.OpenVMS then
 100          Name_Buffer (Name_Len + 1) := '_';
 101       else
 102          Name_Buffer (Name_Len + 1) := '.';
 103       end if;
 104
 105       Name_Len := Name_Len + 1;
 106       Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 107       Name_Len := Name_Len + Suffix'Length;
 108
 109       if Output_Object_File_Name /= null then
 110
 111          for Index in reverse Output_Object_File_Name'Range loop
 112
 113             if Output_Object_File_Name (Index) = Directory_Separator then
 114                declare
 115                   File_Name : constant String := Name_Buffer (1 .. Name_Len);
 116
 117                begin
 118                   Name_Len := Index - Output_Object_File_Name'First + 1;
 119                   Name_Buffer (1 .. Name_Len) :=
 120                     Output_Object_File_Name
 121                       (Output_Object_File_Name'First .. Index);
 122                   Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) :=
 123                     File_Name;
 124                   Name_Len := Name_Len + File_Name'Length;
 125                end;
 126
 127                exit;
 128             end if;
 129          end loop;
 130       end if;
 131
 132       Result := Name_Find;
 133       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 134       Create_File_And_Check (Output_FD, Text);
 135       return Result;
 136    end Create_Auxiliary_File;
 137
 138    -----------------------
 139    -- Create_Debug_File --
 140    -----------------------
 141
 142    function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is
 143    begin
 144       return Create_Auxiliary_File (Src, "dg");
 145    end Create_Debug_File;
 146
 147    --------------------------------
 148    -- Create_Output_Library_Info --
 149    --------------------------------
 150
 151    procedure Create_Output_Library_Info is
 152    begin
 153       Set_Library_Info_Name;
 154       Create_File_And_Check (Output_FD, Text);
 155    end Create_Output_Library_Info;
 156
 157    --------------------------
 158    -- Creat_Repinfo_File --
 159    --------------------------
 160
 161    procedure Creat_Repinfo_File (Src : File_Name_Type) is
 162       S : constant File_Name_Type := Create_Auxiliary_File (Src, "rep");
 163       pragma Warnings (Off, S);
 164
 165    begin
 166       return;
 167    end Creat_Repinfo_File;
 168
 169    ---------------------------
 170    -- Debug_File_Eol_Length --
 171    ---------------------------
 172
 173    function Debug_File_Eol_Length return Nat is
 174    begin
 175       --  There has to be a cleaner way to do this! ???
 176
 177       if Directory_Separator = '/' then
 178          return 1;
 179       else
 180          return 2;
 181       end if;
 182    end Debug_File_Eol_Length;
 183
 184    -----------------------
 185    -- More_Source_Files --
 186    -----------------------
 187
 188    function More_Source_Files return Boolean renames More_Files;
 189
 190    ----------------------
 191    -- Next_Main_Source --
 192    ----------------------
 193
 194    function Next_Main_Source return File_Name_Type renames Next_Main_File;
 195
 196    -----------------------
 197    -- Read_Library_Info --
 198    -----------------------
 199
 200    --  Version with default file name
 201
 202    procedure Read_Library_Info
 203      (Name : out File_Name_Type;
 204       Text : out Text_Buffer_Ptr)
 205    is
 206    begin
 207       Set_Library_Info_Name;
 208       Name := Name_Find;
 209       Text := Read_Library_Info (Name, Fatal_Err => False);
 210    end Read_Library_Info;
 211
 212    ---------------------------
 213    -- Set_Library_Info_Name --
 214    ---------------------------
 215
 216    procedure Set_Library_Info_Name is
 217       Dot_Index : Natural;
 218
 219    begin
 220       Get_Name_String (Current_Main);
 221
 222       --  Find last dot since we replace the existing extension by .ali. The
 223       --  initialization to Name_Len + 1 provides for simply adding the .ali
 224       --  extension if the source file name has no extension.
 225
 226       Dot_Index := Name_Len + 1;
 227
 228       for J in reverse 1 .. Name_Len loop
 229          if Name_Buffer (J) = '.' then
 230             Dot_Index := J;
 231             exit;
 232          end if;
 233       end loop;
 234
 235       --  Make sure that the output file name matches the source file name.
 236       --  To compare them, remove file name directories and extensions.
 237
 238       if Output_Object_File_Name /= null then
 239          --  Make sure there is a dot at Dot_Index. This may not be the case
 240          --  if the source file name has no extension.
 241
 242          Name_Buffer (Dot_Index) := '.';
 243
 244          declare
 245             Name : constant String  := Name_Buffer (1 .. Dot_Index);
 246             Len  : constant Natural := Dot_Index;
 247
 248          begin
 249             Name_Buffer (1 .. Output_Object_File_Name'Length)
 250                := Output_Object_File_Name.all;
 251             Dot_Index := 0;
 252
 253             for J in reverse Output_Object_File_Name'Range loop
 254                if Name_Buffer (J) = '.' then
 255                   Dot_Index := J;
 256                   exit;
 257                end if;
 258             end loop;
 259
 260             pragma Assert (Dot_Index /= 0);
 261             --  We check for the extension elsewhere
 262
 263             if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then
 264                Fail ("incorrect object file name");
 265             end if;
 266          end;
 267       end if;
 268
 269       Name_Buffer (Dot_Index) := '.';
 270       Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all;
 271       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
 272       Name_Len := Dot_Index + 3;
 273    end Set_Library_Info_Name;
 274
 275    ---------------------------------
 276    -- Set_Output_Object_File_Name --
 277    ---------------------------------
 278
 279    procedure Set_Output_Object_File_Name (Name : String) is
 280       Ext : constant String := Object_Suffix;
 281       NL  : constant Natural := Name'Length;
 282       EL  : constant Natural := Ext'Length;
 283
 284    begin
 285       --  Make sure that the object file has the expected extension.
 286
 287       if NL <= EL
 288          or else
 289           (Name (NL - EL + Name'First .. Name'Last) /= Ext
 290              and then Name (NL - 2 + Name'First .. Name'Last) /= ".o")
 291       then
 292          Fail ("incorrect object file extension");
 293       end if;
 294
 295       Output_Object_File_Name := new String'(Name);
 296    end Set_Output_Object_File_Name;
 297
 298    ----------------
 299    -- Tree_Close --
 300    ----------------
 301
 302    procedure Tree_Close is
 303    begin
 304       Tree_Write_Terminate;
 305       Close (Output_FD);
 306    end Tree_Close;
 307
 308    -----------------
 309    -- Tree_Create --
 310    -----------------
 311
 312    procedure Tree_Create is
 313       Dot_Index : Natural;
 314
 315    begin
 316       Get_Name_String (Current_Main);
 317
 318       --  If an object file has been specified, then the ALI file
 319       --  will be in the same directory as the object file;
 320       --  so, we put the tree file in this same directory,
 321       --  even though no object file needs to be generated.
 322
 323       if Output_Object_File_Name /= null then
 324          Name_Len := Output_Object_File_Name'Length;
 325          Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
 326       end if;
 327
 328       Dot_Index := 0;
 329       for J in reverse 1 .. Name_Len loop
 330          if Name_Buffer (J) = '.' then
 331             Dot_Index := J;
 332             exit;
 333          end if;
 334       end loop;
 335
 336       --  Should be impossible to not have an extension
 337
 338       pragma Assert (Dot_Index /= 0);
 339
 340       --  Change exctension to adt
 341
 342       Name_Buffer (Dot_Index + 1) := 'a';
 343       Name_Buffer (Dot_Index + 2) := 'd';
 344       Name_Buffer (Dot_Index + 3) := 't';
 345       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
 346       Name_Len := Dot_Index + 3;
 347       Create_File_And_Check (Output_FD, Binary);
 348
 349       Tree_Write_Initialize (Output_FD);
 350    end Tree_Create;
 351
 352    -----------------------
 353    -- Write_Debug_Info --
 354    -----------------------
 355
 356    procedure Write_Debug_Info (Info : String) renames Write_Info;
 357
 358    ------------------------
 359    -- Write_Library_Info --
 360    ------------------------
 361
 362    procedure Write_Library_Info (Info : String) renames Write_Info;
 363
 364    ------------------------
 365    -- Write_Repinfo_Line --
 366    ------------------------
 367
 368    procedure Write_Repinfo_Line (Info : String) renames Write_Info;
 369
 370 begin
 371
 372    Adjust_OS_Resource_Limits;
 373    Opt.Creat_Repinfo_File_Access := Creat_Repinfo_File'Access;
 374    Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
 375    Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
 376
 377    Set_Program (Compiler);
 378
 379 end Osint.C;