1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2003 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
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
80 Close (Output_FD, Status);
84 ("error while closing ALI file ",
85 Get_Name_String (Output_File_Name));
87 end Close_Output_Library_Info;
89 ------------------------
90 -- Close_Repinfo_File --
91 ------------------------
93 procedure Close_Repinfo_File is
96 Close (Output_FD, Status);
100 ("error while closing representation info file ",
101 Get_Name_String (Output_File_Name));
103 end Close_Repinfo_File;
105 ---------------------------
106 -- Create_Auxiliary_File --
107 ---------------------------
109 function Create_Auxiliary_File
110 (Src : File_Name_Type;
112 return File_Name_Type
114 Result : File_Name_Type;
117 Get_Name_String (Src);
119 if Hostparm.OpenVMS then
120 Name_Buffer (Name_Len + 1) := '_';
122 Name_Buffer (Name_Len + 1) := '.';
125 Name_Len := Name_Len + 1;
126 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
127 Name_Len := Name_Len + Suffix'Length;
129 if Output_Object_File_Name /= null then
131 for Index in reverse Output_Object_File_Name'Range loop
133 if Output_Object_File_Name (Index) = Directory_Separator then
135 File_Name : constant String := Name_Buffer (1 .. Name_Len);
138 Name_Len := Index - Output_Object_File_Name'First + 1;
139 Name_Buffer (1 .. Name_Len) :=
140 Output_Object_File_Name
141 (Output_Object_File_Name'First .. Index);
142 Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) :=
144 Name_Len := Name_Len + File_Name'Length;
153 Name_Buffer (Name_Len + 1) := ASCII.NUL;
154 Create_File_And_Check (Output_FD, Text);
156 end Create_Auxiliary_File;
158 -----------------------
159 -- Create_Debug_File --
160 -----------------------
162 function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is
164 return Create_Auxiliary_File (Src, "dg");
165 end Create_Debug_File;
167 --------------------------------
168 -- Create_Output_Library_Info --
169 --------------------------------
171 procedure Create_Output_Library_Info is
173 Set_Library_Info_Name;
174 Create_File_And_Check (Output_FD, Text);
175 end Create_Output_Library_Info;
177 --------------------------
178 -- Creat_Repinfo_File --
179 --------------------------
181 procedure Creat_Repinfo_File (Src : File_Name_Type) is
182 S : constant File_Name_Type := Create_Auxiliary_File (Src, "rep");
183 pragma Warnings (Off, S);
187 end Creat_Repinfo_File;
189 ---------------------------
190 -- Debug_File_Eol_Length --
191 ---------------------------
193 function Debug_File_Eol_Length return Nat is
195 -- There has to be a cleaner way to do this! ???
197 if Directory_Separator = '/' then
202 end Debug_File_Eol_Length;
204 -----------------------
205 -- More_Source_Files --
206 -----------------------
208 function More_Source_Files return Boolean renames More_Files;
210 ----------------------
211 -- Next_Main_Source --
212 ----------------------
214 function Next_Main_Source return File_Name_Type renames Next_Main_File;
216 -----------------------
217 -- Read_Library_Info --
218 -----------------------
220 -- Version with default file name
222 procedure Read_Library_Info
223 (Name : out File_Name_Type;
224 Text : out Text_Buffer_Ptr)
227 Set_Library_Info_Name;
229 Text := Read_Library_Info (Name, Fatal_Err => False);
230 end Read_Library_Info;
232 ---------------------------
233 -- Set_Library_Info_Name --
234 ---------------------------
236 procedure Set_Library_Info_Name is
240 Get_Name_String (Current_Main);
242 -- Find last dot since we replace the existing extension by .ali. The
243 -- initialization to Name_Len + 1 provides for simply adding the .ali
244 -- extension if the source file name has no extension.
246 Dot_Index := Name_Len + 1;
248 for J in reverse 1 .. Name_Len loop
249 if Name_Buffer (J) = '.' then
255 -- Make sure that the output file name matches the source file name.
256 -- To compare them, remove file name directories and extensions.
258 if Output_Object_File_Name /= null then
259 -- Make sure there is a dot at Dot_Index. This may not be the case
260 -- if the source file name has no extension.
262 Name_Buffer (Dot_Index) := '.';
265 Name : constant String := Name_Buffer (1 .. Dot_Index);
266 Len : constant Natural := Dot_Index;
269 Name_Buffer (1 .. Output_Object_File_Name'Length)
270 := Output_Object_File_Name.all;
273 for J in reverse Output_Object_File_Name'Range loop
274 if Name_Buffer (J) = '.' then
280 pragma Assert (Dot_Index /= 0);
281 -- We check for the extension elsewhere
283 if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then
284 Fail ("incorrect object file name");
289 Name_Buffer (Dot_Index) := '.';
290 Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all;
291 Name_Buffer (Dot_Index + 4) := ASCII.NUL;
292 Name_Len := Dot_Index + 3;
293 end Set_Library_Info_Name;
295 ---------------------------------
296 -- Set_Output_Object_File_Name --
297 ---------------------------------
299 procedure Set_Output_Object_File_Name (Name : String) is
300 Ext : constant String := Object_Suffix;
301 NL : constant Natural := Name'Length;
302 EL : constant Natural := Ext'Length;
305 -- Make sure that the object file has the expected extension.
309 (Name (NL - EL + Name'First .. Name'Last) /= Ext
310 and then Name (NL - 2 + Name'First .. Name'Last) /= ".o")
312 Fail ("incorrect object file extension");
315 Output_Object_File_Name := new String'(Name);
316 end Set_Output_Object_File_Name;
322 procedure Tree_Close is
325 Tree_Write_Terminate;
326 Close (Output_FD, Status);
330 ("error while closing tree file ",
331 Get_Name_String (Output_File_Name));
339 procedure Tree_Create is
343 Get_Name_String (Current_Main);
345 -- If an object file has been specified, then the ALI file
346 -- will be in the same directory as the object file;
347 -- so, we put the tree file in this same directory,
348 -- even though no object file needs to be generated.
350 if Output_Object_File_Name /= null then
351 Name_Len := Output_Object_File_Name'Length;
352 Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
355 Dot_Index := Name_Len + 1;
357 for J in reverse 1 .. Name_Len loop
358 if Name_Buffer (J) = '.' then
364 -- Should be impossible to not have an extension
366 pragma Assert (Dot_Index /= 0);
368 -- Change exctension to adt
370 Name_Buffer (Dot_Index) := '.';
371 Name_Buffer (Dot_Index + 1) := 'a';
372 Name_Buffer (Dot_Index + 2) := 'd';
373 Name_Buffer (Dot_Index + 3) := 't';
374 Name_Buffer (Dot_Index + 4) := ASCII.NUL;
375 Name_Len := Dot_Index + 3;
376 Create_File_And_Check (Output_FD, Binary);
378 Tree_Write_Initialize (Output_FD);
381 -----------------------
382 -- Write_Debug_Info --
383 -----------------------
385 procedure Write_Debug_Info (Info : String) renames Write_Info;
387 ------------------------
388 -- Write_Library_Info --
389 ------------------------
391 procedure Write_Library_Info (Info : String) renames Write_Info;
393 ------------------------
394 -- Write_Repinfo_Line --
395 ------------------------
397 procedure Write_Repinfo_Line (Info : String) renames Write_Info;
401 Adjust_OS_Resource_Limits;
402 Opt.Creat_Repinfo_File_Access := Creat_Repinfo_File'Access;
403 Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
404 Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
406 Set_Program (Compiler);