1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001 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
;
47 return File_Name_Type
;
48 -- Common processing for Creat_Repinfo_File and Create_Debug_File.
49 -- Src is the file name used to create the required output file and
50 -- Suffix is the desired suffic (dg/rep for debug/repinfo file).
52 procedure Set_Library_Info_Name
;
53 -- Sets a default ali file name from the main compiler source name.
54 -- This is used by Create_Output_Library_Info, and by the version of
55 -- Read_Library_Info that takes a default file name.
57 ----------------------
58 -- Close_Debug_File --
59 ----------------------
61 procedure Close_Debug_File
is
66 -------------------------------
67 -- Close_Output_Library_Info --
68 -------------------------------
70 procedure Close_Output_Library_Info
is
73 end Close_Output_Library_Info
;
75 ------------------------
76 -- Close_Repinfo_File --
77 ------------------------
79 procedure Close_Repinfo_File
is
82 end Close_Repinfo_File
;
84 ---------------------------
85 -- Create_Auxiliary_File --
86 ---------------------------
88 function Create_Auxiliary_File
89 (Src
: File_Name_Type
;
93 Result
: File_Name_Type
;
96 Get_Name_String
(Src
);
98 if Hostparm
.OpenVMS
then
99 Name_Buffer
(Name_Len
+ 1) := '_';
101 Name_Buffer
(Name_Len
+ 1) := '.';
104 Name_Len
:= Name_Len
+ 1;
105 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Suffix
'Length) := Suffix
;
106 Name_Len
:= Name_Len
+ Suffix
'Length;
108 if Output_Object_File_Name
/= null then
110 for Index
in reverse Output_Object_File_Name
'Range loop
112 if Output_Object_File_Name
(Index
) = Directory_Separator
then
114 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
117 Name_Len
:= Index
- Output_Object_File_Name
'First + 1;
118 Name_Buffer
(1 .. Name_Len
) :=
119 Output_Object_File_Name
120 (Output_Object_File_Name
'First .. Index
);
121 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ File_Name
'Length) :=
123 Name_Len
:= Name_Len
+ File_Name
'Length;
132 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
133 Create_File_And_Check
(Output_FD
, Text
);
135 end Create_Auxiliary_File
;
137 -----------------------
138 -- Create_Debug_File --
139 -----------------------
141 function Create_Debug_File
(Src
: File_Name_Type
) return File_Name_Type
is
143 return Create_Auxiliary_File
(Src
, "dg");
144 end Create_Debug_File
;
146 --------------------------------
147 -- Create_Output_Library_Info --
148 --------------------------------
150 procedure Create_Output_Library_Info
is
152 Set_Library_Info_Name
;
153 Create_File_And_Check
(Output_FD
, Text
);
154 end Create_Output_Library_Info
;
156 --------------------------
157 -- Creat_Repinfo_File --
158 --------------------------
160 procedure Creat_Repinfo_File
(Src
: File_Name_Type
) is
161 S
: constant File_Name_Type
:= Create_Auxiliary_File
(Src
, "rep");
162 pragma Warnings
(Off
, S
);
166 end Creat_Repinfo_File
;
168 ---------------------------
169 -- Debug_File_Eol_Length --
170 ---------------------------
172 function Debug_File_Eol_Length
return Nat
is
174 -- There has to be a cleaner way to do this! ???
176 if Directory_Separator
= '/' then
181 end Debug_File_Eol_Length
;
183 -----------------------
184 -- More_Source_Files --
185 -----------------------
187 function More_Source_Files
return Boolean renames More_Files
;
189 ----------------------
190 -- Next_Main_Source --
191 ----------------------
193 function Next_Main_Source
return File_Name_Type
renames Next_Main_File
;
195 -----------------------
196 -- Read_Library_Info --
197 -----------------------
199 -- Version with default file name
201 procedure Read_Library_Info
202 (Name
: out File_Name_Type
;
203 Text
: out Text_Buffer_Ptr
)
206 Set_Library_Info_Name
;
208 Text
:= Read_Library_Info
(Name
, Fatal_Err
=> False);
209 end Read_Library_Info
;
211 ---------------------------
212 -- Set_Library_Info_Name --
213 ---------------------------
215 procedure Set_Library_Info_Name
is
219 Get_Name_String
(Current_Main
);
221 -- Find last dot since we replace the existing extension by .ali. The
222 -- initialization to Name_Len + 1 provides for simply adding the .ali
223 -- extension if the source file name has no extension.
225 Dot_Index
:= Name_Len
+ 1;
227 for J
in reverse 1 .. Name_Len
loop
228 if Name_Buffer
(J
) = '.' then
234 -- Make sure that the output file name matches the source file name.
235 -- To compare them, remove file name directories and extensions.
237 if Output_Object_File_Name
/= null then
238 -- Make sure there is a dot at Dot_Index. This may not be the case
239 -- if the source file name has no extension.
241 Name_Buffer
(Dot_Index
) := '.';
244 Name
: constant String := Name_Buffer
(1 .. Dot_Index
);
245 Len
: constant Natural := Dot_Index
;
248 Name_Buffer
(1 .. Output_Object_File_Name
'Length)
249 := Output_Object_File_Name
.all;
252 for J
in reverse Output_Object_File_Name
'Range loop
253 if Name_Buffer
(J
) = '.' then
259 pragma Assert
(Dot_Index
/= 0);
260 -- We check for the extension elsewhere
262 if Name
/= Name_Buffer
(Dot_Index
- Len
+ 1 .. Dot_Index
) then
263 Fail
("incorrect object file name");
268 Name_Buffer
(Dot_Index
) := '.';
269 Name_Buffer
(Dot_Index
+ 1 .. Dot_Index
+ 3) := ALI_Suffix
.all;
270 Name_Buffer
(Dot_Index
+ 4) := ASCII
.NUL
;
271 Name_Len
:= Dot_Index
+ 3;
272 end Set_Library_Info_Name
;
274 ---------------------------------
275 -- Set_Output_Object_File_Name --
276 ---------------------------------
278 procedure Set_Output_Object_File_Name
(Name
: String) is
279 Ext
: constant String := Object_Suffix
;
280 NL
: constant Natural := Name
'Length;
281 EL
: constant Natural := Ext
'Length;
284 -- Make sure that the object file has the expected extension.
288 (Name
(NL
- EL
+ Name
'First .. Name
'Last) /= Ext
289 and then Name
(NL
- 2 + Name
'First .. Name
'Last) /= ".o")
291 Fail
("incorrect object file extension");
294 Output_Object_File_Name
:= new String'(Name);
295 end Set_Output_Object_File_Name;
301 procedure Tree_Close is
303 Tree_Write_Terminate;
311 procedure Tree_Create is
315 Get_Name_String (Current_Main);
317 -- If an object file has been specified, then the ALI file
318 -- will be in the same directory as the object file;
319 -- so, we put the tree file in this same directory,
320 -- even though no object file needs to be generated.
322 if Output_Object_File_Name /= null then
323 Name_Len := Output_Object_File_Name'Length;
324 Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
328 for J in reverse 1 .. Name_Len loop
329 if Name_Buffer (J) = '.' then
335 -- Should be impossible to not have an extension
337 pragma Assert (Dot_Index /= 0);
339 -- Change exctension to adt
341 Name_Buffer (Dot_Index + 1) := 'a
';
342 Name_Buffer (Dot_Index + 2) := 'd
';
343 Name_Buffer (Dot_Index + 3) := 't
';
344 Name_Buffer (Dot_Index + 4) := ASCII.NUL;
345 Name_Len := Dot_Index + 3;
346 Create_File_And_Check (Output_FD, Binary);
348 Tree_Write_Initialize (Output_FD);
351 -----------------------
352 -- Write_Debug_Info --
353 -----------------------
355 procedure Write_Debug_Info (Info : String) renames Write_Info;
357 ------------------------
358 -- Write_Library_Info --
359 ------------------------
361 procedure Write_Library_Info (Info : String) renames Write_Info;
363 ------------------------
364 -- Write_Repinfo_Line --
365 ------------------------
367 procedure Write_Repinfo_Line (Info : String) renames Write_Info;
371 Adjust_OS_Resource_Limits;
372 Opt.Creat_Repinfo_File_Access := Creat_Repinfo_File'Access;
373 Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
374 Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
376 Set_Program (Compiler);