Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/osint-c.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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-2016, 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 ------------------------------------------------------------------------------
25
26 with Opt; use Opt;
27 with Tree_IO; use Tree_IO;
28
29 package body Osint.C is
30
31 Output_Object_File_Name : String_Ptr;
32 -- Argument of -o compiler option, if given. This is needed to verify
33 -- consistency with the ALI file name.
34
35 procedure Adjust_OS_Resource_Limits;
36 pragma Import (C, Adjust_OS_Resource_Limits,
37 "__gnat_adjust_os_resource_limits");
38 -- Procedure to make system specific adjustments to make GNAT run better
39
40 function Create_Auxiliary_File
41 (Src : File_Name_Type;
42 Suffix : String) return File_Name_Type;
43 -- Common processing for Create_List_File, Create_Repinfo_File and
44 -- Create_Debug_File. Src is the file name used to create the required
45 -- output file and Suffix is the desired suffix (dg/rep/xxx for debug/
46 -- repinfo/list file where xxx is specified extension.
47
48 ------------------
49 -- Close_C_File --
50 ------------------
51
52 procedure Close_C_File is
53 Status : Boolean;
54
55 begin
56 Close (Output_FD, Status);
57
58 if not Status then
59 Fail
60 ("error while closing file "
61 & Get_Name_String (Output_File_Name));
62 end if;
63 end Close_C_File;
64
65 ----------------------
66 -- Close_Debug_File --
67 ----------------------
68
69 procedure Close_Debug_File is
70 Status : Boolean;
71
72 begin
73 Close (Output_FD, Status);
74
75 if not Status then
76 Fail
77 ("error while closing expanded source file "
78 & Get_Name_String (Output_File_Name));
79 end if;
80 end Close_Debug_File;
81
82 ------------------
83 -- Close_H_File --
84 ------------------
85
86 procedure Close_H_File is
87 Status : Boolean;
88
89 begin
90 Close (Output_FD, Status);
91
92 if not Status then
93 Fail
94 ("error while closing file "
95 & Get_Name_String (Output_File_Name));
96 end if;
97 end Close_H_File;
98
99 ---------------------
100 -- Close_List_File --
101 ---------------------
102
103 procedure Close_List_File is
104 Status : Boolean;
105
106 begin
107 Close (Output_FD, Status);
108
109 if not Status then
110 Fail
111 ("error while closing list file "
112 & Get_Name_String (Output_File_Name));
113 end if;
114 end Close_List_File;
115
116 -------------------------------
117 -- Close_Output_Library_Info --
118 -------------------------------
119
120 procedure Close_Output_Library_Info is
121 Status : Boolean;
122
123 begin
124 Close (Output_FD, Status);
125
126 if not Status then
127 Fail
128 ("error while closing ALI file "
129 & Get_Name_String (Output_File_Name));
130 end if;
131 end Close_Output_Library_Info;
132
133 ------------------------
134 -- Close_Repinfo_File --
135 ------------------------
136
137 procedure Close_Repinfo_File is
138 Status : Boolean;
139
140 begin
141 Close (Output_FD, Status);
142
143 if not Status then
144 Fail
145 ("error while closing representation info file "
146 & Get_Name_String (Output_File_Name));
147 end if;
148 end Close_Repinfo_File;
149
150 ---------------------------
151 -- Create_Auxiliary_File --
152 ---------------------------
153
154 function Create_Auxiliary_File
155 (Src : File_Name_Type;
156 Suffix : String) return File_Name_Type
157 is
158 Result : File_Name_Type;
159
160 begin
161 Get_Name_String (Src);
162
163 Name_Buffer (Name_Len + 1) := '.';
164 Name_Len := Name_Len + 1;
165 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
166 Name_Len := Name_Len + Suffix'Length;
167
168 if Output_Object_File_Name /= null then
169 for Index in reverse Output_Object_File_Name'Range loop
170 if Output_Object_File_Name (Index) = Directory_Separator then
171 declare
172 File_Name : constant String := Name_Buffer (1 .. Name_Len);
173 begin
174 Name_Len := Index - Output_Object_File_Name'First + 1;
175 Name_Buffer (1 .. Name_Len) :=
176 Output_Object_File_Name
177 (Output_Object_File_Name'First .. Index);
178 Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) :=
179 File_Name;
180 Name_Len := Name_Len + File_Name'Length;
181 end;
182
183 exit;
184 end if;
185 end loop;
186 end if;
187
188 Result := Name_Find;
189 Name_Buffer (Name_Len + 1) := ASCII.NUL;
190 Create_File_And_Check (Output_FD, Text);
191 return Result;
192 end Create_Auxiliary_File;
193
194 -------------------
195 -- Create_C_File --
196 -------------------
197
198 procedure Create_C_File is
199 Dummy : Boolean;
200 begin
201 Set_File_Name ("c");
202 Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
203 Create_File_And_Check (Output_FD, Text);
204 end Create_C_File;
205
206 -----------------------
207 -- Create_Debug_File --
208 -----------------------
209
210 function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is
211 begin
212 return Create_Auxiliary_File (Src, "dg");
213 end Create_Debug_File;
214
215 -------------------
216 -- Create_H_File --
217 -------------------
218
219 procedure Create_H_File is
220 Dummy : Boolean;
221 begin
222 Set_File_Name ("h");
223 Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
224 Create_File_And_Check (Output_FD, Text);
225 end Create_H_File;
226
227 ----------------------
228 -- Create_List_File --
229 ----------------------
230
231 procedure Create_List_File (S : String) is
232 Dummy : File_Name_Type;
233 begin
234 if S (S'First) = '.' then
235 Dummy :=
236 Create_Auxiliary_File (Current_Main, S (S'First + 1 .. S'Last));
237 else
238 Name_Buffer (1 .. S'Length) := S;
239 Name_Len := S'Length + 1;
240 Name_Buffer (Name_Len) := ASCII.NUL;
241 Create_File_And_Check (Output_FD, Text);
242 end if;
243 end Create_List_File;
244
245 --------------------------------
246 -- Create_Output_Library_Info --
247 --------------------------------
248
249 procedure Create_Output_Library_Info is
250 Dummy : Boolean;
251 begin
252 Set_File_Name (ALI_Suffix.all);
253 Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
254 Create_File_And_Check (Output_FD, Text);
255 end Create_Output_Library_Info;
256
257 ------------------------------
258 -- Open_Output_Library_Info --
259 ------------------------------
260
261 procedure Open_Output_Library_Info is
262 begin
263 Set_File_Name (ALI_Suffix.all);
264 Open_File_To_Append_And_Check (Output_FD, Text);
265 end Open_Output_Library_Info;
266
267 -------------------------
268 -- Create_Repinfo_File --
269 -------------------------
270
271 procedure Create_Repinfo_File (Src : String) is
272 Discard : File_Name_Type;
273 begin
274 Name_Buffer (1 .. Src'Length) := Src;
275 Name_Len := Src'Length;
276 Discard := Create_Auxiliary_File (Name_Find, "rep");
277 return;
278 end Create_Repinfo_File;
279
280 ---------------------------
281 -- Debug_File_Eol_Length --
282 ---------------------------
283
284 function Debug_File_Eol_Length return Nat is
285 begin
286 -- There has to be a cleaner way to do this ???
287
288 if Directory_Separator = '/' then
289 return 1;
290 else
291 return 2;
292 end if;
293 end Debug_File_Eol_Length;
294
295 -------------------
296 -- Delete_C_File --
297 -------------------
298
299 procedure Delete_C_File is
300 Dummy : Boolean;
301 begin
302 Set_File_Name ("c");
303 Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
304 end Delete_C_File;
305
306 -------------------
307 -- Delete_H_File --
308 -------------------
309
310 procedure Delete_H_File is
311 Dummy : Boolean;
312 begin
313 Set_File_Name ("h");
314 Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
315 end Delete_H_File;
316
317 ---------------------------------
318 -- Get_Output_Object_File_Name --
319 ---------------------------------
320
321 function Get_Output_Object_File_Name return String is
322 begin
323 pragma Assert (Output_Object_File_Name /= null);
324
325 return Output_Object_File_Name.all;
326 end Get_Output_Object_File_Name;
327
328 -----------------------
329 -- More_Source_Files --
330 -----------------------
331
332 function More_Source_Files return Boolean renames More_Files;
333
334 ----------------------
335 -- Next_Main_Source --
336 ----------------------
337
338 function Next_Main_Source return File_Name_Type renames Next_Main_File;
339
340 -----------------------
341 -- Read_Library_Info --
342 -----------------------
343
344 procedure Read_Library_Info
345 (Name : out File_Name_Type;
346 Text : out Text_Buffer_Ptr)
347 is
348 begin
349 Set_File_Name (ALI_Suffix.all);
350
351 -- Remove trailing NUL that comes from Set_File_Name above. This is
352 -- needed for consistency with names that come from Scan_ALI and thus
353 -- preventing repeated scanning of the same file.
354
355 pragma Assert (Name_Len > 1 and then Name_Buffer (Name_Len) = ASCII.NUL);
356 Name_Len := Name_Len - 1;
357
358 Name := Name_Find;
359 Text := Read_Library_Info (Name, Fatal_Err => False);
360 end Read_Library_Info;
361
362 -------------------
363 -- Set_File_Name --
364 -------------------
365
366 procedure Set_File_Name (Ext : String) is
367 Dot_Index : Natural;
368
369 begin
370 Get_Name_String (Current_Main);
371
372 -- Find last dot since we replace the existing extension by .ali. The
373 -- initialization to Name_Len + 1 provides for simply adding the .ali
374 -- extension if the source file name has no extension.
375
376 Dot_Index := Name_Len + 1;
377
378 for J in reverse 1 .. Name_Len loop
379 if Name_Buffer (J) = '.' then
380 Dot_Index := J;
381 exit;
382 end if;
383 end loop;
384
385 -- Make sure that the output file name matches the source file name.
386 -- To compare them, remove file name directories and extensions.
387
388 if Output_Object_File_Name /= null then
389
390 -- Make sure there is a dot at Dot_Index. This may not be the case
391 -- if the source file name has no extension.
392
393 Name_Buffer (Dot_Index) := '.';
394
395 -- If we are in multiple unit per file mode, then add ~nnn
396 -- extension to the name before doing the comparison.
397
398 if Multiple_Unit_Index /= 0 then
399 declare
400 Exten : constant String := Name_Buffer (Dot_Index .. Name_Len);
401 begin
402 Name_Len := Dot_Index - 1;
403 Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
404 Add_Nat_To_Name_Buffer (Multiple_Unit_Index);
405 Dot_Index := Name_Len + 1;
406 Add_Str_To_Name_Buffer (Exten);
407 end;
408 end if;
409
410 -- Remove extension preparing to replace it
411
412 declare
413 Name : String := Name_Buffer (1 .. Dot_Index);
414 First : Positive;
415
416 begin
417 Name_Buffer (1 .. Output_Object_File_Name'Length) :=
418 Output_Object_File_Name.all;
419
420 -- Put two names in canonical case, to allow object file names
421 -- with upper-case letters on Windows.
422
423 Canonical_Case_File_Name (Name);
424 Canonical_Case_File_Name
425 (Name_Buffer (1 .. Output_Object_File_Name'Length));
426
427 Dot_Index := 0;
428 for J in reverse Output_Object_File_Name'Range loop
429 if Name_Buffer (J) = '.' then
430 Dot_Index := J;
431 exit;
432 end if;
433 end loop;
434
435 -- Dot_Index should not be zero now (we check for extension
436 -- elsewhere).
437
438 pragma Assert (Dot_Index /= 0);
439
440 -- Look for first character of file name
441
442 First := Dot_Index;
443 while First > 1
444 and then Name_Buffer (First - 1) /= Directory_Separator
445 and then Name_Buffer (First - 1) /= '/'
446 loop
447 First := First - 1;
448 end loop;
449
450 -- Check name of object file is what we expect
451
452 if Name /= Name_Buffer (First .. Dot_Index) then
453 Fail ("incorrect object file name");
454 end if;
455 end;
456 end if;
457
458 Name_Buffer (Dot_Index) := '.';
459 Name_Buffer (Dot_Index + 1 .. Dot_Index + Ext'Length) := Ext;
460 Name_Buffer (Dot_Index + Ext'Length + 1) := ASCII.NUL;
461 Name_Len := Dot_Index + Ext'Length + 1;
462 end Set_File_Name;
463
464 ---------------------------------
465 -- Set_Output_Object_File_Name --
466 ---------------------------------
467
468 procedure Set_Output_Object_File_Name (Name : String) is
469 Ext : constant String := Target_Object_Suffix;
470 NL : constant Natural := Name'Length;
471 EL : constant Natural := Ext'Length;
472
473 begin
474 -- Make sure that the object file has the expected extension
475
476 if NL <= EL
477 or else
478 (Name (NL - EL + Name'First .. Name'Last) /= Ext
479 and then Name (NL - 2 + Name'First .. Name'Last) /= ".o"
480 and then
481 (not Generate_C_Code
482 or else Name (NL - 2 + Name'First .. Name'Last) /= ".c"))
483 then
484 Fail ("incorrect object file extension");
485 end if;
486
487 Output_Object_File_Name := new String'(Name);
488 end Set_Output_Object_File_Name;
489
490 ----------------
491 -- Tree_Close --
492 ----------------
493
494 procedure Tree_Close is
495 Status : Boolean;
496 begin
497 Tree_Write_Terminate;
498 Close (Output_FD, Status);
499
500 if not Status then
501 Fail
502 ("error while closing tree file "
503 & Get_Name_String (Output_File_Name));
504 end if;
505 end Tree_Close;
506
507 -----------------
508 -- Tree_Create --
509 -----------------
510
511 procedure Tree_Create is
512 Dot_Index : Natural;
513
514 begin
515 Get_Name_String (Current_Main);
516
517 -- If an object file has been specified, then the ALI file
518 -- will be in the same directory as the object file;
519 -- so, we put the tree file in this same directory,
520 -- even though no object file needs to be generated.
521
522 if Output_Object_File_Name /= null then
523 Name_Len := Output_Object_File_Name'Length;
524 Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
525 end if;
526
527 Dot_Index := Name_Len + 1;
528
529 for J in reverse 1 .. Name_Len loop
530 if Name_Buffer (J) = '.' then
531 Dot_Index := J;
532 exit;
533 end if;
534 end loop;
535
536 -- Should be impossible to not have an extension
537
538 pragma Assert (Dot_Index /= 0);
539
540 -- Change extension to adt
541
542 Name_Buffer (Dot_Index) := '.';
543 Name_Buffer (Dot_Index + 1) := 'a';
544 Name_Buffer (Dot_Index + 2) := 'd';
545 Name_Buffer (Dot_Index + 3) := 't';
546 Name_Buffer (Dot_Index + 4) := ASCII.NUL;
547 Name_Len := Dot_Index + 3;
548 Create_File_And_Check (Output_FD, Binary);
549
550 Tree_Write_Initialize (Output_FD);
551 end Tree_Create;
552
553 -----------------------
554 -- Write_Debug_Info --
555 -----------------------
556
557 procedure Write_Debug_Info (Info : String) renames Write_Info;
558
559 ------------------------
560 -- Write_Library_Info --
561 ------------------------
562
563 procedure Write_Library_Info (Info : String) renames Write_Info;
564
565 ---------------------
566 -- Write_List_Info --
567 ---------------------
568
569 procedure Write_List_Info (S : String) is
570 begin
571 Write_With_Check (S'Address, S'Length);
572 end Write_List_Info;
573
574 ------------------------
575 -- Write_Repinfo_Line --
576 ------------------------
577
578 procedure Write_Repinfo_Line (Info : String) renames Write_Info;
579
580 begin
581 Adjust_OS_Resource_Limits;
582
583 Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access;
584 Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
585 Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
586
587 Opt.Create_List_File_Access := Create_List_File'Access;
588 Opt.Write_List_Info_Access := Write_List_Info'Access;
589 Opt.Close_List_File_Access := Close_List_File'Access;
590
591 Set_Program (Compiler);
592 end Osint.C;