1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2018, 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 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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
27 with Tree_IO
; use Tree_IO
;
29 package body Osint
.C
is
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.
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
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.
52 procedure Close_C_File
is
56 Close
(Output_FD
, Status
);
60 ("error while closing file "
61 & Get_Name_String
(Output_File_Name
));
65 ----------------------
66 -- Close_Debug_File --
67 ----------------------
69 procedure Close_Debug_File
is
73 Close
(Output_FD
, Status
);
77 ("error while closing expanded source file "
78 & Get_Name_String
(Output_File_Name
));
86 procedure Close_H_File
is
90 Close
(Output_FD
, Status
);
94 ("error while closing file "
95 & Get_Name_String
(Output_File_Name
));
100 -- Close_List_File --
101 ---------------------
103 procedure Close_List_File
is
107 Close
(Output_FD
, Status
);
111 ("error while closing list file "
112 & Get_Name_String
(Output_File_Name
));
116 -------------------------------
117 -- Close_Output_Library_Info --
118 -------------------------------
120 procedure Close_Output_Library_Info
is
124 Close
(Output_FD
, Status
);
128 ("error while closing ALI file "
129 & Get_Name_String
(Output_File_Name
));
131 end Close_Output_Library_Info
;
133 ------------------------
134 -- Close_Repinfo_File --
135 ------------------------
137 procedure Close_Repinfo_File
is
141 Close
(Output_FD
, Status
);
145 ("error while closing representation info file "
146 & Get_Name_String
(Output_File_Name
));
148 end Close_Repinfo_File
;
150 ---------------------------
151 -- Create_Auxiliary_File --
152 ---------------------------
154 function Create_Auxiliary_File
155 (Src
: File_Name_Type
;
156 Suffix
: String) return File_Name_Type
158 Result
: File_Name_Type
;
161 Get_Name_String
(Src
);
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;
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
172 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
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) :=
180 Name_Len
:= Name_Len
+ File_Name
'Length;
189 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
190 Create_File_And_Check
(Output_FD
, Text
);
192 end Create_Auxiliary_File
;
198 procedure Create_C_File
is
202 Delete_File
(Name_Buffer
(1 .. Name_Len
), Dummy
);
203 Create_File_And_Check
(Output_FD
, Text
);
206 -----------------------
207 -- Create_Debug_File --
208 -----------------------
210 function Create_Debug_File
(Src
: File_Name_Type
) return File_Name_Type
is
212 return Create_Auxiliary_File
(Src
, "dg");
213 end Create_Debug_File
;
219 procedure Create_H_File
is
223 Delete_File
(Name_Buffer
(1 .. Name_Len
), Dummy
);
224 Create_File_And_Check
(Output_FD
, Text
);
227 ----------------------
228 -- Create_List_File --
229 ----------------------
231 procedure Create_List_File
(S
: String) is
232 Dummy
: File_Name_Type
;
234 if S
(S
'First) = '.' then
236 Create_Auxiliary_File
(Current_Main
, S
(S
'First + 1 .. S
'Last));
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
);
243 end Create_List_File
;
245 --------------------------------
246 -- Create_Output_Library_Info --
247 --------------------------------
249 procedure Create_Output_Library_Info
is
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
;
257 ------------------------------
258 -- Open_Output_Library_Info --
259 ------------------------------
261 procedure Open_Output_Library_Info
is
263 Set_File_Name
(ALI_Suffix
.all);
264 Open_File_To_Append_And_Check
(Output_FD
, Text
);
265 end Open_Output_Library_Info
;
267 -------------------------
268 -- Create_Repinfo_File --
269 -------------------------
271 procedure Create_Repinfo_File
(Src
: String) is
272 Discard
: File_Name_Type
;
274 Name_Buffer
(1 .. Src
'Length) := Src
;
275 Name_Len
:= Src
'Length;
276 if List_Representation_Info_To_JSON
then
277 Discard
:= Create_Auxiliary_File
(Name_Find
, "json");
279 Discard
:= Create_Auxiliary_File
(Name_Find
, "rep");
281 end Create_Repinfo_File
;
283 ---------------------------
284 -- Debug_File_Eol_Length --
285 ---------------------------
287 function Debug_File_Eol_Length
return Nat
is
289 -- There has to be a cleaner way to do this ???
291 if Directory_Separator
= '/' then
296 end Debug_File_Eol_Length
;
302 procedure Delete_C_File
is
306 Delete_File
(Name_Buffer
(1 .. Name_Len
), Dummy
);
313 procedure Delete_H_File
is
317 Delete_File
(Name_Buffer
(1 .. Name_Len
), Dummy
);
320 ---------------------------------
321 -- Get_Output_Object_File_Name --
322 ---------------------------------
324 function Get_Output_Object_File_Name
return String is
326 pragma Assert
(Output_Object_File_Name
/= null);
328 return Output_Object_File_Name
.all;
329 end Get_Output_Object_File_Name
;
331 -----------------------
332 -- More_Source_Files --
333 -----------------------
335 function More_Source_Files
return Boolean renames More_Files
;
337 ----------------------
338 -- Next_Main_Source --
339 ----------------------
341 function Next_Main_Source
return File_Name_Type
renames Next_Main_File
;
343 -----------------------
344 -- Read_Library_Info --
345 -----------------------
347 procedure Read_Library_Info
348 (Name
: out File_Name_Type
;
349 Text
: out Text_Buffer_Ptr
)
352 Set_File_Name
(ALI_Suffix
.all);
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.
358 pragma Assert
(Name_Len
> 1 and then Name_Buffer
(Name_Len
) = ASCII
.NUL
);
359 Name_Len
:= Name_Len
- 1;
362 Text
:= Read_Library_Info
(Name
, Fatal_Err
=> False);
363 end Read_Library_Info
;
369 procedure Set_File_Name
(Ext
: String) is
373 Get_Name_String
(Current_Main
);
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.
379 Dot_Index
:= Name_Len
+ 1;
381 for J
in reverse 1 .. Name_Len
loop
382 if Name_Buffer
(J
) = '.' then
388 -- Make sure that the output file name matches the source file name.
389 -- To compare them, remove file name directories and extensions.
391 if Output_Object_File_Name
/= null then
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.
396 Name_Buffer
(Dot_Index
) := '.';
398 -- If we are in multiple unit per file mode, then add ~nnn
399 -- extension to the name before doing the comparison.
401 if Multiple_Unit_Index
/= 0 then
403 Exten
: constant String := Name_Buffer
(Dot_Index
.. Name_Len
);
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
);
413 -- Remove extension preparing to replace it
416 Name
: String := Name_Buffer
(1 .. Dot_Index
);
420 Name_Buffer
(1 .. Output_Object_File_Name
'Length) :=
421 Output_Object_File_Name
.all;
423 -- Put two names in canonical case, to allow object file names
424 -- with upper-case letters on Windows.
426 Canonical_Case_File_Name
(Name
);
427 Canonical_Case_File_Name
428 (Name_Buffer
(1 .. Output_Object_File_Name
'Length));
431 for J
in reverse Output_Object_File_Name
'Range loop
432 if Name_Buffer
(J
) = '.' then
438 -- Dot_Index should not be zero now (we check for extension
441 pragma Assert
(Dot_Index
/= 0);
443 -- Look for first character of file name
447 and then Name_Buffer
(First
- 1) /= Directory_Separator
448 and then Name_Buffer
(First
- 1) /= '/'
453 -- Check name of object file is what we expect
455 if Name
/= Name_Buffer
(First
.. Dot_Index
) then
456 Fail
("incorrect object file name");
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;
467 ---------------------------------
468 -- Set_Output_Object_File_Name --
469 ---------------------------------
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;
477 -- Make sure that the object file has the expected extension
481 (Name
(NL
- EL
+ Name
'First .. Name
'Last) /= Ext
482 and then Name
(NL
- 2 + Name
'First .. Name
'Last) /= ".o"
485 or else Name
(NL
- 2 + Name
'First .. Name
'Last) /= ".c"))
487 Fail
("incorrect object file extension");
490 Output_Object_File_Name
:= new String'(Name);
491 end Set_Output_Object_File_Name;
497 procedure Tree_Close is
500 Tree_Write_Terminate;
501 Close (Output_FD, Status);
505 ("error while closing tree file "
506 & Get_Name_String (Output_File_Name));
514 procedure Tree_Create is
518 Get_Name_String (Current_Main);
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.
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;
530 Dot_Index := Name_Len + 1;
532 for J in reverse 1 .. Name_Len loop
533 if Name_Buffer (J) = '.' then
539 -- Should be impossible to not have an extension
541 pragma Assert (Dot_Index /= 0);
543 -- Change extension to adt
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);
553 Tree_Write_Initialize (Output_FD);
556 -----------------------
557 -- Write_Debug_Info --
558 -----------------------
560 procedure Write_Debug_Info (Info : String) renames Write_Info;
562 ------------------------
563 -- Write_Library_Info --
564 ------------------------
566 procedure Write_Library_Info (Info : String) renames Write_Info;
568 ---------------------
569 -- Write_List_Info --
570 ---------------------
572 procedure Write_List_Info (S : String) is
574 Write_With_Check (S'Address, S'Length);
577 ------------------------
578 -- Write_Repinfo_Line --
579 ------------------------
581 procedure Write_Repinfo_Line (Info : String) renames Write_Info;
584 Adjust_OS_Resource_Limits;
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;
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;
594 Set_Program (Compiler);