1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2008, 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 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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
28 with Tree_IO
; use Tree_IO
;
30 package body Osint
.C
is
32 Output_Object_File_Name
: String_Ptr
;
33 -- Argument of -o compiler option, if given. This is needed to verify
34 -- consistency with the ALI file name.
36 procedure Adjust_OS_Resource_Limits
;
37 pragma Import
(C
, Adjust_OS_Resource_Limits
,
38 "__gnat_adjust_os_resource_limits");
39 -- Procedure to make system specific adjustments to make GNAT run better
41 function Create_Auxiliary_File
42 (Src
: File_Name_Type
;
43 Suffix
: String) return File_Name_Type
;
44 -- Common processing for Create_List_File, Create_Repinfo_File and
45 -- Create_Debug_File. Src is the file name used to create the required
46 -- output file and Suffix is the desired suffix (dg/rep/xxx for debug/
47 -- repinfo/list file where xxx is specified extension.
49 procedure Set_Library_Info_Name
;
50 -- Sets a default ALI file name from the main compiler source name.
51 -- This is used by Create_Output_Library_Info, and by the version of
52 -- Read_Library_Info that takes a default file name. The name is in
53 -- Name_Buffer (with length in Name_Len) on return from the call.
55 ----------------------
56 -- Close_Debug_File --
57 ----------------------
59 procedure Close_Debug_File
is
63 Close
(Output_FD
, Status
);
67 ("error while closing expanded source file ",
68 Get_Name_String
(Output_File_Name
));
76 procedure Close_List_File
is
80 Close
(Output_FD
, Status
);
84 ("error while closing list file ",
85 Get_Name_String
(Output_File_Name
));
89 -------------------------------
90 -- Close_Output_Library_Info --
91 -------------------------------
93 procedure Close_Output_Library_Info
is
97 Close
(Output_FD
, Status
);
101 ("error while closing ALI file ",
102 Get_Name_String
(Output_File_Name
));
104 end Close_Output_Library_Info
;
106 ------------------------
107 -- Close_Repinfo_File --
108 ------------------------
110 procedure Close_Repinfo_File
is
114 Close
(Output_FD
, Status
);
118 ("error while closing representation info file ",
119 Get_Name_String
(Output_File_Name
));
121 end Close_Repinfo_File
;
123 ---------------------------
124 -- Create_Auxiliary_File --
125 ---------------------------
127 function Create_Auxiliary_File
128 (Src
: File_Name_Type
;
129 Suffix
: String) return File_Name_Type
131 Result
: File_Name_Type
;
134 Get_Name_String
(Src
);
136 if Hostparm
.OpenVMS
then
137 Name_Buffer
(Name_Len
+ 1) := '_';
139 Name_Buffer
(Name_Len
+ 1) := '.';
142 Name_Len
:= Name_Len
+ 1;
143 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Suffix
'Length) := Suffix
;
144 Name_Len
:= Name_Len
+ Suffix
'Length;
146 if Output_Object_File_Name
/= null then
147 for Index
in reverse Output_Object_File_Name
'Range loop
148 if Output_Object_File_Name
(Index
) = Directory_Separator
then
150 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
152 Name_Len
:= Index
- Output_Object_File_Name
'First + 1;
153 Name_Buffer
(1 .. Name_Len
) :=
154 Output_Object_File_Name
155 (Output_Object_File_Name
'First .. Index
);
156 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ File_Name
'Length) :=
158 Name_Len
:= Name_Len
+ File_Name
'Length;
167 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
168 Create_File_And_Check
(Output_FD
, Text
);
170 end Create_Auxiliary_File
;
172 -----------------------
173 -- Create_Debug_File --
174 -----------------------
176 function Create_Debug_File
(Src
: File_Name_Type
) return File_Name_Type
is
178 return Create_Auxiliary_File
(Src
, "dg");
179 end Create_Debug_File
;
181 ----------------------
182 -- Create_List_File --
183 ----------------------
185 procedure Create_List_File
(S
: String) is
187 pragma Warnings
(Off
, F
);
189 if S
(S
'First) = '.' then
190 F
:= Create_Auxiliary_File
(Current_Main
, S
(S
'First + 1 .. S
'Last));
193 Name_Buffer
(1 .. S
'Length) := S
;
194 Name_Len
:= S
'Length + 1;
195 Name_Buffer
(Name_Len
) := ASCII
.NUL
;
196 Create_File_And_Check
(Output_FD
, Text
);
198 end Create_List_File
;
200 --------------------------------
201 -- Create_Output_Library_Info --
202 --------------------------------
204 procedure Create_Output_Library_Info
is
206 Set_Library_Info_Name
;
207 Create_File_And_Check
(Output_FD
, Text
);
208 end Create_Output_Library_Info
;
210 -------------------------
211 -- Create_Repinfo_File --
212 -------------------------
214 procedure Create_Repinfo_File
(Src
: String) is
215 Discard
: File_Name_Type
;
216 pragma Warnings
(Off
, Discard
);
218 Name_Buffer
(1 .. Src
'Length) := Src
;
219 Name_Len
:= Src
'Length;
220 Discard
:= Create_Auxiliary_File
(Name_Find
, "rep");
222 end Create_Repinfo_File
;
224 ---------------------------
225 -- Debug_File_Eol_Length --
226 ---------------------------
228 function Debug_File_Eol_Length
return Nat
is
230 -- There has to be a cleaner way to do this! ???
232 if Directory_Separator
= '/' then
237 end Debug_File_Eol_Length
;
239 -----------------------
240 -- More_Source_Files --
241 -----------------------
243 function More_Source_Files
return Boolean renames More_Files
;
245 ----------------------
246 -- Next_Main_Source --
247 ----------------------
249 function Next_Main_Source
return File_Name_Type
renames Next_Main_File
;
251 -----------------------
252 -- Read_Library_Info --
253 -----------------------
255 -- Version with default file name
257 procedure Read_Library_Info
258 (Name
: out File_Name_Type
;
259 Text
: out Text_Buffer_Ptr
)
262 Set_Library_Info_Name
;
264 Text
:= Read_Library_Info
(Name
, Fatal_Err
=> False);
265 end Read_Library_Info
;
267 ---------------------------
268 -- Set_Library_Info_Name --
269 ---------------------------
271 procedure Set_Library_Info_Name
is
275 Get_Name_String
(Current_Main
);
277 -- Find last dot since we replace the existing extension by .ali. The
278 -- initialization to Name_Len + 1 provides for simply adding the .ali
279 -- extension if the source file name has no extension.
281 Dot_Index
:= Name_Len
+ 1;
283 for J
in reverse 1 .. Name_Len
loop
284 if Name_Buffer
(J
) = '.' then
290 -- Make sure that the output file name matches the source file name.
291 -- To compare them, remove file name directories and extensions.
293 if Output_Object_File_Name
/= null then
295 -- Make sure there is a dot at Dot_Index. This may not be the case
296 -- if the source file name has no extension.
298 Name_Buffer
(Dot_Index
) := '.';
300 -- If we are in multiple unit per file mode, then add ~nnn
301 -- extension to the name before doing the comparison.
303 if Multiple_Unit_Index
/= 0 then
305 Exten
: constant String := Name_Buffer
(Dot_Index
.. Name_Len
);
307 Name_Len
:= Dot_Index
- 1;
308 Add_Char_To_Name_Buffer
(Multi_Unit_Index_Character
);
309 Add_Nat_To_Name_Buffer
(Multiple_Unit_Index
);
310 Dot_Index
:= Name_Len
+ 1;
311 Add_Str_To_Name_Buffer
(Exten
);
315 -- Remove extension preparing to replace it
318 Name
: String := Name_Buffer
(1 .. Dot_Index
);
322 Name_Buffer
(1 .. Output_Object_File_Name
'Length) :=
323 Output_Object_File_Name
.all;
325 -- Put two names in canonical case, to allow object file names
326 -- with upper-case letters on Windows.
328 Canonical_Case_File_Name
(Name
);
329 Canonical_Case_File_Name
330 (Name_Buffer
(1 .. Output_Object_File_Name
'Length));
333 for J
in reverse Output_Object_File_Name
'Range loop
334 if Name_Buffer
(J
) = '.' then
340 -- Dot_Index should not be zero now (we check for extension
343 pragma Assert
(Dot_Index
/= 0);
345 -- Look for first character of file name
349 and then Name_Buffer
(First
- 1) /= Directory_Separator
350 and then Name_Buffer
(First
- 1) /= '/'
355 -- Check name of object file is what we expect
357 if Name
/= Name_Buffer
(First
.. Dot_Index
) then
358 Fail
("incorrect object file name");
363 Name_Buffer
(Dot_Index
) := '.';
364 Name_Buffer
(Dot_Index
+ 1 .. Dot_Index
+ 3) := ALI_Suffix
.all;
365 Name_Buffer
(Dot_Index
+ 4) := ASCII
.NUL
;
366 Name_Len
:= Dot_Index
+ 3;
367 end Set_Library_Info_Name
;
369 ---------------------------------
370 -- Set_Output_Object_File_Name --
371 ---------------------------------
373 procedure Set_Output_Object_File_Name
(Name
: String) is
374 Ext
: constant String := Target_Object_Suffix
;
375 NL
: constant Natural := Name
'Length;
376 EL
: constant Natural := Ext
'Length;
379 -- Make sure that the object file has the expected extension
383 (Name
(NL
- EL
+ Name
'First .. Name
'Last) /= Ext
384 and then Name
(NL
- 2 + Name
'First .. Name
'Last) /= ".o")
386 Fail
("incorrect object file extension");
389 Output_Object_File_Name
:= new String'(Name);
390 end Set_Output_Object_File_Name;
396 procedure Tree_Close is
399 Tree_Write_Terminate;
400 Close (Output_FD, Status);
404 ("error while closing tree file ",
405 Get_Name_String (Output_File_Name));
413 procedure Tree_Create is
417 Get_Name_String (Current_Main);
419 -- If an object file has been specified, then the ALI file
420 -- will be in the same directory as the object file;
421 -- so, we put the tree file in this same directory,
422 -- even though no object file needs to be generated.
424 if Output_Object_File_Name /= null then
425 Name_Len := Output_Object_File_Name'Length;
426 Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
429 Dot_Index := Name_Len + 1;
431 for J in reverse 1 .. Name_Len loop
432 if Name_Buffer (J) = '.' then
438 -- Should be impossible to not have an extension
440 pragma Assert (Dot_Index /= 0);
442 -- Change extension to adt
444 Name_Buffer (Dot_Index) := '.';
445 Name_Buffer (Dot_Index + 1) := 'a
';
446 Name_Buffer (Dot_Index + 2) := 'd
';
447 Name_Buffer (Dot_Index + 3) := 't
';
448 Name_Buffer (Dot_Index + 4) := ASCII.NUL;
449 Name_Len := Dot_Index + 3;
450 Create_File_And_Check (Output_FD, Binary);
452 Tree_Write_Initialize (Output_FD);
455 -----------------------
456 -- Write_Debug_Info --
457 -----------------------
459 procedure Write_Debug_Info (Info : String) renames Write_Info;
461 ------------------------
462 -- Write_Library_Info --
463 ------------------------
465 procedure Write_Library_Info (Info : String) renames Write_Info;
467 ---------------------
468 -- Write_List_Info --
469 ---------------------
471 procedure Write_List_Info (S : String) is
473 Write_With_Check (S'Address, S'Length);
476 ------------------------
477 -- Write_Repinfo_Line --
478 ------------------------
480 procedure Write_Repinfo_Line (Info : String) renames Write_Info;
483 Adjust_OS_Resource_Limits;
485 Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access;
486 Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
487 Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
489 Opt.Create_List_File_Access := Create_List_File'Access;
490 Opt.Write_List_Info_Access := Write_List_Info'Access;
491 Opt.Close_List_File_Access := Close_List_File'Access;
493 Set_Program (Compiler);