Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / osint-c.adb
blobd43332694777925cd7e9ee096ca10d2c2c1c14c9
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- O S I N T - C --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2011, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Hostparm;
27 with Opt; use Opt;
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 ----------------------
50 -- Close_Debug_File --
51 ----------------------
53 procedure Close_Debug_File is
54 Status : Boolean;
56 begin
57 Close (Output_FD, Status);
59 if not Status then
60 Fail
61 ("error while closing expanded source file "
62 & Get_Name_String (Output_File_Name));
63 end if;
64 end Close_Debug_File;
66 ---------------------
67 -- Close_List_File --
68 ---------------------
70 procedure Close_List_File is
71 Status : Boolean;
73 begin
74 Close (Output_FD, Status);
76 if not Status then
77 Fail
78 ("error while closing list file "
79 & Get_Name_String (Output_File_Name));
80 end if;
81 end Close_List_File;
83 -------------------------------
84 -- Close_Output_Library_Info --
85 -------------------------------
87 procedure Close_Output_Library_Info is
88 Status : Boolean;
90 begin
91 Close (Output_FD, Status);
93 if not Status then
94 Fail
95 ("error while closing ALI file "
96 & Get_Name_String (Output_File_Name));
97 end if;
98 end Close_Output_Library_Info;
100 ------------------------
101 -- Close_Repinfo_File --
102 ------------------------
104 procedure Close_Repinfo_File is
105 Status : Boolean;
107 begin
108 Close (Output_FD, Status);
110 if not Status then
111 Fail
112 ("error while closing representation info file "
113 & Get_Name_String (Output_File_Name));
114 end if;
115 end Close_Repinfo_File;
117 ---------------------------
118 -- Create_Auxiliary_File --
119 ---------------------------
121 function Create_Auxiliary_File
122 (Src : File_Name_Type;
123 Suffix : String) return File_Name_Type
125 Result : File_Name_Type;
127 begin
128 Get_Name_String (Src);
130 if Hostparm.OpenVMS then
131 Name_Buffer (Name_Len + 1) := '_';
132 else
133 Name_Buffer (Name_Len + 1) := '.';
134 end if;
136 Name_Len := Name_Len + 1;
137 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
138 Name_Len := Name_Len + Suffix'Length;
140 if Output_Object_File_Name /= null then
141 for Index in reverse Output_Object_File_Name'Range loop
142 if Output_Object_File_Name (Index) = Directory_Separator then
143 declare
144 File_Name : constant String := Name_Buffer (1 .. Name_Len);
145 begin
146 Name_Len := Index - Output_Object_File_Name'First + 1;
147 Name_Buffer (1 .. Name_Len) :=
148 Output_Object_File_Name
149 (Output_Object_File_Name'First .. Index);
150 Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) :=
151 File_Name;
152 Name_Len := Name_Len + File_Name'Length;
153 end;
155 exit;
156 end if;
157 end loop;
158 end if;
160 Result := Name_Find;
161 Name_Buffer (Name_Len + 1) := ASCII.NUL;
162 Create_File_And_Check (Output_FD, Text);
163 return Result;
164 end Create_Auxiliary_File;
166 -----------------------
167 -- Create_Debug_File --
168 -----------------------
170 function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is
171 begin
172 return Create_Auxiliary_File (Src, "dg");
173 end Create_Debug_File;
175 ----------------------
176 -- Create_List_File --
177 ----------------------
179 procedure Create_List_File (S : String) is
180 F : File_Name_Type;
181 pragma Warnings (Off, F);
182 begin
183 if S (S'First) = '.' then
184 F := Create_Auxiliary_File (Current_Main, S (S'First + 1 .. S'Last));
186 else
187 Name_Buffer (1 .. S'Length) := S;
188 Name_Len := S'Length + 1;
189 Name_Buffer (Name_Len) := ASCII.NUL;
190 Create_File_And_Check (Output_FD, Text);
191 end if;
192 end Create_List_File;
194 --------------------------------
195 -- Create_Output_Library_Info --
196 --------------------------------
198 procedure Create_Output_Library_Info is
199 Dummy : Boolean;
200 pragma Unreferenced (Dummy);
202 begin
203 Set_Library_Info_Name;
204 Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
205 Create_File_And_Check (Output_FD, Text);
206 end Create_Output_Library_Info;
208 -------------------------
209 -- Create_Repinfo_File --
210 -------------------------
212 procedure Create_Repinfo_File (Src : String) is
213 Discard : File_Name_Type;
214 pragma Warnings (Off, Discard);
215 begin
216 Name_Buffer (1 .. Src'Length) := Src;
217 Name_Len := Src'Length;
218 Discard := Create_Auxiliary_File (Name_Find, "rep");
219 return;
220 end Create_Repinfo_File;
222 ---------------------------
223 -- Debug_File_Eol_Length --
224 ---------------------------
226 function Debug_File_Eol_Length return Nat is
227 begin
228 -- There has to be a cleaner way to do this! ???
230 if Directory_Separator = '/' then
231 return 1;
232 else
233 return 2;
234 end if;
235 end Debug_File_Eol_Length;
237 ---------------------------------
238 -- Get_Output_Object_File_Name --
239 ---------------------------------
241 function Get_Output_Object_File_Name return String is
242 begin
243 pragma Assert (Output_Object_File_Name /= null);
245 return Output_Object_File_Name.all;
246 end Get_Output_Object_File_Name;
248 -----------------------
249 -- More_Source_Files --
250 -----------------------
252 function More_Source_Files return Boolean renames More_Files;
254 ----------------------
255 -- Next_Main_Source --
256 ----------------------
258 function Next_Main_Source return File_Name_Type renames Next_Main_File;
260 -----------------------
261 -- Read_Library_Info --
262 -----------------------
264 -- Version with default file name
266 procedure Read_Library_Info
267 (Name : out File_Name_Type;
268 Text : out Text_Buffer_Ptr)
270 begin
271 Set_Library_Info_Name;
272 Name := Name_Find;
273 Text := Read_Library_Info (Name, Fatal_Err => False);
274 end Read_Library_Info;
276 ---------------------------
277 -- Set_Library_Info_Name --
278 ---------------------------
280 procedure Set_Library_Info_Name is
281 Dot_Index : Natural;
283 begin
284 Get_Name_String (Current_Main);
286 -- Find last dot since we replace the existing extension by .ali. The
287 -- initialization to Name_Len + 1 provides for simply adding the .ali
288 -- extension if the source file name has no extension.
290 Dot_Index := Name_Len + 1;
292 for J in reverse 1 .. Name_Len loop
293 if Name_Buffer (J) = '.' then
294 Dot_Index := J;
295 exit;
296 end if;
297 end loop;
299 -- Make sure that the output file name matches the source file name.
300 -- To compare them, remove file name directories and extensions.
302 if Output_Object_File_Name /= null then
304 -- Make sure there is a dot at Dot_Index. This may not be the case
305 -- if the source file name has no extension.
307 Name_Buffer (Dot_Index) := '.';
309 -- If we are in multiple unit per file mode, then add ~nnn
310 -- extension to the name before doing the comparison.
312 if Multiple_Unit_Index /= 0 then
313 declare
314 Exten : constant String := Name_Buffer (Dot_Index .. Name_Len);
315 begin
316 Name_Len := Dot_Index - 1;
317 Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
318 Add_Nat_To_Name_Buffer (Multiple_Unit_Index);
319 Dot_Index := Name_Len + 1;
320 Add_Str_To_Name_Buffer (Exten);
321 end;
322 end if;
324 -- Remove extension preparing to replace it
326 declare
327 Name : String := Name_Buffer (1 .. Dot_Index);
328 First : Positive;
330 begin
331 Name_Buffer (1 .. Output_Object_File_Name'Length) :=
332 Output_Object_File_Name.all;
334 -- Put two names in canonical case, to allow object file names
335 -- with upper-case letters on Windows.
337 Canonical_Case_File_Name (Name);
338 Canonical_Case_File_Name
339 (Name_Buffer (1 .. Output_Object_File_Name'Length));
341 Dot_Index := 0;
342 for J in reverse Output_Object_File_Name'Range loop
343 if Name_Buffer (J) = '.' then
344 Dot_Index := J;
345 exit;
346 end if;
347 end loop;
349 -- Dot_Index should not be zero now (we check for extension
350 -- elsewhere).
352 pragma Assert (Dot_Index /= 0);
354 -- Look for first character of file name
356 First := Dot_Index;
357 while First > 1
358 and then Name_Buffer (First - 1) /= Directory_Separator
359 and then Name_Buffer (First - 1) /= '/'
360 loop
361 First := First - 1;
362 end loop;
364 -- Check name of object file is what we expect
366 if Name /= Name_Buffer (First .. Dot_Index) then
367 Fail ("incorrect object file name");
368 end if;
369 end;
370 end if;
372 Name_Buffer (Dot_Index) := '.';
373 Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all;
374 Name_Buffer (Dot_Index + 4) := ASCII.NUL;
375 Name_Len := Dot_Index + 3;
376 end Set_Library_Info_Name;
378 ---------------------------------
379 -- Set_Output_Object_File_Name --
380 ---------------------------------
382 procedure Set_Output_Object_File_Name (Name : String) is
383 Ext : constant String := Target_Object_Suffix;
384 NL : constant Natural := Name'Length;
385 EL : constant Natural := Ext'Length;
387 begin
388 -- Make sure that the object file has the expected extension
390 if NL <= EL
391 or else
392 (Name (NL - EL + Name'First .. Name'Last) /= Ext
393 and then Name (NL - 2 + Name'First .. Name'Last) /= ".o")
394 then
395 Fail ("incorrect object file extension");
396 end if;
398 Output_Object_File_Name := new String'(Name);
399 end Set_Output_Object_File_Name;
401 ----------------
402 -- Tree_Close --
403 ----------------
405 procedure Tree_Close is
406 Status : Boolean;
407 begin
408 Tree_Write_Terminate;
409 Close (Output_FD, Status);
411 if not Status then
412 Fail
413 ("error while closing tree file "
414 & Get_Name_String (Output_File_Name));
415 end if;
416 end Tree_Close;
418 -----------------
419 -- Tree_Create --
420 -----------------
422 procedure Tree_Create is
423 Dot_Index : Natural;
425 begin
426 Get_Name_String (Current_Main);
428 -- If an object file has been specified, then the ALI file
429 -- will be in the same directory as the object file;
430 -- so, we put the tree file in this same directory,
431 -- even though no object file needs to be generated.
433 if Output_Object_File_Name /= null then
434 Name_Len := Output_Object_File_Name'Length;
435 Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
436 end if;
438 Dot_Index := Name_Len + 1;
440 for J in reverse 1 .. Name_Len loop
441 if Name_Buffer (J) = '.' then
442 Dot_Index := J;
443 exit;
444 end if;
445 end loop;
447 -- Should be impossible to not have an extension
449 pragma Assert (Dot_Index /= 0);
451 -- Change extension to adt
453 Name_Buffer (Dot_Index) := '.';
454 Name_Buffer (Dot_Index + 1) := 'a';
455 Name_Buffer (Dot_Index + 2) := 'd';
456 Name_Buffer (Dot_Index + 3) := 't';
457 Name_Buffer (Dot_Index + 4) := ASCII.NUL;
458 Name_Len := Dot_Index + 3;
459 Create_File_And_Check (Output_FD, Binary);
461 Tree_Write_Initialize (Output_FD);
462 end Tree_Create;
464 -----------------------
465 -- Write_Debug_Info --
466 -----------------------
468 procedure Write_Debug_Info (Info : String) renames Write_Info;
470 ------------------------
471 -- Write_Library_Info --
472 ------------------------
474 procedure Write_Library_Info (Info : String) renames Write_Info;
476 ---------------------
477 -- Write_List_Info --
478 ---------------------
480 procedure Write_List_Info (S : String) is
481 begin
482 Write_With_Check (S'Address, S'Length);
483 end Write_List_Info;
485 ------------------------
486 -- Write_Repinfo_Line --
487 ------------------------
489 procedure Write_Repinfo_Line (Info : String) renames Write_Info;
491 begin
492 Adjust_OS_Resource_Limits;
494 Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access;
495 Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
496 Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
498 Opt.Create_List_File_Access := Create_List_File'Access;
499 Opt.Write_List_Info_Access := Write_List_Info'Access;
500 Opt.Close_List_File_Access := Close_List_File'Access;
502 Set_Program (Compiler);
503 end Osint.C;