summaryrefslogtreecommitdiff
path: root/gcc/ada/osint-b.adb
blob: 39b7a99be8438696b949a030f2666da5b140e980 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              O S I N T - B                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2001-2010, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Opt;      use Opt;
with Output;   use Output;
with Targparm; use Targparm;

package body Osint.B is

   Current_List_File : File_Descriptor := Invalid_FD;

   -------------------------
   -- Close_Binder_Output --
   -------------------------

   procedure Close_Binder_Output is
      Status : Boolean;
   begin
      Close (Output_FD, Status);

      if not Status then
         Fail
           ("error while closing generated file "
            & Get_Name_String (Output_File_Name));
      end if;

   end Close_Binder_Output;

   ---------------------
   -- Close_List_File --
   ---------------------

   procedure Close_List_File is
   begin
      if Current_List_File /= Invalid_FD then
         Close (Current_List_File);
         Current_List_File := Invalid_FD;
         Set_Standard_Output;
      end if;
   end Close_List_File;

   --------------------------
   -- Create_Binder_Output --
   --------------------------

   procedure Create_Binder_Output
     (Output_File_Name : String;
      Typ              : Character;
      Bfile            : out Name_Id)
   is
      File_Name : String_Ptr;
      Findex1   : Natural;
      Findex2   : Natural;
      Flength   : Natural;

      Bind_File_Prefix_Len : Natural := 2;
      --  Length of binder file prefix (normally set to 2 for b~, but gets
      --  reset to 3 for VMS for b__).

   begin
      if Output_File_Name /= "" then
         Name_Buffer (1 .. Output_File_Name'Length) := Output_File_Name;
         Name_Buffer (Output_File_Name'Length + 1)  := ASCII.NUL;

         if Typ = 's' then
            Name_Buffer (Output_File_Name'Last) := 's';
         end if;

         Name_Len := Output_File_Name'Last;

      else
         Name_Buffer (1) := 'b';
         File_Name := File_Names (Current_File_Name_Index);

         Findex1 := File_Name'First;

         --  The ali file might be specified by a full path name. However,
         --  the binder generated file should always be created in the
         --  current directory, so the path might need to be stripped away.
         --  In addition to the default directory_separator allow the '/' to
         --  act as separator since this is allowed in MS-DOS and OS2 ports.

         for J in reverse File_Name'Range loop
            if File_Name (J) = Directory_Separator
              or else File_Name (J) = '/'
            then
               Findex1 := J + 1;
               exit;
            end if;
         end loop;

         Findex2 := File_Name'Last;
         while File_Name (Findex2) /=  '.' loop
            Findex2 := Findex2 - 1;
         end loop;

         Flength := Findex2 - Findex1;

         if Maximum_File_Name_Length > 0 then

            if OpenVMS_On_Target and then Typ /= 'c' then
               Bind_File_Prefix_Len := 3;
            end if;

            --  Make room for the extra two characters in "b?"

            while Int (Flength) >
              Maximum_File_Name_Length - Nat (Bind_File_Prefix_Len)
            loop
               Findex2 := Findex2 - 1;
               Flength := Findex2 - Findex1;
            end loop;
         end if;

         Name_Buffer
           (Bind_File_Prefix_Len + 1 .. Flength + Bind_File_Prefix_Len) :=
              File_Name (Findex1 .. Findex2 - 1);
         Name_Buffer (Flength + Bind_File_Prefix_Len + 1) := '.';

         --  C bind file, name is b_xxx.c

         if Typ = 'c' then
            Name_Buffer (2) := '_';
            Name_Buffer (Flength + 4) := 'c';
            Name_Buffer (Flength + 5) := ASCII.NUL;
            Name_Len := Flength + 4;

         --  Ada bind file, name is b~xxx.adb or b~xxx.ads
         --  (with __ instead of ~ in VMS)

         else
            if OpenVMS_On_Target then
               Name_Buffer (2) := '_';
               Name_Buffer (3) := '_';
            else
               Name_Buffer (2) := '~';
            end if;

            Name_Buffer (Flength + Bind_File_Prefix_Len + 2) := 'a';
            Name_Buffer (Flength + Bind_File_Prefix_Len + 3) := 'd';
            Name_Buffer (Flength + Bind_File_Prefix_Len + 4) := Typ;
            Name_Buffer (Flength + Bind_File_Prefix_Len + 5) := ASCII.NUL;
            Name_Len := Flength + Bind_File_Prefix_Len + 4;
         end if;
      end if;

      Bfile := Name_Find;

      Create_File_And_Check (Output_FD, Text);
   end Create_Binder_Output;

   --------------------
   -- More_Lib_Files --
   --------------------

   function More_Lib_Files return Boolean renames  More_Files;

   ------------------------
   -- Next_Main_Lib_File --
   ------------------------

   function Next_Main_Lib_File return File_Name_Type renames Next_Main_File;

   ---------------------------------
   -- Set_Current_File_Name_Index --
   ---------------------------------

   procedure Set_Current_File_Name_Index (To : Int) is
   begin
      Current_File_Name_Index := To;
   end Set_Current_File_Name_Index;

   -------------------
   -- Set_List_File --
   -------------------

   procedure Set_List_File (Filename : String) is
   begin
      pragma Assert (Current_List_File = Invalid_FD);
      Current_List_File := Create_File (Filename, Text);

      if Current_List_File = Invalid_FD then
         Fail ("cannot create list file: " & Filename);
      else
         Set_Output (Current_List_File);
      end if;
   end Set_List_File;

   -----------------------
   -- Write_Binder_Info --
   -----------------------

   procedure Write_Binder_Info (Info : String) renames Write_Info;

begin
   Set_Program (Binder);
end Osint.B;