File : put_scos.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P U T _ S C O S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2009-2014, 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 Namet; use Namet;
27 with Opt; use Opt;
28 with SCOs; use SCOs;
29
30 procedure Put_SCOs is
31 Current_SCO_Unit : SCO_Unit_Index := 0;
32 -- Initial value must not be a valid unit index
33
34 procedure Write_SCO_Initiate (SU : SCO_Unit_Index);
35 -- Start SCO line for unit SU, also emitting SCO unit header if necessary
36
37 procedure Write_Instance_Table;
38 -- Output the SCO table of instances
39
40 procedure Output_Range (T : SCO_Table_Entry);
41 -- Outputs T.From and T.To in line:col-line:col format
42
43 procedure Output_Source_Location (Loc : Source_Location);
44 -- Output source location in line:col format
45
46 procedure Output_String (S : String);
47 -- Output S
48
49 ------------------
50 -- Output_Range --
51 ------------------
52
53 procedure Output_Range (T : SCO_Table_Entry) is
54 begin
55 Output_Source_Location (T.From);
56 Write_Info_Char ('-');
57 Output_Source_Location (T.To);
58 end Output_Range;
59
60 ----------------------------
61 -- Output_Source_Location --
62 ----------------------------
63
64 procedure Output_Source_Location (Loc : Source_Location) is
65 begin
66 Write_Info_Nat (Nat (Loc.Line));
67 Write_Info_Char (':');
68 Write_Info_Nat (Nat (Loc.Col));
69 end Output_Source_Location;
70
71 -------------------
72 -- Output_String --
73 -------------------
74
75 procedure Output_String (S : String) is
76 begin
77 for J in S'Range loop
78 Write_Info_Char (S (J));
79 end loop;
80 end Output_String;
81
82 --------------------------
83 -- Write_Instance_Table --
84 --------------------------
85
86 procedure Write_Instance_Table is
87 begin
88 for J in 1 .. SCO_Instance_Table.Last loop
89 declare
90 SIE : SCO_Instance_Table_Entry
91 renames SCO_Instance_Table.Table (J);
92 begin
93 Output_String ("C i ");
94 Write_Info_Nat (Nat (J));
95 Write_Info_Char (' ');
96 Write_Info_Nat (SIE.Inst_Dep_Num);
97 Write_Info_Char ('|');
98 Output_Source_Location (SIE.Inst_Loc);
99
100 if SIE.Enclosing_Instance > 0 then
101 Write_Info_Char (' ');
102 Write_Info_Nat (Nat (SIE.Enclosing_Instance));
103 end if;
104 Write_Info_Terminate;
105 end;
106 end loop;
107 end Write_Instance_Table;
108
109 ------------------------
110 -- Write_SCO_Initiate --
111 ------------------------
112
113 procedure Write_SCO_Initiate (SU : SCO_Unit_Index) is
114 SUT : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (SU);
115
116 begin
117 if Current_SCO_Unit /= SU then
118 Write_Info_Initiate ('C');
119 Write_Info_Char (' ');
120 Write_Info_Nat (SUT.Dep_Num);
121 Write_Info_Char (' ');
122
123 Output_String (SUT.File_Name.all);
124
125 Write_Info_Terminate;
126
127 Current_SCO_Unit := SU;
128 end if;
129
130 Write_Info_Initiate ('C');
131 end Write_SCO_Initiate;
132
133 -- Start of processing for Put_SCOs
134
135 begin
136 -- Loop through entries in SCO_Unit_Table. Note that entry 0 is by
137 -- convention present but unused.
138
139 for U in 1 .. SCO_Unit_Table.Last loop
140 declare
141 SUT : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (U);
142
143 Start : Nat;
144 Stop : Nat;
145
146 begin
147 Start := SUT.From;
148 Stop := SUT.To;
149
150 -- Loop through SCO entries for this unit
151
152 loop
153 exit when Start = Stop + 1;
154 pragma Assert (Start <= Stop);
155
156 Output_SCO_Line : declare
157 T : SCO_Table_Entry renames SCO_Table.Table (Start);
158 Continuation : Boolean;
159
160 Ctr : Nat;
161 -- Counter for statement entries
162
163 begin
164 case T.C1 is
165
166 -- Statements (and dominance markers)
167
168 when 'S' | '>' =>
169 Ctr := 0;
170 Continuation := False;
171 loop
172 if Ctr = 0 then
173 Write_SCO_Initiate (U);
174 if not Continuation then
175 Write_Info_Char ('S');
176 Continuation := True;
177 else
178 Write_Info_Char ('s');
179 end if;
180 end if;
181
182 Write_Info_Char (' ');
183
184 declare
185 Sent : SCO_Table_Entry
186 renames SCO_Table.Table (Start);
187 begin
188 if Sent.C1 = '>' then
189 Write_Info_Char (Sent.C1);
190 end if;
191
192 if Sent.C2 /= ' ' then
193 Write_Info_Char (Sent.C2);
194
195 if Sent.C1 = 'S'
196 and then (Sent.C2 = 'P' or else Sent.C2 = 'p')
197 and then Sent.Pragma_Aspect_Name /= No_Name
198 then
199 Write_Info_Name (Sent.Pragma_Aspect_Name);
200 Write_Info_Char (':');
201 end if;
202 end if;
203
204 -- For dependence markers (except E), output sloc.
205 -- For >E and all statement entries, output sloc
206 -- range.
207
208 if Sent.C1 = '>' and then Sent.C2 /= 'E' then
209 Output_Source_Location (Sent.From);
210 else
211 Output_Range (Sent);
212 end if;
213 end;
214
215 -- Increment entry counter (up to 6 entries per line,
216 -- continuation lines are marked Cs).
217
218 Ctr := Ctr + 1;
219 if Ctr = 6 then
220 Write_Info_Terminate;
221 Ctr := 0;
222 end if;
223
224 exit when SCO_Table.Table (Start).Last;
225 Start := Start + 1;
226 end loop;
227
228 if Ctr > 0 then
229 Write_Info_Terminate;
230 end if;
231
232 -- Decision
233
234 when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' =>
235 Start := Start + 1;
236
237 Write_SCO_Initiate (U);
238 Write_Info_Char (T.C1);
239
240 if T.C1 = 'A' then
241 Write_Info_Name (T.Pragma_Aspect_Name);
242 end if;
243
244 if T.C1 /= 'X' then
245 Write_Info_Char (' ');
246 Output_Source_Location (T.From);
247 end if;
248
249 -- Loop through table entries for this decision
250
251 loop
252 declare
253 T : SCO_Table_Entry renames SCO_Table.Table (Start);
254
255 begin
256 Write_Info_Char (' ');
257
258 if T.C1 = '!' or else
259 T.C1 = '&' or else
260 T.C1 = '|'
261 then
262 Write_Info_Char (T.C1);
263 pragma Assert (T.C2 /= '?');
264 Output_Source_Location (T.From);
265
266 else
267 Write_Info_Char (T.C2);
268 Output_Range (T);
269 end if;
270
271 exit when T.Last;
272 Start := Start + 1;
273 end;
274 end loop;
275
276 Write_Info_Terminate;
277
278 when ASCII.NUL =>
279
280 -- Nullified entry: skip
281
282 null;
283
284 when others =>
285 raise Program_Error;
286 end case;
287 end Output_SCO_Line;
288
289 Start := Start + 1;
290 end loop;
291 end;
292 end loop;
293
294 if Opt.Generate_SCO_Instance_Table then
295 Write_Instance_Table;
296 end if;
297 end Put_SCOs;