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;
|
