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