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