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-2023, 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
  29 package body Osint.B is
  30
  31    Current_List_File : File_Descriptor := Invalid_FD;
  32
  33    -------------------------
  34    -- Close_Binder_Output --
  35    -------------------------
  36
  37    procedure Close_Binder_Output is
  38       Status : Boolean;
  39    begin
  40       Close (Output_FD, Status);
  41
  42       if not Status then
  43          Fail
  44            ("error while closing generated file "
  45             & Get_Name_String (Output_File_Name));
  46       end if;
  47
  48    end Close_Binder_Output;
  49
  50    ---------------------
  51    -- Close_List_File --
  52    ---------------------
  53
  54    procedure Close_List_File is
  55    begin
  56       if Current_List_File /= Invalid_FD then
  57          Close (Current_List_File);
  58          Current_List_File := Invalid_FD;
  59          Set_Standard_Output;
  60       end if;
  61    end Close_List_File;
  62
  63    --------------------------
  64    -- Create_Binder_Output --
  65    --------------------------
  66
  67    procedure Create_Binder_Output
  68      (Output_File_Name : String;
  69       Typ              : Character;
  70       Bfile            : out Name_Id)
  71    is
  72       File_Name : String_Ptr;
  73       Findex1   : Natural;
  74       Findex2   : Natural;
  75       Flength   : Natural;
  76
  77       Bind_File_Prefix_Len : constant Natural := 2;
  78       --  Length of binder file prefix (2 for b~)
  79
  80    begin
  81       if Output_File_Name /= "" then
  82          Name_Buffer (1 .. Output_File_Name'Length) := Output_File_Name;
  83          Name_Buffer (Output_File_Name'Length + 1)  := ASCII.NUL;
  84
  85          if Typ = 's' then
  86             Name_Buffer (Output_File_Name'Last) := 's';
  87          end if;
  88
  89          Name_Len := Output_File_Name'Last;
  90
  91       else
  92          Name_Buffer (1) := 'b';
  93          File_Name := File_Names (Current_File_Name_Index);
  94
  95          Findex1 := File_Name'First;
  96
  97          --  The ali file might be specified by a full path name. However,
  98          --  the binder generated file should always be created in the
  99          --  current directory, so the path might need to be stripped away.
 100          --  In addition to the default directory_separator allow the '/' to
 101          --  act as separator since this is allowed in MS-DOS and OS2 ports.
 102
 103          for J in reverse File_Name'Range loop
 104             if File_Name (J) = Directory_Separator
 105               or else File_Name (J) = '/'
 106             then
 107                Findex1 := J + 1;
 108                exit;
 109             end if;
 110          end loop;
 111
 112          Findex2 := File_Name'Last;
 113          while File_Name (Findex2) /=  '.' loop
 114             Findex2 := Findex2 - 1;
 115          end loop;
 116
 117          Flength := Findex2 - Findex1;
 118
 119          if Maximum_File_Name_Length > 0 then
 120
 121             --  Make room for the extra two characters in "b?"
 122
 123             while Int (Flength) >
 124               Maximum_File_Name_Length - Nat (Bind_File_Prefix_Len)
 125             loop
 126                Findex2 := Findex2 - 1;
 127                Flength := Findex2 - Findex1;
 128             end loop;
 129          end if;
 130
 131          Name_Buffer
 132            (Bind_File_Prefix_Len + 1 .. Flength + Bind_File_Prefix_Len) :=
 133               File_Name (Findex1 .. Findex2 - 1);
 134          Name_Buffer (Flength + Bind_File_Prefix_Len + 1) := '.';
 135
 136          --  Ada bind file, name is b~xxx.adb or b~xxx.ads
 137
 138          Name_Buffer (2) := '~';
 139
 140          Name_Buffer (Flength + Bind_File_Prefix_Len + 2) := 'a';
 141          Name_Buffer (Flength + Bind_File_Prefix_Len + 3) := 'd';
 142          Name_Buffer (Flength + Bind_File_Prefix_Len + 4) := Typ;
 143          Name_Buffer (Flength + Bind_File_Prefix_Len + 5) := ASCII.NUL;
 144          Name_Len := Flength + Bind_File_Prefix_Len + 4;
 145       end if;
 146
 147       Bfile := Name_Find;
 148
 149       Create_File_And_Check (Output_FD, Text);
 150    end Create_Binder_Output;
 151
 152    --------------------
 153    -- More_Lib_Files --
 154    --------------------
 155
 156    function More_Lib_Files return Boolean renames More_Files;
 157
 158    ------------------------
 159    -- Next_Main_Lib_File --
 160    ------------------------
 161
 162    function Next_Main_Lib_File return File_Name_Type renames Next_Main_File;
 163
 164    ---------------------------------
 165    -- Set_Current_File_Name_Index --
 166    ---------------------------------
 167
 168    procedure Set_Current_File_Name_Index (To : Int) is
 169    begin
 170       Current_File_Name_Index := To;
 171    end Set_Current_File_Name_Index;
 172
 173    -------------------
 174    -- Set_List_File --
 175    -------------------
 176
 177    procedure Set_List_File (Filename : String) is
 178    begin
 179       pragma Assert (Current_List_File = Invalid_FD);
 180       Current_List_File := Create_File (Filename, Text);
 181
 182       if Current_List_File = Invalid_FD then
 183          Fail ("cannot create list file: " & Filename);
 184       else
 185          Set_Output (Current_List_File);
 186       end if;
 187    end Set_List_File;
 188
 189    -----------------------
 190    -- Write_Binder_Info --
 191    -----------------------
 192
 193    procedure Write_Binder_Info (Info : String) renames Write_Info;
 194
 195 begin
 196    Set_Program (Binder);
 197 end Osint.B;