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