1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285 | ------------------------------------------------------------------------------
-- --
-- GNATPP COMPONENTS --
-- --
-- A S I S _ U L . S O U R C E _ T A B L E . P R O C E S S I N G . --
-- A S I S _ P R O C E S S I N G --
-- --
-- (adapted for gnatpp from ASIS Utility Library) --
-- --
-- B o d y --
-- --
-- Copyright (C) 2009-2017, AdaCore --
-- --
-- GNATPP is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNATPP is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABI- --
-- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
-- License for more details. You should have received a copy of the GNU --
-- General Public License distributed with GNAT; see file COPYING. If not, --
-- write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, --
-- --
-- GNATPP is maintained by AdaCore (http://www.adacore.com) --
-- --
------------------------------------------------------------------------------
pragma Ada_2012;
with Ada.Directories; use Ada.Directories;
with Ada.Exceptions;
with Ada.Finalization;
with Ada.Text_IO; use Ada;
with Ada_Trees.PP;
with Ada.Wide_Text_IO;
with System.WCh_Con;
with Opt;
with GNATPP.Output; use GNATPP;
with GNATPP.Options; use GNATPP.Options;
separate (ASIS_UL.Source_Table.Processing)
procedure ASIS_Processing (CU : Asis.Compilation_Unit; SF : SF_Id) is
-- See also comments on File_Name_File_Name in GNATPP.Options.
pragma Assert (not Incremental_Mode);
-- We initially write the output to Temp_Output_Name, then later rename it
-- to Output_Name (except in Pipe mode). These are full pathnames. If we
-- are overwriting the Source_Name, and it's a link link-->file, we want to
-- overwrite file. But we put the temp file in the directory containing
-- link, in case the directory containing file is not writable.
function Get_Output_Name (Resolve_Links : Boolean) return String is
(case Output_Mode is
when Pipe => "", -- not used
when Create_Modes => Res_File_Name.all,
when Replace_Modes => Normalize_Pathname
(Source_Name (SF),
Resolve_Links => Resolve_Links,
Case_Sensitive => True),
when Default => Source_Name (SF) & PP_Suffix,
when Out_Directory => Compose (Out_Dir.all, Short_Source_Name (SF)));
Output_Name : constant String := Get_Output_Name (Resolve_Links => True);
Temp_Output_Name : constant String :=
(if Output_Mode = Pipe then "" -- means standard output
else Get_Output_Name (Resolve_Links => False) & "__GNATPP-TEMP");
Output_Written : Boolean;
-- True if Tree_To_Ada wrote the output to Temp_Output_Name. It always
-- does, except in Replace_Modes if the output would be identical to the
-- input.
procedure Write_File_Name_File;
-- If the Output_Mode /= Pipe, and Output_Written is True, add a pair of
-- lines to the file name file.
procedure Set_Output_Encoding;
-- Set the output encoding method. Default is as for the input.
procedure Write_File_Name_File is
use Text_IO;
Lock_File_Name : constant String := File_Name_File_Name.all & ".lock";
procedure Do_Writes;
-- Write the two file names to the file name file. This is split out
-- into a procedure so we can call it with and without file locking, as
-- appropriate.
procedure Do_Writes is
File_Name_File : File_Type;
begin
Open (File_Name_File,
Mode => Append_File,
Name => File_Name_File_Name.all);
Put_Line (File_Name_File, Temp_Output_Name);
Put_Line (File_Name_File, Output_Name);
Close (File_Name_File);
end Do_Writes;
-- Start of processing for Write_File_Name_File
begin
if Output_Mode /= Pipe then
-- In -r, -rf, and -rnb modes, if the output was identical to the
-- input, Output_Written will be False, so there is no
-- Temp_Output_Name file, so we don't move it in that case. This can
-- also happen if the exception handler at the end of Tree_To_Ada is
-- executed.
pragma Assert
(if Output_Mode not in Replace_Modes then Output_Written);
if not Output_Written then
return;
end if;
if Mimic_gcc and then (Verbose_Mode or else Debug_Flag_V) then
Put_Line
((if Output_Mode in Replace_Modes
then "updating "
else "creating ") &
(if Debug_Flag_V then Short_Source_Name (SF) else Output_Name));
end if;
-- The temp file was created, so write a pair (Temp_Output_Name,
-- Output_Name) of lines to the file name file, so Finalize will know
-- to rename temp --> output. This is done under lock, in case this
-- is an inner process of an incremental build, and the -j switch of
-- the builder is used to invoke this in parallel.
if Outer_Parallel then
pragma Assert (Mimic_gcc);
Lock_File (Lock_File_Name);
declare
-- We create a dummy object whose finalization calls
-- Unlock_File, so we don't leave stale lock files around even
-- in case of unhandled exceptions.
type Dummy_Type is new Ada.Finalization.Limited_Controlled with
null record;
procedure Finalize (Ignore : in out Dummy_Type);
procedure Finalize (Ignore : in out Dummy_Type) is
begin
Unlock_File (Lock_File_Name);
end Finalize;
Dummy : Dummy_Type;
begin
Do_Writes;
end;
-- Otherwise, it's safe to do the writes without any locking. We want
-- to avoid locking when possible, because it reduces the likelihood
-- of stale locks left lying around. It's a little more efficient,
-- too.
else
Do_Writes;
end if;
end if;
exception
when Lock_Error =>
ASIS_UL.Output.Error ("cannot create " & Lock_File_Name);
ASIS_UL.Output.Error ("delete it by hand if stale");
raise;
end Write_File_Name_File;
procedure Set_Output_Encoding is
use System.WCh_Con;
begin
-- If the output encoding was not specified on the command line, make it
-- the same as the input encoding, which is in
-- Opt.Wide_Character_Encoding_Method. See also Check_Parameters.
-- Otherwise, it is an error if they are not the same, which happens if
-- the user specified both "-gnatWx" and "Wy", where x /= y.
if Output_Encoding = WCEM_Default then
Output_Encoding := Opt.Wide_Character_Encoding_Method;
elsif Output_Encoding /=
Opt.Wide_Character_Encoding_Method
then
ASIS_UL.Output.Error
("input and output wide character encodings conflict");
raise Fatal_Error;
end if;
The_Formatting_Options.Output_Encoding :=
Output_Encoding;
GNATPP.Output.Set_Form_String;
-- This is the second time we're calling Set_Form_String; the first time
-- was too early, before we had a correct value for
-- Opt.Wide_Character_Encoding_Method. ???Could be cleaned up.
-- Also, do we really need two different types for encodings?
end Set_Output_Encoding;
use Wide_Text_IO;
begin
case Output_Mode is
when Pipe | Replace_Modes | Default =>
pragma Assert (Res_File_Name = null);
pragma Assert (Out_Dir = null);
when Create_Modes =>
pragma Assert (Res_File_Name /= null);
pragma Assert (Out_Dir = null);
when Out_Directory =>
pragma Assert (Res_File_Name = null);
pragma Assert (Out_Dir /= null);
if Out_Dir.all =
Containing_Directory (Source_Name (SF))
then
Error ("--output-dir=" & Out_Dir.all);
Error (" contains input file " & Short_Source_Name (SF));
Error (" skipping " & Short_Source_Name (SF));
Error (" use -rnb to update source files in place");
return;
end if;
end case;
Set_Output_Encoding;
if Output_Mode = Replace and then
Is_Regular_File (Source_Name (SF) & NPP_Suffix)
then
Put (Standard_Error, "gnatpp: file ");
Put (Standard_Error,
To_Wide_String (Source_Name (SF) & NPP_Suffix));
Put (Standard_Error, " exists. Use '-rf' option to override");
New_Line (Standard_Error);
return;
end if;
if Output_Mode in Replace | Force_Replace then
if Verbose_Mode then
Put (Standard_Error, "gnatpp: creating the back-up copy ");
Put (Standard_Error, "of the original source ");
Put (Standard_Error, To_Wide_String (Source_Name (SF)));
New_Line (Standard_Error);
end if;
declare
Success : Boolean;
begin
Copy_File
(Name => Source_Name (SF),
Pathname => Source_Name (SF) & NPP_Suffix,
Success => Success,
Mode => Overwrite);
if not Success then
Put (Standard_Error, "gnatpp: can not create ");
Put (Standard_Error, "the back-up copy for ");
Put (Standard_Error, To_Wide_String (Source_Name (SF)));
New_Line (Standard_Error);
end if;
end;
end if;
begin
Ada_Trees.PP.Asis_To_Ada
(CU,
Short_Source_Name (SF),
The_Formatting_Options,
Output_Name => Temp_Output_Name, Form_String => Form_String.all,
Do_Diff => Output_Mode in Replace_Modes,
Output_Written => Output_Written);
Set_Source_Status (SF, Processed);
Write_File_Name_File;
exception
when others =>
Set_Source_Status (SF, Error_Detected);
raise;
end;
end ASIS_Processing;
|