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