1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
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. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
28 with Namet
; use Namet
;
30 with Tree_IO
; use Tree_IO
;
32 package body Osint
.C
is
34 Output_Object_File_Name
: String_Ptr
;
35 -- Argument of -o compiler option, if given. This is needed to verify
36 -- consistency with the ALI file name.
38 procedure Adjust_OS_Resource_Limits
;
39 pragma Import
(C
, Adjust_OS_Resource_Limits
,
40 "__gnat_adjust_os_resource_limits");
41 -- Procedure to make system specific adjustments to make GNAT run better
43 function Create_Auxiliary_File
44 (Src
: File_Name_Type
;
45 Suffix
: String) return File_Name_Type
;
46 -- Common processing for Creat_Repinfo_File and Create_Debug_File.
47 -- Src is the file name used to create the required output file and
48 -- Suffix is the desired suffic (dg/rep for debug/repinfo file).
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
56 ----------------------
57 -- Close_Debug_File --
58 ----------------------
60 procedure Close_Debug_File
is
64 Close
(Output_FD
, Status
);
68 ("error while closing expanded source file ",
69 Get_Name_String
(Output_File_Name
));
73 -------------------------------
74 -- Close_Output_Library_Info --
75 -------------------------------
77 procedure Close_Output_Library_Info
is
81 Close
(Output_FD
, Status
);
85 ("error while closing ALI file ",
86 Get_Name_String
(Output_File_Name
));
88 end Close_Output_Library_Info
;
90 ------------------------
91 -- Close_Repinfo_File --
92 ------------------------
94 procedure Close_Repinfo_File
is
98 Close
(Output_FD
, Status
);
102 ("error while closing representation info file ",
103 Get_Name_String
(Output_File_Name
));
105 end Close_Repinfo_File
;
107 ---------------------------
108 -- Create_Auxiliary_File --
109 ---------------------------
111 function Create_Auxiliary_File
112 (Src
: File_Name_Type
;
113 Suffix
: String) return File_Name_Type
115 Result
: File_Name_Type
;
118 Get_Name_String
(Src
);
120 if Hostparm
.OpenVMS
then
121 Name_Buffer
(Name_Len
+ 1) := '_';
123 Name_Buffer
(Name_Len
+ 1) := '.';
126 Name_Len
:= Name_Len
+ 1;
127 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Suffix
'Length) := Suffix
;
128 Name_Len
:= Name_Len
+ Suffix
'Length;
130 if Output_Object_File_Name
/= null then
132 for Index
in reverse Output_Object_File_Name
'Range loop
134 if Output_Object_File_Name
(Index
) = Directory_Separator
then
136 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
139 Name_Len
:= Index
- Output_Object_File_Name
'First + 1;
140 Name_Buffer
(1 .. Name_Len
) :=
141 Output_Object_File_Name
142 (Output_Object_File_Name
'First .. Index
);
143 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ File_Name
'Length) :=
145 Name_Len
:= Name_Len
+ File_Name
'Length;
154 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
155 Create_File_And_Check
(Output_FD
, Text
);
157 end Create_Auxiliary_File
;
159 -----------------------
160 -- Create_Debug_File --
161 -----------------------
163 function Create_Debug_File
(Src
: File_Name_Type
) return File_Name_Type
is
165 return Create_Auxiliary_File
(Src
, "dg");
166 end Create_Debug_File
;
168 --------------------------------
169 -- Create_Output_Library_Info --
170 --------------------------------
172 procedure Create_Output_Library_Info
is
174 Set_Library_Info_Name
;
175 Create_File_And_Check
(Output_FD
, Text
);
176 end Create_Output_Library_Info
;
178 --------------------------
179 -- Creat_Repinfo_File --
180 --------------------------
182 procedure Creat_Repinfo_File
(Src
: File_Name_Type
) is
183 S
: constant File_Name_Type
:= Create_Auxiliary_File
(Src
, "rep");
184 pragma Warnings
(Off
, S
);
188 end Creat_Repinfo_File
;
190 ---------------------------
191 -- Debug_File_Eol_Length --
192 ---------------------------
194 function Debug_File_Eol_Length
return Nat
is
196 -- There has to be a cleaner way to do this! ???
198 if Directory_Separator
= '/' then
203 end Debug_File_Eol_Length
;
205 -----------------------
206 -- More_Source_Files --
207 -----------------------
209 function More_Source_Files
return Boolean renames More_Files
;
211 ----------------------
212 -- Next_Main_Source --
213 ----------------------
215 function Next_Main_Source
return File_Name_Type
renames Next_Main_File
;
217 -----------------------
218 -- Read_Library_Info --
219 -----------------------
221 -- Version with default file name
223 procedure Read_Library_Info
224 (Name
: out File_Name_Type
;
225 Text
: out Text_Buffer_Ptr
)
228 Set_Library_Info_Name
;
230 Text
:= Read_Library_Info
(Name
, Fatal_Err
=> False);
231 end Read_Library_Info
;
233 ---------------------------
234 -- Set_Library_Info_Name --
235 ---------------------------
237 procedure Set_Library_Info_Name
is
241 Get_Name_String
(Current_Main
);
243 -- Find last dot since we replace the existing extension by .ali. The
244 -- initialization to Name_Len + 1 provides for simply adding the .ali
245 -- extension if the source file name has no extension.
247 Dot_Index
:= Name_Len
+ 1;
249 for J
in reverse 1 .. Name_Len
loop
250 if Name_Buffer
(J
) = '.' then
256 -- Make sure that the output file name matches the source file name.
257 -- To compare them, remove file name directories and extensions.
259 if Output_Object_File_Name
/= null then
261 -- Make sure there is a dot at Dot_Index. This may not be the case
262 -- if the source file name has no extension.
264 Name_Buffer
(Dot_Index
) := '.';
266 -- If we are in multiple unit per file mode, then add ~nnn
267 -- extension to the name before doing the comparison.
269 if Multiple_Unit_Index
/= 0 then
271 Exten
: constant String := Name_Buffer
(Dot_Index
.. Name_Len
);
273 Name_Len
:= Dot_Index
- 1;
274 Add_Char_To_Name_Buffer
(Multi_Unit_Index_Character
);
275 Add_Nat_To_Name_Buffer
(Multiple_Unit_Index
);
276 Dot_Index
:= Name_Len
+ 1;
277 Add_Str_To_Name_Buffer
(Exten
);
281 -- Remove extension preparing to replace it
284 Name
: constant String := Name_Buffer
(1 .. Dot_Index
);
285 Len
: constant Natural := Dot_Index
;
288 Name_Buffer
(1 .. Output_Object_File_Name
'Length) :=
289 Output_Object_File_Name
.all;
292 for J
in reverse Output_Object_File_Name
'Range loop
293 if Name_Buffer
(J
) = '.' then
299 -- Dot_Index should be zero now (we check for extension elsewhere)
301 pragma Assert
(Dot_Index
/= 0);
303 -- Check name of object file is what we expect
305 if Name
/= Name_Buffer
(Dot_Index
- Len
+ 1 .. Dot_Index
) then
306 Fail
("incorrect object file name");
311 Name_Buffer
(Dot_Index
) := '.';
312 Name_Buffer
(Dot_Index
+ 1 .. Dot_Index
+ 3) := ALI_Suffix
.all;
313 Name_Buffer
(Dot_Index
+ 4) := ASCII
.NUL
;
314 Name_Len
:= Dot_Index
+ 3;
315 end Set_Library_Info_Name
;
317 ---------------------------------
318 -- Set_Output_Object_File_Name --
319 ---------------------------------
321 procedure Set_Output_Object_File_Name
(Name
: String) is
322 Ext
: constant String := Target_Object_Suffix
;
323 NL
: constant Natural := Name
'Length;
324 EL
: constant Natural := Ext
'Length;
327 -- Make sure that the object file has the expected extension
331 (Name
(NL
- EL
+ Name
'First .. Name
'Last) /= Ext
332 and then Name
(NL
- 2 + Name
'First .. Name
'Last) /= ".o")
334 Fail
("incorrect object file extension");
337 Output_Object_File_Name
:= new String'(Name);
338 end Set_Output_Object_File_Name;
344 procedure Tree_Close is
347 Tree_Write_Terminate;
348 Close (Output_FD, Status);
352 ("error while closing tree file ",
353 Get_Name_String (Output_File_Name));
361 procedure Tree_Create is
365 Get_Name_String (Current_Main);
367 -- If an object file has been specified, then the ALI file
368 -- will be in the same directory as the object file;
369 -- so, we put the tree file in this same directory,
370 -- even though no object file needs to be generated.
372 if Output_Object_File_Name /= null then
373 Name_Len := Output_Object_File_Name'Length;
374 Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
377 Dot_Index := Name_Len + 1;
379 for J in reverse 1 .. Name_Len loop
380 if Name_Buffer (J) = '.' then
386 -- Should be impossible to not have an extension
388 pragma Assert (Dot_Index /= 0);
390 -- Change exctension to adt
392 Name_Buffer (Dot_Index) := '.';
393 Name_Buffer (Dot_Index + 1) := 'a
';
394 Name_Buffer (Dot_Index + 2) := 'd
';
395 Name_Buffer (Dot_Index + 3) := 't
';
396 Name_Buffer (Dot_Index + 4) := ASCII.NUL;
397 Name_Len := Dot_Index + 3;
398 Create_File_And_Check (Output_FD, Binary);
400 Tree_Write_Initialize (Output_FD);
403 -----------------------
404 -- Write_Debug_Info --
405 -----------------------
407 procedure Write_Debug_Info (Info : String) renames Write_Info;
409 ------------------------
410 -- Write_Library_Info --
411 ------------------------
413 procedure Write_Library_Info (Info : String) renames Write_Info;
415 ------------------------
416 -- Write_Repinfo_Line --
417 ------------------------
419 procedure Write_Repinfo_Line (Info : String) renames Write_Info;
423 Adjust_OS_Resource_Limits;
424 Opt.Creat_Repinfo_File_Access := Creat_Repinfo_File'Access;
425 Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
426 Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
428 Set_Program (Compiler);