gcc/ada/osint-b.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              O S I N T - B                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2010, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Opt;      use Opt;
  27 with Output;   use Output;
  28 with Targparm; use Targparm;
  29
  30 package body Osint.B is
  31
  32    Current_List_File : File_Descriptor := Invalid_FD;
  33
  34    -------------------------
  35    -- Close_Binder_Output --
  36    -------------------------
  37
  38    procedure Close_Binder_Output is
  39       Status : Boolean;
  40    begin
  41       Close (Output_FD, Status);
  42
  43       if not Status then
  44          Fail
  45            ("error while closing generated file "
  46             & Get_Name_String (Output_File_Name));
  47       end if;
  48
  49    end Close_Binder_Output;
  50
  51    ---------------------
  52    -- Close_List_File --
  53    ---------------------
  54
  55    procedure Close_List_File is
  56    begin
  57       if Current_List_File /= Invalid_FD then
  58          Close (Current_List_File);
  59          Current_List_File := Invalid_FD;
  60          Set_Standard_Output;
  61       end if;
  62    end Close_List_File;
  63
  64    --------------------------
  65    -- Create_Binder_Output --
  66    --------------------------
  67
  68    procedure Create_Binder_Output
  69      (Output_File_Name : String;
  70       Typ              : Character;
  71       Bfile            : out Name_Id)
  72    is
  73       File_Name : String_Ptr;
  74       Findex1   : Natural;
  75       Findex2   : Natural;
  76       Flength   : Natural;
  77
  78       Bind_File_Prefix_Len : Natural := 2;
  79       --  Length of binder file prefix (normally set to 2 for b~, but gets
  80       --  reset to 3 for VMS for b__).
  81
  82    begin
  83       if Output_File_Name /= "" then
  84          Name_Buffer (1 .. Output_File_Name'Length) := Output_File_Name;
  85          Name_Buffer (Output_File_Name'Length + 1)  := ASCII.NUL;
  86
  87          if Typ = 's' then
  88             Name_Buffer (Output_File_Name'Last) := 's';
  89          end if;
  90
  91          Name_Len := Output_File_Name'Last;
  92
  93       else
  94          Name_Buffer (1) := 'b';
  95          File_Name := File_Names (Current_File_Name_Index);
  96
  97          Findex1 := File_Name'First;
  98
  99          --  The ali file might be specified by a full path name. However,
 100          --  the binder generated file should always be created in the
 101          --  current directory, so the path might need to be stripped away.
 102          --  In addition to the default directory_separator allow the '/' to
 103          --  act as separator since this is allowed in MS-DOS and OS2 ports.
 104
 105          for J in reverse File_Name'Range loop
 106             if File_Name (J) = Directory_Separator
 107               or else File_Name (J) = '/'
 108             then
 109                Findex1 := J + 1;
 110                exit;
 111             end if;
 112          end loop;
 113
 114          Findex2 := File_Name'Last;
 115          while File_Name (Findex2) /=  '.' loop
 116             Findex2 := Findex2 - 1;
 117          end loop;
 118
 119          Flength := Findex2 - Findex1;
 120
 121          if Maximum_File_Name_Length > 0 then
 122
 123             if OpenVMS_On_Target and then Typ /= 'c' then
 124                Bind_File_Prefix_Len := 3;
 125             end if;
 126
 127             --  Make room for the extra two characters in "b?"
 128
 129             while Int (Flength) >
 130               Maximum_File_Name_Length - Nat (Bind_File_Prefix_Len)
 131             loop
 132                Findex2 := Findex2 - 1;
 133                Flength := Findex2 - Findex1;
 134             end loop;
 135          end if;
 136
 137          Name_Buffer
 138            (Bind_File_Prefix_Len + 1 .. Flength + Bind_File_Prefix_Len) :=
 139               File_Name (Findex1 .. Findex2 - 1);
 140          Name_Buffer (Flength + Bind_File_Prefix_Len + 1) := '.';
 141
 142          --  C bind file, name is b_xxx.c
 143
 144          if Typ = 'c' then
 145             Name_Buffer (2) := '_';
 146             Name_Buffer (Flength + 4) := 'c';
 147             Name_Buffer (Flength + 5) := ASCII.NUL;
 148             Name_Len := Flength + 4;
 149
 150          --  Ada bind file, name is b~xxx.adb or b~xxx.ads
 151          --  (with __ instead of ~ in VMS)
 152
 153          else
 154             if OpenVMS_On_Target then
 155                Name_Buffer (2) := '_';
 156                Name_Buffer (3) := '_';
 157             else
 158                Name_Buffer (2) := '~';
 159             end if;
 160
 161             Name_Buffer (Flength + Bind_File_Prefix_Len + 2) := 'a';
 162             Name_Buffer (Flength + Bind_File_Prefix_Len + 3) := 'd';
 163             Name_Buffer (Flength + Bind_File_Prefix_Len + 4) := Typ;
 164             Name_Buffer (Flength + Bind_File_Prefix_Len + 5) := ASCII.NUL;
 165             Name_Len := Flength + Bind_File_Prefix_Len + 4;
 166          end if;
 167       end if;
 168
 169       Bfile := Name_Find;
 170
 171       Create_File_And_Check (Output_FD, Text);
 172    end Create_Binder_Output;
 173
 174    --------------------
 175    -- More_Lib_Files --
 176    --------------------
 177
 178    function More_Lib_Files return Boolean renames  More_Files;
 179
 180    ------------------------
 181    -- Next_Main_Lib_File --
 182    ------------------------
 183
 184    function Next_Main_Lib_File return File_Name_Type renames Next_Main_File;
 185
 186    ---------------------------------
 187    -- Set_Current_File_Name_Index --
 188    ---------------------------------
 189
 190    procedure Set_Current_File_Name_Index (To : Int) is
 191    begin
 192       Current_File_Name_Index := To;
 193    end Set_Current_File_Name_Index;
 194
 195    -------------------
 196    -- Set_List_File --
 197    -------------------
 198
 199    procedure Set_List_File (Filename : String) is
 200    begin
 201       pragma Assert (Current_List_File = Invalid_FD);
 202       Current_List_File := Create_File (Filename, Text);
 203
 204       if Current_List_File = Invalid_FD then
 205          Fail ("cannot create list file: " & Filename);
 206       else
 207          Set_Output (Current_List_File);
 208       end if;
 209    end Set_List_File;
 210
 211    -----------------------
 212    -- Write_Binder_Info --
 213    -----------------------
 214
 215    procedure Write_Binder_Info (Info : String) renames Write_Info;
 216
 217 begin
 218    Set_Program (Binder);
 219 end Osint.B;