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
|
------------------------------------------------------------------------------
-- --
-- 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-2014, 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.Text_IO;
with Ada.Wide_Text_IO; use Ada;
with Ada_Trees.PP;
with GNAT.Lock_Files;
with System.WCh_Con;
with Opt;
with GNATPP.Output; use GNATPP;
with GNATPP.Processing;
with GNATPP.State;
with GNATPP.Options; use GNATPP.Options;
with GNATPP.Common; use GNATPP.Common;
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.State.
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.
Output_Name : constant String :=
(case Output_Mode is
when Pipe => "", -- not used
when Create_Modes => State.Res_File_Name.all,
when Replace_Modes => Source_Name (SF),
when Default => Source_Name (SF) & GNATPP.Output.PP_Suffix,
when Out_Directory => Compose (Out_Dir.all, Short_Source_Name (SF)));
Temp_Output_Name : constant String :=
(if Output_Mode = Pipe then "" -- means standard output
else Output_Name & "__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 GNATPP.State, Text_IO, GNAT.Lock_Files;
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.
Lock_File (File_Name_File_Name.all & ".lock");
declare
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;
Unlock_File (File_Name_File_Name.all & ".lock");
end if;
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;
Success : Boolean;
begin
Set_Current_SF (SF);
-- ???Use_New_PP is True if we should use the new version of gnatpp
-- implemented by Ada_Trees. It is True by default, and set to False by the
-- --pp-old switch. Eventually, once we've been through a complete release
-- cycle with Use_New_PP defaulting to True, we plan to remove the flag and
-- the switch. We can then remove the GNATPP.Processing package and pretty
-- much everything it calls.
if Use_New_PP then
case Output_Mode is
when Pipe | Replace_Modes | Default =>
pragma Assert (State.Res_File_Name = null);
pragma Assert (Out_Dir = null);
when Create_Modes =>
pragma Assert (State.Res_File_Name /= null);
pragma Assert (Out_Dir = null);
when Out_Directory =>
pragma Assert (State.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;
GNATPP.State.Initialize;
Set_Output_Encoding;
GNATPP.Output.Set_Output (SF, Success);
-- pragma Assert (Success);
begin
Ada_Trees.PP.Asis_To_Ada
(CU, 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;
-- Use old pretty printer
else
GNATPP.Output.Set_Output (SF, Success);
-- pragma Assert (Success);
GNATPP.Processing.Pretty_Print (CU, SF);
end if;
end ASIS_Processing;
|
