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-2007, 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 Opt;      use Opt;
  29 with Tree_IO;  use Tree_IO;
  30
  31 package body Osint.C is
  32
  33    Output_Object_File_Name : String_Ptr;
  34    --  Argument of -o compiler option, if given. This is needed to verify
  35    --  consistency with the ALI file name.
  36
  37    procedure Adjust_OS_Resource_Limits;
  38    pragma Import (C, Adjust_OS_Resource_Limits,
  39                   "__gnat_adjust_os_resource_limits");
  40    --  Procedure to make system specific adjustments to make GNAT run better
  41
  42    function Create_Auxiliary_File
  43      (Src    : File_Name_Type;
  44       Suffix : String) return File_Name_Type;
  45    --  Common processing for Create_List_File, Create_Repinfo_File and
  46    --  Create_Debug_File. Src is the file name used to create the required
  47    --  output file and Suffix is the desired suffic (dg/rep/xxx for debug/
  48    --  repinfo/list file where xxx is specified extension.
  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_List_File --
  75    ---------------------
  76
  77    procedure Close_List_File is
  78       Status : Boolean;
  79
  80    begin
  81       Close (Output_FD, Status);
  82
  83       if not Status then
  84          Fail
  85            ("error while closing list file ",
  86             Get_Name_String (Output_File_Name));
  87       end if;
  88    end Close_List_File;
  89
  90    -------------------------------
  91    -- Close_Output_Library_Info --
  92    -------------------------------
  93
  94    procedure Close_Output_Library_Info is
  95       Status : Boolean;
  96
  97    begin
  98       Close (Output_FD, Status);
  99
 100       if not Status then
 101          Fail
 102            ("error while closing ALI file ",
 103             Get_Name_String (Output_File_Name));
 104       end if;
 105    end Close_Output_Library_Info;
 106
 107    ------------------------
 108    -- Close_Repinfo_File --
 109    ------------------------
 110
 111    procedure Close_Repinfo_File is
 112       Status : Boolean;
 113
 114    begin
 115       Close (Output_FD, Status);
 116
 117       if not Status then
 118          Fail
 119            ("error while closing representation info file ",
 120             Get_Name_String (Output_File_Name));
 121       end if;
 122    end Close_Repinfo_File;
 123
 124    ---------------------------
 125    -- Create_Auxiliary_File --
 126    ---------------------------
 127
 128    function Create_Auxiliary_File
 129      (Src    : File_Name_Type;
 130       Suffix : String) return File_Name_Type
 131    is
 132       Result : File_Name_Type;
 133
 134    begin
 135       Get_Name_String (Src);
 136
 137       if Hostparm.OpenVMS then
 138          Name_Buffer (Name_Len + 1) := '_';
 139       else
 140          Name_Buffer (Name_Len + 1) := '.';
 141       end if;
 142
 143       Name_Len := Name_Len + 1;
 144       Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 145       Name_Len := Name_Len + Suffix'Length;
 146
 147       if Output_Object_File_Name /= null then
 148          for Index in reverse Output_Object_File_Name'Range loop
 149             if Output_Object_File_Name (Index) = Directory_Separator then
 150                declare
 151                   File_Name : constant String := Name_Buffer (1 .. Name_Len);
 152                begin
 153                   Name_Len := Index - Output_Object_File_Name'First + 1;
 154                   Name_Buffer (1 .. Name_Len) :=
 155                     Output_Object_File_Name
 156                       (Output_Object_File_Name'First .. Index);
 157                   Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) :=
 158                     File_Name;
 159                   Name_Len := Name_Len + File_Name'Length;
 160                end;
 161
 162                exit;
 163             end if;
 164          end loop;
 165       end if;
 166
 167       Result := Name_Find;
 168       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 169       Create_File_And_Check (Output_FD, Text);
 170       return Result;
 171    end Create_Auxiliary_File;
 172
 173    -----------------------
 174    -- Create_Debug_File --
 175    -----------------------
 176
 177    function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is
 178    begin
 179       return Create_Auxiliary_File (Src, "dg");
 180    end Create_Debug_File;
 181
 182    ----------------------
 183    -- Create_List_File --
 184    ----------------------
 185
 186    procedure Create_List_File (S : String) is
 187       F : File_Name_Type;
 188       pragma Warnings (Off, F);
 189    begin
 190       if S (S'First) = '.' then
 191          F := Create_Auxiliary_File (Current_Main, S (S'First + 1 .. S'Last));
 192
 193       else
 194          Name_Buffer (1 .. S'Length) := S;
 195          Name_Len := S'Length + 1;
 196          Name_Buffer (Name_Len) := ASCII.NUL;
 197          Create_File_And_Check (Output_FD, Text);
 198       end if;
 199    end Create_List_File;
 200
 201    --------------------------------
 202    -- Create_Output_Library_Info --
 203    --------------------------------
 204
 205    procedure Create_Output_Library_Info is
 206    begin
 207       Set_Library_Info_Name;
 208       Create_File_And_Check (Output_FD, Text);
 209    end Create_Output_Library_Info;
 210
 211    -------------------------
 212    -- Create_Repinfo_File --
 213    -------------------------
 214
 215    procedure Create_Repinfo_File (Src : String) is
 216       Discard : File_Name_Type;
 217       pragma Warnings (Off, Discard);
 218    begin
 219       Name_Buffer (1 .. Src'Length) := Src;
 220       Name_Len := Src'Length;
 221       Discard := Create_Auxiliary_File (Name_Find, "rep");
 222       return;
 223    end Create_Repinfo_File;
 224
 225    ---------------------------
 226    -- Debug_File_Eol_Length --
 227    ---------------------------
 228
 229    function Debug_File_Eol_Length return Nat is
 230    begin
 231       --  There has to be a cleaner way to do this! ???
 232
 233       if Directory_Separator = '/' then
 234          return 1;
 235       else
 236          return 2;
 237       end if;
 238    end Debug_File_Eol_Length;
 239
 240    -----------------------
 241    -- More_Source_Files --
 242    -----------------------
 243
 244    function More_Source_Files return Boolean renames More_Files;
 245
 246    ----------------------
 247    -- Next_Main_Source --
 248    ----------------------
 249
 250    function Next_Main_Source return File_Name_Type renames Next_Main_File;
 251
 252    -----------------------
 253    -- Read_Library_Info --
 254    -----------------------
 255
 256    --  Version with default file name
 257
 258    procedure Read_Library_Info
 259      (Name : out File_Name_Type;
 260       Text : out Text_Buffer_Ptr)
 261    is
 262    begin
 263       Set_Library_Info_Name;
 264       Name := Name_Find;
 265       Text := Read_Library_Info (Name, Fatal_Err => False);
 266    end Read_Library_Info;
 267
 268    ---------------------------
 269    -- Set_Library_Info_Name --
 270    ---------------------------
 271
 272    procedure Set_Library_Info_Name is
 273       Dot_Index : Natural;
 274
 275    begin
 276       Get_Name_String (Current_Main);
 277
 278       --  Find last dot since we replace the existing extension by .ali. The
 279       --  initialization to Name_Len + 1 provides for simply adding the .ali
 280       --  extension if the source file name has no extension.
 281
 282       Dot_Index := Name_Len + 1;
 283
 284       for J in reverse 1 .. Name_Len loop
 285          if Name_Buffer (J) = '.' then
 286             Dot_Index := J;
 287             exit;
 288          end if;
 289       end loop;
 290
 291       --  Make sure that the output file name matches the source file name.
 292       --  To compare them, remove file name directories and extensions.
 293
 294       if Output_Object_File_Name /= null then
 295
 296          --  Make sure there is a dot at Dot_Index. This may not be the case
 297          --  if the source file name has no extension.
 298
 299          Name_Buffer (Dot_Index) := '.';
 300
 301          --  If we are in multiple unit per file mode, then add ~nnn
 302          --  extension to the name before doing the comparison.
 303
 304          if Multiple_Unit_Index /= 0 then
 305             declare
 306                Exten : constant String := Name_Buffer (Dot_Index .. Name_Len);
 307             begin
 308                Name_Len := Dot_Index - 1;
 309                Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
 310                Add_Nat_To_Name_Buffer (Multiple_Unit_Index);
 311                Dot_Index := Name_Len + 1;
 312                Add_Str_To_Name_Buffer (Exten);
 313             end;
 314          end if;
 315
 316          --  Remove extension preparing to replace it
 317
 318          declare
 319             Name  : constant String  := Name_Buffer (1 .. Dot_Index);
 320             First : Positive;
 321
 322          begin
 323             Name_Buffer (1 .. Output_Object_File_Name'Length) :=
 324               Output_Object_File_Name.all;
 325             Dot_Index := 0;
 326
 327             for J in reverse Output_Object_File_Name'Range loop
 328                if Name_Buffer (J) = '.' then
 329                   Dot_Index := J;
 330                   exit;
 331                end if;
 332             end loop;
 333
 334             --  Dot_Index should not be zero now (we check for extension
 335             --  elsewhere).
 336
 337             pragma Assert (Dot_Index /= 0);
 338
 339             --  Look for first character of file name
 340
 341             First := Dot_Index;
 342             while First > 1
 343               and then Name_Buffer (First - 1) /= Directory_Separator
 344               and then Name_Buffer (First - 1) /= '/'
 345             loop
 346                First := First - 1;
 347             end loop;
 348
 349             --  Check name of object file is what we expect
 350
 351             if Name /= Name_Buffer (First .. Dot_Index) then
 352                Fail ("incorrect object file name");
 353             end if;
 354          end;
 355       end if;
 356
 357       Name_Buffer (Dot_Index) := '.';
 358       Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all;
 359       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
 360       Name_Len := Dot_Index + 3;
 361    end Set_Library_Info_Name;
 362
 363    ---------------------------------
 364    -- Set_Output_Object_File_Name --
 365    ---------------------------------
 366
 367    procedure Set_Output_Object_File_Name (Name : String) is
 368       Ext : constant String  := Target_Object_Suffix;
 369       NL  : constant Natural := Name'Length;
 370       EL  : constant Natural := Ext'Length;
 371
 372    begin
 373       --  Make sure that the object file has the expected extension
 374
 375       if NL <= EL
 376          or else
 377           (Name (NL - EL + Name'First .. Name'Last) /= Ext
 378              and then Name (NL - 2 + Name'First .. Name'Last) /= ".o")
 379       then
 380          Fail ("incorrect object file extension");
 381       end if;
 382
 383       Output_Object_File_Name := new String'(Name);
 384    end Set_Output_Object_File_Name;
 385
 386    ----------------
 387    -- Tree_Close --
 388    ----------------
 389
 390    procedure Tree_Close is
 391       Status : Boolean;
 392    begin
 393       Tree_Write_Terminate;
 394       Close (Output_FD, Status);
 395
 396       if not Status then
 397          Fail
 398            ("error while closing tree file ",
 399             Get_Name_String (Output_File_Name));
 400       end if;
 401    end Tree_Close;
 402
 403    -----------------
 404    -- Tree_Create --
 405    -----------------
 406
 407    procedure Tree_Create is
 408       Dot_Index : Natural;
 409
 410    begin
 411       Get_Name_String (Current_Main);
 412
 413       --  If an object file has been specified, then the ALI file
 414       --  will be in the same directory as the object file;
 415       --  so, we put the tree file in this same directory,
 416       --  even though no object file needs to be generated.
 417
 418       if Output_Object_File_Name /= null then
 419          Name_Len := Output_Object_File_Name'Length;
 420          Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
 421       end if;
 422
 423       Dot_Index := Name_Len + 1;
 424
 425       for J in reverse 1 .. Name_Len loop
 426          if Name_Buffer (J) = '.' then
 427             Dot_Index := J;
 428             exit;
 429          end if;
 430       end loop;
 431
 432       --  Should be impossible to not have an extension
 433
 434       pragma Assert (Dot_Index /= 0);
 435
 436       --  Change exctension to adt
 437
 438       Name_Buffer (Dot_Index) := '.';
 439       Name_Buffer (Dot_Index + 1) := 'a';
 440       Name_Buffer (Dot_Index + 2) := 'd';
 441       Name_Buffer (Dot_Index + 3) := 't';
 442       Name_Buffer (Dot_Index + 4) := ASCII.NUL;
 443       Name_Len := Dot_Index + 3;
 444       Create_File_And_Check (Output_FD, Binary);
 445
 446       Tree_Write_Initialize (Output_FD);
 447    end Tree_Create;
 448
 449    -----------------------
 450    -- Write_Debug_Info --
 451    -----------------------
 452
 453    procedure Write_Debug_Info (Info : String) renames Write_Info;
 454
 455    ------------------------
 456    -- Write_Library_Info --
 457    ------------------------
 458
 459    procedure Write_Library_Info (Info : String) renames Write_Info;
 460
 461    ---------------------
 462    -- Write_List_Info --
 463    ---------------------
 464
 465    procedure Write_List_Info (S : String) is
 466    begin
 467       Write_With_Check (S'Address, S'Length);
 468    end Write_List_Info;
 469
 470    ------------------------
 471    -- Write_Repinfo_Line --
 472    ------------------------
 473
 474    procedure Write_Repinfo_Line (Info : String) renames Write_Info;
 475
 476 begin
 477    Adjust_OS_Resource_Limits;
 478
 479    Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access;
 480    Opt.Write_Repinfo_Line_Access  := Write_Repinfo_Line'Access;
 481    Opt.Close_Repinfo_File_Access  := Close_Repinfo_File'Access;
 482
 483    Opt.Create_List_File_Access := Create_List_File'Access;
 484    Opt.Write_List_Info_Access  := Write_List_Info'Access;
 485    Opt.Close_List_File_Access  := Close_List_File'Access;
 486
 487    Set_Program (Compiler);
 488 end Osint.C;