1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2004 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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
36 -- verify 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
44 function Create_Auxiliary_File
45 (Src
: File_Name_Type
;
46 Suffix
: String) return File_Name_Type
;
47 -- Common processing for Creat_Repinfo_File and Create_Debug_File.
48 -- Src is the file name used to create the required output file and
49 -- Suffix is the desired suffic (dg/rep for debug/repinfo file).
51 procedure Set_Library_Info_Name
;
52 -- Sets a default ali file name from the main compiler source name.
53 -- This is used by Create_Output_Library_Info, and by the version of
54 -- Read_Library_Info that takes a default file name. The name is in
55 -- Name_Buffer (with length in Name_Len) on return from the call
57 ----------------------
58 -- Close_Debug_File --
59 ----------------------
61 procedure Close_Debug_File
is
65 Close
(Output_FD
, Status
);
69 ("error while closing expanded source file ",
70 Get_Name_String
(Output_File_Name
));
74 -------------------------------
75 -- Close_Output_Library_Info --
76 -------------------------------
78 procedure Close_Output_Library_Info
is
82 Close
(Output_FD
, Status
);
86 ("error while closing ALI file ",
87 Get_Name_String
(Output_File_Name
));
89 end Close_Output_Library_Info
;
91 ------------------------
92 -- Close_Repinfo_File --
93 ------------------------
95 procedure Close_Repinfo_File
is
99 Close
(Output_FD
, Status
);
103 ("error while closing representation info file ",
104 Get_Name_String
(Output_File_Name
));
106 end Close_Repinfo_File
;
108 ---------------------------
109 -- Create_Auxiliary_File --
110 ---------------------------
112 function Create_Auxiliary_File
113 (Src
: File_Name_Type
;
114 Suffix
: String) return File_Name_Type
116 Result
: File_Name_Type
;
119 Get_Name_String
(Src
);
121 if Hostparm
.OpenVMS
then
122 Name_Buffer
(Name_Len
+ 1) := '_';
124 Name_Buffer
(Name_Len
+ 1) := '.';
127 Name_Len
:= Name_Len
+ 1;
128 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Suffix
'Length) := Suffix
;
129 Name_Len
:= Name_Len
+ Suffix
'Length;
131 if Output_Object_File_Name
/= null then
133 for Index
in reverse Output_Object_File_Name
'Range loop
135 if Output_Object_File_Name
(Index
) = Directory_Separator
then
137 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
140 Name_Len
:= Index
- Output_Object_File_Name
'First + 1;
141 Name_Buffer
(1 .. Name_Len
) :=
142 Output_Object_File_Name
143 (Output_Object_File_Name
'First .. Index
);
144 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ File_Name
'Length) :=
146 Name_Len
:= Name_Len
+ File_Name
'Length;
155 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
156 Create_File_And_Check
(Output_FD
, Text
);
158 end Create_Auxiliary_File
;
160 -----------------------
161 -- Create_Debug_File --
162 -----------------------
164 function Create_Debug_File
(Src
: File_Name_Type
) return File_Name_Type
is
166 return Create_Auxiliary_File
(Src
, "dg");
167 end Create_Debug_File
;
169 --------------------------------
170 -- Create_Output_Library_Info --
171 --------------------------------
173 procedure Create_Output_Library_Info
is
175 Set_Library_Info_Name
;
176 Create_File_And_Check
(Output_FD
, Text
);
177 end Create_Output_Library_Info
;
179 --------------------------
180 -- Creat_Repinfo_File --
181 --------------------------
183 procedure Creat_Repinfo_File
(Src
: File_Name_Type
) is
184 S
: constant File_Name_Type
:= Create_Auxiliary_File
(Src
, "rep");
185 pragma Warnings
(Off
, S
);
189 end Creat_Repinfo_File
;
191 ---------------------------
192 -- Debug_File_Eol_Length --
193 ---------------------------
195 function Debug_File_Eol_Length
return Nat
is
197 -- There has to be a cleaner way to do this! ???
199 if Directory_Separator
= '/' then
204 end Debug_File_Eol_Length
;
206 -----------------------
207 -- More_Source_Files --
208 -----------------------
210 function More_Source_Files
return Boolean renames More_Files
;
212 ----------------------
213 -- Next_Main_Source --
214 ----------------------
216 function Next_Main_Source
return File_Name_Type
renames Next_Main_File
;
218 -----------------------
219 -- Read_Library_Info --
220 -----------------------
222 -- Version with default file name
224 procedure Read_Library_Info
225 (Name
: out File_Name_Type
;
226 Text
: out Text_Buffer_Ptr
)
229 Set_Library_Info_Name
;
231 Text
:= Read_Library_Info
(Name
, Fatal_Err
=> False);
232 end Read_Library_Info
;
234 ---------------------------
235 -- Set_Library_Info_Name --
236 ---------------------------
238 procedure Set_Library_Info_Name
is
242 Get_Name_String
(Current_Main
);
244 -- Find last dot since we replace the existing extension by .ali. The
245 -- initialization to Name_Len + 1 provides for simply adding the .ali
246 -- extension if the source file name has no extension.
248 Dot_Index
:= Name_Len
+ 1;
250 for J
in reverse 1 .. Name_Len
loop
251 if Name_Buffer
(J
) = '.' then
257 -- Make sure that the output file name matches the source file name.
258 -- To compare them, remove file name directories and extensions.
260 if Output_Object_File_Name
/= null then
262 -- Make sure there is a dot at Dot_Index. This may not be the case
263 -- if the source file name has no extension.
265 Name_Buffer
(Dot_Index
) := '.';
267 -- If we are in multiple unit per file mode, then add ~nnn
268 -- extension to the name before doing the comparison.
270 if Multiple_Unit_Index
/= 0 then
272 Exten
: constant String := Name_Buffer
(Dot_Index
.. Name_Len
);
274 Name_Len
:= Dot_Index
- 1;
275 Add_Char_To_Name_Buffer
(Multi_Unit_Index_Character
);
276 Add_Nat_To_Name_Buffer
(Multiple_Unit_Index
);
277 Dot_Index
:= Name_Len
+ 1;
278 Add_Str_To_Name_Buffer
(Exten
);
282 -- Remove extension preparing to replace it
285 Name
: constant String := Name_Buffer
(1 .. Dot_Index
);
286 Len
: constant Natural := Dot_Index
;
289 Name_Buffer
(1 .. Output_Object_File_Name
'Length) :=
290 Output_Object_File_Name
.all;
293 for J
in reverse Output_Object_File_Name
'Range loop
294 if Name_Buffer
(J
) = '.' then
300 -- Dot_Index should be zero now (we check for extension elsewhere)
302 pragma Assert
(Dot_Index
/= 0);
304 -- Check name of object file is what we expect
306 if Name
/= Name_Buffer
(Dot_Index
- Len
+ 1 .. Dot_Index
) then
307 Fail
("incorrect object file name");
312 Name_Buffer
(Dot_Index
) := '.';
313 Name_Buffer
(Dot_Index
+ 1 .. Dot_Index
+ 3) := ALI_Suffix
.all;
314 Name_Buffer
(Dot_Index
+ 4) := ASCII
.NUL
;
315 Name_Len
:= Dot_Index
+ 3;
316 end Set_Library_Info_Name
;
318 ---------------------------------
319 -- Set_Output_Object_File_Name --
320 ---------------------------------
322 procedure Set_Output_Object_File_Name
(Name
: String) is
323 Ext
: constant String := Object_Suffix
;
324 NL
: constant Natural := Name
'Length;
325 EL
: constant Natural := Ext
'Length;
328 -- Make sure that the object file has the expected extension.
332 (Name
(NL
- EL
+ Name
'First .. Name
'Last) /= Ext
333 and then Name
(NL
- 2 + Name
'First .. Name
'Last) /= ".o")
335 Fail
("incorrect object file extension");
338 Output_Object_File_Name
:= new String'(Name);
339 end Set_Output_Object_File_Name;
345 procedure Tree_Close is
348 Tree_Write_Terminate;
349 Close (Output_FD, Status);
353 ("error while closing tree file ",
354 Get_Name_String (Output_File_Name));
362 procedure Tree_Create is
366 Get_Name_String (Current_Main);
368 -- If an object file has been specified, then the ALI file
369 -- will be in the same directory as the object file;
370 -- so, we put the tree file in this same directory,
371 -- even though no object file needs to be generated.
373 if Output_Object_File_Name /= null then
374 Name_Len := Output_Object_File_Name'Length;
375 Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
378 Dot_Index := Name_Len + 1;
380 for J in reverse 1 .. Name_Len loop
381 if Name_Buffer (J) = '.' then
387 -- Should be impossible to not have an extension
389 pragma Assert (Dot_Index /= 0);
391 -- Change exctension to adt
393 Name_Buffer (Dot_Index) := '.';
394 Name_Buffer (Dot_Index + 1) := 'a
';
395 Name_Buffer (Dot_Index + 2) := 'd
';
396 Name_Buffer (Dot_Index + 3) := 't
';
397 Name_Buffer (Dot_Index + 4) := ASCII.NUL;
398 Name_Len := Dot_Index + 3;
399 Create_File_And_Check (Output_FD, Binary);
401 Tree_Write_Initialize (Output_FD);
404 -----------------------
405 -- Write_Debug_Info --
406 -----------------------
408 procedure Write_Debug_Info (Info : String) renames Write_Info;
410 ------------------------
411 -- Write_Library_Info --
412 ------------------------
414 procedure Write_Library_Info (Info : String) renames Write_Info;
416 ------------------------
417 -- Write_Repinfo_Line --
418 ------------------------
420 procedure Write_Repinfo_Line (Info : String) renames Write_Info;
424 Adjust_OS_Resource_Limits;
425 Opt.Creat_Repinfo_File_Access := Creat_Repinfo_File'Access;
426 Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
427 Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
429 Set_Program (Compiler);