111
|
1 ------------------------------------------------------------------------------
|
|
2 -- --
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
4 -- --
|
|
5 -- O S I N T - C --
|
|
6 -- --
|
|
7 -- B o d y --
|
|
8 -- --
|
131
|
9 -- Copyright (C) 2001-2018, Free Software Foundation, Inc. --
|
111
|
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;
|
131
|
276 if List_Representation_Info_To_JSON then
|
|
277 Discard := Create_Auxiliary_File (Name_Find, "json");
|
|
278 else
|
|
279 Discard := Create_Auxiliary_File (Name_Find, "rep");
|
|
280 end if;
|
111
|
281 end Create_Repinfo_File;
|
|
282
|
|
283 ---------------------------
|
|
284 -- Debug_File_Eol_Length --
|
|
285 ---------------------------
|
|
286
|
|
287 function Debug_File_Eol_Length return Nat is
|
|
288 begin
|
|
289 -- There has to be a cleaner way to do this ???
|
|
290
|
|
291 if Directory_Separator = '/' then
|
|
292 return 1;
|
|
293 else
|
|
294 return 2;
|
|
295 end if;
|
|
296 end Debug_File_Eol_Length;
|
|
297
|
|
298 -------------------
|
|
299 -- Delete_C_File --
|
|
300 -------------------
|
|
301
|
|
302 procedure Delete_C_File is
|
|
303 Dummy : Boolean;
|
|
304 begin
|
|
305 Set_File_Name ("c");
|
|
306 Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
|
|
307 end Delete_C_File;
|
|
308
|
|
309 -------------------
|
|
310 -- Delete_H_File --
|
|
311 -------------------
|
|
312
|
|
313 procedure Delete_H_File is
|
|
314 Dummy : Boolean;
|
|
315 begin
|
|
316 Set_File_Name ("h");
|
|
317 Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
|
|
318 end Delete_H_File;
|
|
319
|
|
320 ---------------------------------
|
|
321 -- Get_Output_Object_File_Name --
|
|
322 ---------------------------------
|
|
323
|
|
324 function Get_Output_Object_File_Name return String is
|
|
325 begin
|
|
326 pragma Assert (Output_Object_File_Name /= null);
|
|
327
|
|
328 return Output_Object_File_Name.all;
|
|
329 end Get_Output_Object_File_Name;
|
|
330
|
|
331 -----------------------
|
|
332 -- More_Source_Files --
|
|
333 -----------------------
|
|
334
|
|
335 function More_Source_Files return Boolean renames More_Files;
|
|
336
|
|
337 ----------------------
|
|
338 -- Next_Main_Source --
|
|
339 ----------------------
|
|
340
|
|
341 function Next_Main_Source return File_Name_Type renames Next_Main_File;
|
|
342
|
|
343 -----------------------
|
|
344 -- Read_Library_Info --
|
|
345 -----------------------
|
|
346
|
|
347 procedure Read_Library_Info
|
|
348 (Name : out File_Name_Type;
|
|
349 Text : out Text_Buffer_Ptr)
|
|
350 is
|
|
351 begin
|
|
352 Set_File_Name (ALI_Suffix.all);
|
|
353
|
|
354 -- Remove trailing NUL that comes from Set_File_Name above. This is
|
|
355 -- needed for consistency with names that come from Scan_ALI and thus
|
|
356 -- preventing repeated scanning of the same file.
|
|
357
|
|
358 pragma Assert (Name_Len > 1 and then Name_Buffer (Name_Len) = ASCII.NUL);
|
|
359 Name_Len := Name_Len - 1;
|
|
360
|
|
361 Name := Name_Find;
|
|
362 Text := Read_Library_Info (Name, Fatal_Err => False);
|
|
363 end Read_Library_Info;
|
|
364
|
|
365 -------------------
|
|
366 -- Set_File_Name --
|
|
367 -------------------
|
|
368
|
|
369 procedure Set_File_Name (Ext : String) is
|
|
370 Dot_Index : Natural;
|
|
371
|
|
372 begin
|
|
373 Get_Name_String (Current_Main);
|
|
374
|
|
375 -- Find last dot since we replace the existing extension by .ali. The
|
|
376 -- initialization to Name_Len + 1 provides for simply adding the .ali
|
|
377 -- extension if the source file name has no extension.
|
|
378
|
|
379 Dot_Index := Name_Len + 1;
|
|
380
|
|
381 for J in reverse 1 .. Name_Len loop
|
|
382 if Name_Buffer (J) = '.' then
|
|
383 Dot_Index := J;
|
|
384 exit;
|
|
385 end if;
|
|
386 end loop;
|
|
387
|
|
388 -- Make sure that the output file name matches the source file name.
|
|
389 -- To compare them, remove file name directories and extensions.
|
|
390
|
|
391 if Output_Object_File_Name /= null then
|
|
392
|
|
393 -- Make sure there is a dot at Dot_Index. This may not be the case
|
|
394 -- if the source file name has no extension.
|
|
395
|
|
396 Name_Buffer (Dot_Index) := '.';
|
|
397
|
|
398 -- If we are in multiple unit per file mode, then add ~nnn
|
|
399 -- extension to the name before doing the comparison.
|
|
400
|
|
401 if Multiple_Unit_Index /= 0 then
|
|
402 declare
|
|
403 Exten : constant String := Name_Buffer (Dot_Index .. Name_Len);
|
|
404 begin
|
|
405 Name_Len := Dot_Index - 1;
|
|
406 Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
|
|
407 Add_Nat_To_Name_Buffer (Multiple_Unit_Index);
|
|
408 Dot_Index := Name_Len + 1;
|
|
409 Add_Str_To_Name_Buffer (Exten);
|
|
410 end;
|
|
411 end if;
|
|
412
|
|
413 -- Remove extension preparing to replace it
|
|
414
|
|
415 declare
|
|
416 Name : String := Name_Buffer (1 .. Dot_Index);
|
|
417 First : Positive;
|
|
418
|
|
419 begin
|
|
420 Name_Buffer (1 .. Output_Object_File_Name'Length) :=
|
|
421 Output_Object_File_Name.all;
|
|
422
|
|
423 -- Put two names in canonical case, to allow object file names
|
|
424 -- with upper-case letters on Windows.
|
|
425
|
|
426 Canonical_Case_File_Name (Name);
|
|
427 Canonical_Case_File_Name
|
|
428 (Name_Buffer (1 .. Output_Object_File_Name'Length));
|
|
429
|
|
430 Dot_Index := 0;
|
|
431 for J in reverse Output_Object_File_Name'Range loop
|
|
432 if Name_Buffer (J) = '.' then
|
|
433 Dot_Index := J;
|
|
434 exit;
|
|
435 end if;
|
|
436 end loop;
|
|
437
|
|
438 -- Dot_Index should not be zero now (we check for extension
|
|
439 -- elsewhere).
|
|
440
|
|
441 pragma Assert (Dot_Index /= 0);
|
|
442
|
|
443 -- Look for first character of file name
|
|
444
|
|
445 First := Dot_Index;
|
|
446 while First > 1
|
|
447 and then Name_Buffer (First - 1) /= Directory_Separator
|
|
448 and then Name_Buffer (First - 1) /= '/'
|
|
449 loop
|
|
450 First := First - 1;
|
|
451 end loop;
|
|
452
|
|
453 -- Check name of object file is what we expect
|
|
454
|
|
455 if Name /= Name_Buffer (First .. Dot_Index) then
|
|
456 Fail ("incorrect object file name");
|
|
457 end if;
|
|
458 end;
|
|
459 end if;
|
|
460
|
|
461 Name_Buffer (Dot_Index) := '.';
|
|
462 Name_Buffer (Dot_Index + 1 .. Dot_Index + Ext'Length) := Ext;
|
|
463 Name_Buffer (Dot_Index + Ext'Length + 1) := ASCII.NUL;
|
|
464 Name_Len := Dot_Index + Ext'Length + 1;
|
|
465 end Set_File_Name;
|
|
466
|
|
467 ---------------------------------
|
|
468 -- Set_Output_Object_File_Name --
|
|
469 ---------------------------------
|
|
470
|
|
471 procedure Set_Output_Object_File_Name (Name : String) is
|
|
472 Ext : constant String := Target_Object_Suffix;
|
|
473 NL : constant Natural := Name'Length;
|
|
474 EL : constant Natural := Ext'Length;
|
|
475
|
|
476 begin
|
|
477 -- Make sure that the object file has the expected extension
|
|
478
|
|
479 if NL <= EL
|
|
480 or else
|
|
481 (Name (NL - EL + Name'First .. Name'Last) /= Ext
|
|
482 and then Name (NL - 2 + Name'First .. Name'Last) /= ".o"
|
|
483 and then
|
|
484 (not Generate_C_Code
|
|
485 or else Name (NL - 2 + Name'First .. Name'Last) /= ".c"))
|
|
486 then
|
|
487 Fail ("incorrect object file extension");
|
|
488 end if;
|
|
489
|
|
490 Output_Object_File_Name := new String'(Name);
|
|
491 end Set_Output_Object_File_Name;
|
|
492
|
|
493 ----------------
|
|
494 -- Tree_Close --
|
|
495 ----------------
|
|
496
|
|
497 procedure Tree_Close is
|
|
498 Status : Boolean;
|
|
499 begin
|
|
500 Tree_Write_Terminate;
|
|
501 Close (Output_FD, Status);
|
|
502
|
|
503 if not Status then
|
|
504 Fail
|
|
505 ("error while closing tree file "
|
|
506 & Get_Name_String (Output_File_Name));
|
|
507 end if;
|
|
508 end Tree_Close;
|
|
509
|
|
510 -----------------
|
|
511 -- Tree_Create --
|
|
512 -----------------
|
|
513
|
|
514 procedure Tree_Create is
|
|
515 Dot_Index : Natural;
|
|
516
|
|
517 begin
|
|
518 Get_Name_String (Current_Main);
|
|
519
|
|
520 -- If an object file has been specified, then the ALI file
|
|
521 -- will be in the same directory as the object file;
|
|
522 -- so, we put the tree file in this same directory,
|
|
523 -- even though no object file needs to be generated.
|
|
524
|
|
525 if Output_Object_File_Name /= null then
|
|
526 Name_Len := Output_Object_File_Name'Length;
|
|
527 Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
|
|
528 end if;
|
|
529
|
|
530 Dot_Index := Name_Len + 1;
|
|
531
|
|
532 for J in reverse 1 .. Name_Len loop
|
|
533 if Name_Buffer (J) = '.' then
|
|
534 Dot_Index := J;
|
|
535 exit;
|
|
536 end if;
|
|
537 end loop;
|
|
538
|
|
539 -- Should be impossible to not have an extension
|
|
540
|
|
541 pragma Assert (Dot_Index /= 0);
|
|
542
|
|
543 -- Change extension to adt
|
|
544
|
|
545 Name_Buffer (Dot_Index) := '.';
|
|
546 Name_Buffer (Dot_Index + 1) := 'a';
|
|
547 Name_Buffer (Dot_Index + 2) := 'd';
|
|
548 Name_Buffer (Dot_Index + 3) := 't';
|
|
549 Name_Buffer (Dot_Index + 4) := ASCII.NUL;
|
|
550 Name_Len := Dot_Index + 3;
|
|
551 Create_File_And_Check (Output_FD, Binary);
|
|
552
|
|
553 Tree_Write_Initialize (Output_FD);
|
|
554 end Tree_Create;
|
|
555
|
|
556 -----------------------
|
|
557 -- Write_Debug_Info --
|
|
558 -----------------------
|
|
559
|
|
560 procedure Write_Debug_Info (Info : String) renames Write_Info;
|
|
561
|
|
562 ------------------------
|
|
563 -- Write_Library_Info --
|
|
564 ------------------------
|
|
565
|
|
566 procedure Write_Library_Info (Info : String) renames Write_Info;
|
|
567
|
|
568 ---------------------
|
|
569 -- Write_List_Info --
|
|
570 ---------------------
|
|
571
|
|
572 procedure Write_List_Info (S : String) is
|
|
573 begin
|
|
574 Write_With_Check (S'Address, S'Length);
|
|
575 end Write_List_Info;
|
|
576
|
|
577 ------------------------
|
|
578 -- Write_Repinfo_Line --
|
|
579 ------------------------
|
|
580
|
|
581 procedure Write_Repinfo_Line (Info : String) renames Write_Info;
|
|
582
|
|
583 begin
|
|
584 Adjust_OS_Resource_Limits;
|
|
585
|
|
586 Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access;
|
|
587 Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
|
|
588 Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
|
|
589
|
|
590 Opt.Create_List_File_Access := Create_List_File'Access;
|
|
591 Opt.Write_List_Info_Access := Write_List_Info'Access;
|
|
592 Opt.Close_List_File_Access := Close_List_File'Access;
|
|
593
|
|
594 Set_Program (Compiler);
|
|
595 end Osint.C;
|