|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- R E P I N F O --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1999-2019, 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. --
|
|
|
17 -- --
|
|
|
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
21 -- --
|
|
|
22 -- You should have received a copy of the GNU General Public License and --
|
|
|
23 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
25 -- <http://www.gnu.org/licenses/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 with Alloc;
|
|
|
33 with Atree; use Atree;
|
|
|
34 with Casing; use Casing;
|
|
|
35 with Debug; use Debug;
|
|
|
36 with Einfo; use Einfo;
|
|
|
37 with Lib; use Lib;
|
|
|
38 with Namet; use Namet;
|
|
|
39 with Nlists; use Nlists;
|
|
|
40 with Opt; use Opt;
|
|
|
41 with Output; use Output;
|
|
|
42 with Sem_Aux; use Sem_Aux;
|
|
|
43 with Sinfo; use Sinfo;
|
|
|
44 with Sinput; use Sinput;
|
|
|
45 with Snames; use Snames;
|
|
|
46 with Stringt; use Stringt;
|
|
|
47 with Table;
|
|
|
48 with Uname; use Uname;
|
|
|
49 with Urealp; use Urealp;
|
|
|
50
|
|
|
51 with Ada.Unchecked_Conversion;
|
|
|
52
|
|
145
|
53 with GNAT.HTable;
|
|
|
54
|
|
111
|
55 package body Repinfo is
|
|
|
56
|
|
|
57 SSU : constant := 8;
|
|
|
58 -- Value for Storage_Unit, we do not want to get this from TTypes, since
|
|
|
59 -- this introduces problematic dependencies in ASIS, and in any case this
|
|
|
60 -- value is assumed to be 8 for the implementation of the DDA.
|
|
|
61
|
|
|
62 ---------------------------------------
|
|
|
63 -- Representation of GCC Expressions --
|
|
|
64 ---------------------------------------
|
|
|
65
|
|
|
66 -- A table internal to this unit is used to hold the values of back
|
|
|
67 -- annotated expressions. This table is written out by -gnatt and read
|
|
|
68 -- back in for ASIS processing.
|
|
|
69
|
|
|
70 -- Node values are stored as Uint values using the negative of the node
|
|
|
71 -- index in this table. Constants appear as non-negative Uint values.
|
|
|
72
|
|
|
73 type Exp_Node is record
|
|
|
74 Expr : TCode;
|
|
|
75 Op1 : Node_Ref_Or_Val;
|
|
|
76 Op2 : Node_Ref_Or_Val;
|
|
|
77 Op3 : Node_Ref_Or_Val;
|
|
|
78 end record;
|
|
|
79
|
|
|
80 -- The following representation clause ensures that the above record
|
|
|
81 -- has no holes. We do this so that when instances of this record are
|
|
|
82 -- written by Tree_Gen, we do not write uninitialized values to the file.
|
|
|
83
|
|
|
84 for Exp_Node use record
|
|
|
85 Expr at 0 range 0 .. 31;
|
|
|
86 Op1 at 4 range 0 .. 31;
|
|
|
87 Op2 at 8 range 0 .. 31;
|
|
|
88 Op3 at 12 range 0 .. 31;
|
|
|
89 end record;
|
|
|
90
|
|
|
91 for Exp_Node'Size use 16 * 8;
|
|
|
92 -- This ensures that we did not leave out any fields
|
|
|
93
|
|
|
94 package Rep_Table is new Table.Table (
|
|
|
95 Table_Component_Type => Exp_Node,
|
|
|
96 Table_Index_Type => Nat,
|
|
|
97 Table_Low_Bound => 1,
|
|
|
98 Table_Initial => Alloc.Rep_Table_Initial,
|
|
|
99 Table_Increment => Alloc.Rep_Table_Increment,
|
|
|
100 Table_Name => "BE_Rep_Table");
|
|
|
101
|
|
|
102 --------------------------------------------------------------
|
|
|
103 -- Representation of Front-End Dynamic Size/Offset Entities --
|
|
|
104 --------------------------------------------------------------
|
|
|
105
|
|
|
106 package Dynamic_SO_Entity_Table is new Table.Table (
|
|
|
107 Table_Component_Type => Entity_Id,
|
|
|
108 Table_Index_Type => Nat,
|
|
|
109 Table_Low_Bound => 1,
|
|
|
110 Table_Initial => Alloc.Rep_Table_Initial,
|
|
|
111 Table_Increment => Alloc.Rep_Table_Increment,
|
|
|
112 Table_Name => "FE_Rep_Table");
|
|
|
113
|
|
|
114 Unit_Casing : Casing_Type;
|
|
|
115 -- Identifier casing for current unit. This is set by List_Rep_Info for
|
|
|
116 -- each unit, before calling subprograms which may read it.
|
|
|
117
|
|
145
|
118 Need_Separator : Boolean;
|
|
|
119 -- Set True if a separator is needed before outputting any information for
|
|
|
120 -- the current entity.
|
|
|
121
|
|
|
122 ------------------------------
|
|
|
123 -- Set of Relevant Entities --
|
|
|
124 ------------------------------
|
|
|
125
|
|
|
126 Relevant_Entities_Size : constant := 4093;
|
|
|
127 -- Number of headers in hash table
|
|
|
128
|
|
|
129 subtype Entity_Header_Num is Integer range 0 .. Relevant_Entities_Size - 1;
|
|
|
130 -- Range of headers in hash table
|
|
|
131
|
|
|
132 function Entity_Hash (Id : Entity_Id) return Entity_Header_Num;
|
|
|
133 -- Simple hash function for Entity_Ids
|
|
|
134
|
|
|
135 package Relevant_Entities is new GNAT.Htable.Simple_HTable
|
|
|
136 (Header_Num => Entity_Header_Num,
|
|
|
137 Element => Boolean,
|
|
|
138 No_Element => False,
|
|
|
139 Key => Entity_Id,
|
|
|
140 Hash => Entity_Hash,
|
|
|
141 Equal => "=");
|
|
|
142 -- Hash table to record which compiler-generated entities are relevant
|
|
111
|
143
|
|
|
144 -----------------------
|
|
|
145 -- Local Subprograms --
|
|
|
146 -----------------------
|
|
|
147
|
|
|
148 function Back_End_Layout return Boolean;
|
|
|
149 -- Test for layout mode, True = back end, False = front end. This function
|
|
|
150 -- is used rather than checking the configuration parameter because we do
|
|
|
151 -- not want Repinfo to depend on Targparm (for ASIS)
|
|
|
152
|
|
|
153 procedure List_Entities
|
|
|
154 (Ent : Entity_Id;
|
|
|
155 Bytes_Big_Endian : Boolean;
|
|
|
156 In_Subprogram : Boolean := False);
|
|
|
157 -- This procedure lists the entities associated with the entity E, starting
|
|
|
158 -- with the First_Entity and using the Next_Entity link. If a nested
|
|
|
159 -- package is found, entities within the package are recursively processed.
|
|
|
160 -- When recursing within a subprogram body, Is_Subprogram suppresses
|
|
|
161 -- duplicate information about signature.
|
|
|
162
|
|
|
163 procedure List_Name (Ent : Entity_Id);
|
|
|
164 -- List name of entity Ent in appropriate case. The name is listed with
|
|
|
165 -- full qualification up to but not including the compilation unit name.
|
|
|
166
|
|
|
167 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
|
|
|
168 -- List representation info for array type Ent
|
|
|
169
|
|
145
|
170 procedure List_Common_Type_Info (Ent : Entity_Id);
|
|
|
171 -- List common type info (name, size, alignment) for type Ent
|
|
|
172
|
|
111
|
173 procedure List_Linker_Section (Ent : Entity_Id);
|
|
|
174 -- List linker section for Ent (caller has checked that Ent is an entity
|
|
|
175 -- for which the Linker_Section_Pragma field is defined).
|
|
|
176
|
|
131
|
177 procedure List_Location (Ent : Entity_Id);
|
|
|
178 -- List location information for Ent
|
|
|
179
|
|
111
|
180 procedure List_Object_Info (Ent : Entity_Id);
|
|
|
181 -- List representation info for object Ent
|
|
|
182
|
|
|
183 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
|
|
|
184 -- List representation info for record type Ent
|
|
|
185
|
|
|
186 procedure List_Scalar_Storage_Order
|
|
|
187 (Ent : Entity_Id;
|
|
|
188 Bytes_Big_Endian : Boolean);
|
|
|
189 -- List scalar storage order information for record or array type Ent.
|
|
|
190 -- Also includes bit order information for record types, if necessary.
|
|
|
191
|
|
145
|
192 procedure List_Subprogram_Info (Ent : Entity_Id);
|
|
|
193 -- List subprogram info for subprogram Ent
|
|
|
194
|
|
111
|
195 procedure List_Type_Info (Ent : Entity_Id);
|
|
|
196 -- List type info for type Ent
|
|
|
197
|
|
|
198 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean;
|
|
|
199 -- Returns True if Val represents a variable value, and False if it
|
|
|
200 -- represents a value that is fixed at compile time.
|
|
|
201
|
|
|
202 procedure Spaces (N : Natural);
|
|
|
203 -- Output given number of spaces
|
|
|
204
|
|
|
205 procedure Write_Info_Line (S : String);
|
|
|
206 -- Routine to write a line to Repinfo output file. This routine is passed
|
|
|
207 -- as a special output procedure to Output.Set_Special_Output. Note that
|
|
|
208 -- Write_Info_Line is called with an EOL character at the end of each line,
|
|
|
209 -- as per the Output spec, but the internal call to the appropriate routine
|
|
|
210 -- in Osint requires that the end of line sequence be stripped off.
|
|
|
211
|
|
|
212 procedure Write_Mechanism (M : Mechanism_Type);
|
|
|
213 -- Writes symbolic string for mechanism represented by M
|
|
|
214
|
|
145
|
215 procedure Write_Separator;
|
|
|
216 -- Called before outputting anything for an entity. Ensures that
|
|
|
217 -- a separator precedes the output for a particular entity.
|
|
|
218
|
|
131
|
219 procedure Write_Unknown_Val;
|
|
|
220 -- Writes symbolic string for an unknown or non-representable value
|
|
|
221
|
|
111
|
222 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
|
|
|
223 -- Given a representation value, write it out. No_Uint values or values
|
|
|
224 -- dependent on discriminants are written as two question marks. If the
|
|
|
225 -- flag Paren is set, then the output is surrounded in parentheses if it is
|
|
|
226 -- other than a simple value.
|
|
|
227
|
|
|
228 ---------------------
|
|
|
229 -- Back_End_Layout --
|
|
|
230 ---------------------
|
|
|
231
|
|
|
232 function Back_End_Layout return Boolean is
|
|
|
233 begin
|
|
131
|
234 -- We have back-end layout if the back end has made any entries in the
|
|
|
235 -- table of GCC expressions, otherwise we have front-end layout.
|
|
111
|
236
|
|
|
237 return Rep_Table.Last > 0;
|
|
|
238 end Back_End_Layout;
|
|
|
239
|
|
|
240 ------------------------
|
|
|
241 -- Create_Discrim_Ref --
|
|
|
242 ------------------------
|
|
|
243
|
|
|
244 function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref is
|
|
|
245 begin
|
|
|
246 return Create_Node
|
|
|
247 (Expr => Discrim_Val,
|
|
|
248 Op1 => Discriminant_Number (Discr));
|
|
|
249 end Create_Discrim_Ref;
|
|
|
250
|
|
|
251 ---------------------------
|
|
|
252 -- Create_Dynamic_SO_Ref --
|
|
|
253 ---------------------------
|
|
|
254
|
|
|
255 function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is
|
|
|
256 begin
|
|
|
257 Dynamic_SO_Entity_Table.Append (E);
|
|
|
258 return UI_From_Int (-Dynamic_SO_Entity_Table.Last);
|
|
|
259 end Create_Dynamic_SO_Ref;
|
|
|
260
|
|
|
261 -----------------
|
|
|
262 -- Create_Node --
|
|
|
263 -----------------
|
|
|
264
|
|
|
265 function Create_Node
|
|
|
266 (Expr : TCode;
|
|
|
267 Op1 : Node_Ref_Or_Val;
|
|
|
268 Op2 : Node_Ref_Or_Val := No_Uint;
|
|
|
269 Op3 : Node_Ref_Or_Val := No_Uint) return Node_Ref
|
|
|
270 is
|
|
|
271 begin
|
|
|
272 Rep_Table.Append (
|
|
|
273 (Expr => Expr,
|
|
|
274 Op1 => Op1,
|
|
|
275 Op2 => Op2,
|
|
|
276 Op3 => Op3));
|
|
|
277 return UI_From_Int (-Rep_Table.Last);
|
|
|
278 end Create_Node;
|
|
|
279
|
|
145
|
280 -----------------
|
|
|
281 -- Entity_Hash --
|
|
|
282 -----------------
|
|
|
283
|
|
|
284 function Entity_Hash (Id : Entity_Id) return Entity_Header_Num is
|
|
|
285 begin
|
|
|
286 return Entity_Header_Num (Id mod Relevant_Entities_Size);
|
|
|
287 end Entity_Hash;
|
|
|
288
|
|
111
|
289 ---------------------------
|
|
|
290 -- Get_Dynamic_SO_Entity --
|
|
|
291 ---------------------------
|
|
|
292
|
|
|
293 function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is
|
|
|
294 begin
|
|
|
295 return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U));
|
|
|
296 end Get_Dynamic_SO_Entity;
|
|
|
297
|
|
|
298 -----------------------
|
|
|
299 -- Is_Dynamic_SO_Ref --
|
|
|
300 -----------------------
|
|
|
301
|
|
|
302 function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is
|
|
|
303 begin
|
|
|
304 return U < Uint_0;
|
|
|
305 end Is_Dynamic_SO_Ref;
|
|
|
306
|
|
|
307 ----------------------
|
|
|
308 -- Is_Static_SO_Ref --
|
|
|
309 ----------------------
|
|
|
310
|
|
|
311 function Is_Static_SO_Ref (U : SO_Ref) return Boolean is
|
|
|
312 begin
|
|
|
313 return U >= Uint_0;
|
|
|
314 end Is_Static_SO_Ref;
|
|
|
315
|
|
|
316 ---------
|
|
|
317 -- lgx --
|
|
|
318 ---------
|
|
|
319
|
|
|
320 procedure lgx (U : Node_Ref_Or_Val) is
|
|
|
321 begin
|
|
|
322 List_GCC_Expression (U);
|
|
|
323 Write_Eol;
|
|
|
324 end lgx;
|
|
|
325
|
|
|
326 ----------------------
|
|
|
327 -- List_Array_Info --
|
|
|
328 ----------------------
|
|
|
329
|
|
|
330 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
|
|
|
331 begin
|
|
145
|
332 Write_Separator;
|
|
131
|
333
|
|
|
334 if List_Representation_Info_To_JSON then
|
|
|
335 Write_Line ("{");
|
|
|
336 end if;
|
|
|
337
|
|
145
|
338 List_Common_Type_Info (Ent);
|
|
131
|
339
|
|
|
340 if List_Representation_Info_To_JSON then
|
|
|
341 Write_Line (",");
|
|
|
342 Write_Str (" ""Component_Size"": ");
|
|
|
343 Write_Val (Component_Size (Ent));
|
|
|
344 else
|
|
|
345 Write_Str ("for ");
|
|
|
346 List_Name (Ent);
|
|
|
347 Write_Str ("'Component_Size use ");
|
|
|
348 Write_Val (Component_Size (Ent));
|
|
|
349 Write_Line (";");
|
|
|
350 end if;
|
|
111
|
351
|
|
|
352 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
|
|
131
|
353
|
|
|
354 List_Linker_Section (Ent);
|
|
|
355
|
|
|
356 if List_Representation_Info_To_JSON then
|
|
|
357 Write_Eol;
|
|
|
358 Write_Line ("}");
|
|
|
359 end if;
|
|
145
|
360
|
|
|
361 -- The component type is relevant for an array
|
|
|
362
|
|
|
363 if List_Representation_Info = 4
|
|
|
364 and then Is_Itype (Component_Type (Base_Type (Ent)))
|
|
|
365 then
|
|
|
366 Relevant_Entities.Set (Component_Type (Base_Type (Ent)), True);
|
|
|
367 end if;
|
|
111
|
368 end List_Array_Info;
|
|
|
369
|
|
145
|
370 ---------------------------
|
|
|
371 -- List_Common_Type_Info --
|
|
|
372 ---------------------------
|
|
|
373
|
|
|
374 procedure List_Common_Type_Info (Ent : Entity_Id) is
|
|
|
375 begin
|
|
|
376 if List_Representation_Info_To_JSON then
|
|
|
377 Write_Str (" ""name"": """);
|
|
|
378 List_Name (Ent);
|
|
|
379 Write_Line (""",");
|
|
|
380 List_Location (Ent);
|
|
|
381 end if;
|
|
|
382
|
|
|
383 -- Do not list size info for unconstrained arrays, not meaningful
|
|
|
384
|
|
|
385 if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then
|
|
|
386 null;
|
|
|
387
|
|
|
388 else
|
|
|
389 -- If Esize and RM_Size are the same, list as Size. This is a common
|
|
|
390 -- case, which we may as well list in simple form.
|
|
|
391
|
|
|
392 if Esize (Ent) = RM_Size (Ent) then
|
|
|
393 if List_Representation_Info_To_JSON then
|
|
|
394 Write_Str (" ""Size"": ");
|
|
|
395 Write_Val (Esize (Ent));
|
|
|
396 Write_Line (",");
|
|
|
397 else
|
|
|
398 Write_Str ("for ");
|
|
|
399 List_Name (Ent);
|
|
|
400 Write_Str ("'Size use ");
|
|
|
401 Write_Val (Esize (Ent));
|
|
|
402 Write_Line (";");
|
|
|
403 end if;
|
|
|
404
|
|
|
405 -- Otherwise list size values separately
|
|
|
406
|
|
|
407 else
|
|
|
408 if List_Representation_Info_To_JSON then
|
|
|
409 Write_Str (" ""Object_Size"": ");
|
|
|
410 Write_Val (Esize (Ent));
|
|
|
411 Write_Line (",");
|
|
|
412
|
|
|
413 Write_Str (" ""Value_Size"": ");
|
|
|
414 Write_Val (RM_Size (Ent));
|
|
|
415 Write_Line (",");
|
|
|
416
|
|
|
417 else
|
|
|
418 Write_Str ("for ");
|
|
|
419 List_Name (Ent);
|
|
|
420 Write_Str ("'Object_Size use ");
|
|
|
421 Write_Val (Esize (Ent));
|
|
|
422 Write_Line (";");
|
|
|
423
|
|
|
424 Write_Str ("for ");
|
|
|
425 List_Name (Ent);
|
|
|
426 Write_Str ("'Value_Size use ");
|
|
|
427 Write_Val (RM_Size (Ent));
|
|
|
428 Write_Line (";");
|
|
|
429 end if;
|
|
|
430 end if;
|
|
|
431 end if;
|
|
|
432
|
|
|
433 if List_Representation_Info_To_JSON then
|
|
|
434 Write_Str (" ""Alignment"": ");
|
|
|
435 Write_Val (Alignment (Ent));
|
|
|
436 else
|
|
|
437 Write_Str ("for ");
|
|
|
438 List_Name (Ent);
|
|
|
439 Write_Str ("'Alignment use ");
|
|
|
440 Write_Val (Alignment (Ent));
|
|
|
441 Write_Line (";");
|
|
|
442 end if;
|
|
|
443 end List_Common_Type_Info;
|
|
|
444
|
|
111
|
445 -------------------
|
|
|
446 -- List_Entities --
|
|
|
447 -------------------
|
|
|
448
|
|
|
449 procedure List_Entities
|
|
|
450 (Ent : Entity_Id;
|
|
|
451 Bytes_Big_Endian : Boolean;
|
|
|
452 In_Subprogram : Boolean := False)
|
|
|
453 is
|
|
|
454 Body_E : Entity_Id;
|
|
|
455 E : Entity_Id;
|
|
|
456
|
|
|
457 function Find_Declaration (E : Entity_Id) return Node_Id;
|
|
|
458 -- Utility to retrieve declaration node for entity in the
|
|
|
459 -- case of package bodies and subprograms.
|
|
|
460
|
|
|
461 ----------------------
|
|
|
462 -- Find_Declaration --
|
|
|
463 ----------------------
|
|
|
464
|
|
|
465 function Find_Declaration (E : Entity_Id) return Node_Id is
|
|
|
466 Decl : Node_Id;
|
|
|
467
|
|
|
468 begin
|
|
|
469 Decl := Parent (E);
|
|
|
470 while Present (Decl)
|
|
|
471 and then Nkind (Decl) /= N_Package_Body
|
|
|
472 and then Nkind (Decl) /= N_Subprogram_Declaration
|
|
|
473 and then Nkind (Decl) /= N_Subprogram_Body
|
|
|
474 loop
|
|
|
475 Decl := Parent (Decl);
|
|
|
476 end loop;
|
|
|
477
|
|
|
478 return Decl;
|
|
|
479 end Find_Declaration;
|
|
|
480
|
|
|
481 -- Start of processing for List_Entities
|
|
|
482
|
|
|
483 begin
|
|
|
484 -- List entity if we have one, and it is not a renaming declaration.
|
|
|
485 -- For renamings, we don't get proper information, and really it makes
|
|
|
486 -- sense to restrict the output to the renamed entity.
|
|
|
487
|
|
|
488 if Present (Ent)
|
|
|
489 and then Nkind (Declaration_Node (Ent)) not in N_Renaming_Declaration
|
|
145
|
490 and then not Is_Ignored_Ghost_Entity (Ent)
|
|
111
|
491 then
|
|
|
492 -- If entity is a subprogram and we are listing mechanisms,
|
|
|
493 -- then we need to list mechanisms for this entity. We skip this
|
|
|
494 -- if it is a nested subprogram, as the information has already
|
|
|
495 -- been produced when listing the enclosing scope.
|
|
|
496
|
|
|
497 if List_Representation_Info_Mechanisms
|
|
|
498 and then (Is_Subprogram (Ent)
|
|
|
499 or else Ekind (Ent) = E_Entry
|
|
|
500 or else Ekind (Ent) = E_Entry_Family)
|
|
|
501 and then not In_Subprogram
|
|
|
502 then
|
|
145
|
503 List_Subprogram_Info (Ent);
|
|
111
|
504 end if;
|
|
|
505
|
|
|
506 E := First_Entity (Ent);
|
|
|
507 while Present (E) loop
|
|
|
508 -- We list entities that come from source (excluding private or
|
|
145
|
509 -- incomplete types or deferred constants, for which we will list
|
|
|
510 -- the information for the full view). If requested, we also list
|
|
|
511 -- relevant entities that have been generated when processing the
|
|
|
512 -- original entities coming from source. But if debug flag A is
|
|
|
513 -- set, then all entities are listed.
|
|
111
|
514
|
|
131
|
515 if ((Comes_From_Source (E)
|
|
|
516 or else (Ekind (E) = E_Block
|
|
|
517 and then
|
|
|
518 Nkind (Parent (E)) = N_Implicit_Label_Declaration
|
|
|
519 and then
|
|
|
520 Comes_From_Source (Label_Construct (Parent (E)))))
|
|
111
|
521 and then not Is_Incomplete_Or_Private_Type (E)
|
|
|
522 and then not (Ekind (E) = E_Constant
|
|
|
523 and then Present (Full_View (E))))
|
|
145
|
524 or else (List_Representation_Info = 4
|
|
|
525 and then Relevant_Entities.Get (E))
|
|
111
|
526 or else Debug_Flag_AA
|
|
|
527 then
|
|
|
528 if Is_Subprogram (E) then
|
|
|
529 if List_Representation_Info_Mechanisms then
|
|
145
|
530 List_Subprogram_Info (E);
|
|
111
|
531 end if;
|
|
|
532
|
|
|
533 -- Recurse into entities local to subprogram
|
|
|
534
|
|
|
535 List_Entities (E, Bytes_Big_Endian, True);
|
|
|
536
|
|
|
537 elsif Ekind_In (E, E_Entry,
|
|
|
538 E_Entry_Family,
|
|
|
539 E_Subprogram_Type)
|
|
|
540 then
|
|
|
541 if List_Representation_Info_Mechanisms then
|
|
145
|
542 List_Subprogram_Info (E);
|
|
111
|
543 end if;
|
|
|
544
|
|
|
545 elsif Is_Record_Type (E) then
|
|
|
546 if List_Representation_Info >= 1 then
|
|
|
547 List_Record_Info (E, Bytes_Big_Endian);
|
|
|
548 end if;
|
|
|
549
|
|
145
|
550 -- Recurse into entities local to a record type
|
|
|
551
|
|
|
552 if List_Representation_Info = 4 then
|
|
|
553 List_Entities (E, Bytes_Big_Endian, False);
|
|
|
554 end if;
|
|
|
555
|
|
111
|
556 elsif Is_Array_Type (E) then
|
|
|
557 if List_Representation_Info >= 1 then
|
|
|
558 List_Array_Info (E, Bytes_Big_Endian);
|
|
|
559 end if;
|
|
|
560
|
|
|
561 elsif Is_Type (E) then
|
|
|
562 if List_Representation_Info >= 2 then
|
|
|
563 List_Type_Info (E);
|
|
|
564 end if;
|
|
|
565
|
|
145
|
566 -- Note that formals are not annotated so we skip them here
|
|
|
567
|
|
|
568 elsif Ekind_In (E, E_Constant,
|
|
|
569 E_Loop_Parameter,
|
|
|
570 E_Variable)
|
|
|
571 then
|
|
111
|
572 if List_Representation_Info >= 2 then
|
|
|
573 List_Object_Info (E);
|
|
|
574 end if;
|
|
|
575 end if;
|
|
|
576
|
|
|
577 -- Recurse into nested package, but not if they are package
|
|
|
578 -- renamings (in particular renamings of the enclosing package,
|
|
|
579 -- as for some Java bindings and for generic instances).
|
|
|
580
|
|
|
581 if Ekind (E) = E_Package then
|
|
|
582 if No (Renamed_Object (E)) then
|
|
|
583 List_Entities (E, Bytes_Big_Endian);
|
|
|
584 end if;
|
|
|
585
|
|
|
586 -- Recurse into bodies
|
|
|
587
|
|
145
|
588 elsif Ekind_In (E, E_Package_Body,
|
|
|
589 E_Protected_Body,
|
|
|
590 E_Protected_Type,
|
|
111
|
591 E_Subprogram_Body,
|
|
|
592 E_Task_Body,
|
|
145
|
593 E_Task_Type)
|
|
111
|
594 then
|
|
|
595 List_Entities (E, Bytes_Big_Endian);
|
|
|
596
|
|
|
597 -- Recurse into blocks
|
|
|
598
|
|
|
599 elsif Ekind (E) = E_Block then
|
|
|
600 List_Entities (E, Bytes_Big_Endian);
|
|
|
601 end if;
|
|
|
602 end if;
|
|
|
603
|
|
|
604 E := Next_Entity (E);
|
|
|
605 end loop;
|
|
|
606
|
|
|
607 -- For a package body, the entities of the visible subprograms are
|
|
|
608 -- declared in the corresponding spec. Iterate over its entities in
|
|
|
609 -- order to handle properly the subprogram bodies. Skip bodies in
|
|
|
610 -- subunits, which are listed independently.
|
|
|
611
|
|
|
612 if Ekind (Ent) = E_Package_Body
|
|
|
613 and then Present (Corresponding_Spec (Find_Declaration (Ent)))
|
|
|
614 then
|
|
|
615 E := First_Entity (Corresponding_Spec (Find_Declaration (Ent)));
|
|
|
616 while Present (E) loop
|
|
|
617 if Is_Subprogram (E)
|
|
|
618 and then
|
|
|
619 Nkind (Find_Declaration (E)) = N_Subprogram_Declaration
|
|
|
620 then
|
|
|
621 Body_E := Corresponding_Body (Find_Declaration (E));
|
|
|
622
|
|
|
623 if Present (Body_E)
|
|
|
624 and then
|
|
|
625 Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit
|
|
|
626 then
|
|
|
627 List_Entities (Body_E, Bytes_Big_Endian);
|
|
|
628 end if;
|
|
|
629 end if;
|
|
|
630
|
|
|
631 Next_Entity (E);
|
|
|
632 end loop;
|
|
|
633 end if;
|
|
|
634 end if;
|
|
|
635 end List_Entities;
|
|
|
636
|
|
|
637 -------------------------
|
|
|
638 -- List_GCC_Expression --
|
|
|
639 -------------------------
|
|
|
640
|
|
|
641 procedure List_GCC_Expression (U : Node_Ref_Or_Val) is
|
|
|
642
|
|
|
643 procedure Print_Expr (Val : Node_Ref_Or_Val);
|
|
|
644 -- Internal recursive procedure to print expression
|
|
|
645
|
|
|
646 ----------------
|
|
|
647 -- Print_Expr --
|
|
|
648 ----------------
|
|
|
649
|
|
|
650 procedure Print_Expr (Val : Node_Ref_Or_Val) is
|
|
|
651 begin
|
|
|
652 if Val >= 0 then
|
|
|
653 UI_Write (Val, Decimal);
|
|
|
654
|
|
|
655 else
|
|
|
656 declare
|
|
|
657 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
|
|
|
658
|
|
131
|
659 procedure Unop (S : String);
|
|
|
660 -- Output text for unary operator with S being operator name
|
|
|
661
|
|
111
|
662 procedure Binop (S : String);
|
|
|
663 -- Output text for binary operator with S being operator name
|
|
|
664
|
|
131
|
665 ----------
|
|
|
666 -- Unop --
|
|
|
667 ----------
|
|
|
668
|
|
|
669 procedure Unop (S : String) is
|
|
|
670 begin
|
|
|
671 if List_Representation_Info_To_JSON then
|
|
|
672 Write_Str ("{ ""code"": """);
|
|
|
673 if S (S'Last) = ' ' then
|
|
|
674 Write_Str (S (S'First .. S'Last - 1));
|
|
|
675 else
|
|
|
676 Write_Str (S);
|
|
|
677 end if;
|
|
|
678 Write_Str (""", ""operands"": [ ");
|
|
|
679 Print_Expr (Node.Op1);
|
|
|
680 Write_Str (" ] }");
|
|
|
681 else
|
|
|
682 Write_Str (S);
|
|
|
683 Print_Expr (Node.Op1);
|
|
|
684 end if;
|
|
|
685 end Unop;
|
|
|
686
|
|
111
|
687 -----------
|
|
|
688 -- Binop --
|
|
|
689 -----------
|
|
|
690
|
|
|
691 procedure Binop (S : String) is
|
|
|
692 begin
|
|
131
|
693 if List_Representation_Info_To_JSON then
|
|
|
694 Write_Str ("{ ""code"": """);
|
|
|
695 Write_Str (S (S'First + 1 .. S'Last - 1));
|
|
|
696 Write_Str (""", ""operands"": [ ");
|
|
|
697 Print_Expr (Node.Op1);
|
|
|
698 Write_Str (", ");
|
|
|
699 Print_Expr (Node.Op2);
|
|
|
700 Write_Str (" ] }");
|
|
|
701 else
|
|
|
702 Write_Char ('(');
|
|
|
703 Print_Expr (Node.Op1);
|
|
|
704 Write_Str (S);
|
|
|
705 Print_Expr (Node.Op2);
|
|
|
706 Write_Char (')');
|
|
|
707 end if;
|
|
111
|
708 end Binop;
|
|
|
709
|
|
|
710 -- Start of processing for Print_Expr
|
|
|
711
|
|
|
712 begin
|
|
|
713 case Node.Expr is
|
|
|
714 when Cond_Expr =>
|
|
131
|
715 if List_Representation_Info_To_JSON then
|
|
|
716 Write_Str ("{ ""code"": ""?<>""");
|
|
|
717 Write_Str (", ""operands"": [ ");
|
|
|
718 Print_Expr (Node.Op1);
|
|
|
719 Write_Str (", ");
|
|
|
720 Print_Expr (Node.Op2);
|
|
|
721 Write_Str (", ");
|
|
|
722 Print_Expr (Node.Op3);
|
|
|
723 Write_Str (" ] }");
|
|
|
724 else
|
|
|
725 Write_Str ("(if ");
|
|
|
726 Print_Expr (Node.Op1);
|
|
|
727 Write_Str (" then ");
|
|
|
728 Print_Expr (Node.Op2);
|
|
|
729 Write_Str (" else ");
|
|
|
730 Print_Expr (Node.Op3);
|
|
|
731 Write_Str (" end)");
|
|
|
732 end if;
|
|
111
|
733
|
|
|
734 when Plus_Expr =>
|
|
|
735 Binop (" + ");
|
|
|
736
|
|
|
737 when Minus_Expr =>
|
|
|
738 Binop (" - ");
|
|
|
739
|
|
|
740 when Mult_Expr =>
|
|
|
741 Binop (" * ");
|
|
|
742
|
|
|
743 when Trunc_Div_Expr =>
|
|
|
744 Binop (" /t ");
|
|
|
745
|
|
|
746 when Ceil_Div_Expr =>
|
|
|
747 Binop (" /c ");
|
|
|
748
|
|
|
749 when Floor_Div_Expr =>
|
|
|
750 Binop (" /f ");
|
|
|
751
|
|
|
752 when Trunc_Mod_Expr =>
|
|
|
753 Binop (" modt ");
|
|
|
754
|
|
131
|
755 when Ceil_Mod_Expr =>
|
|
|
756 Binop (" modc ");
|
|
|
757
|
|
111
|
758 when Floor_Mod_Expr =>
|
|
|
759 Binop (" modf ");
|
|
|
760
|
|
|
761 when Exact_Div_Expr =>
|
|
|
762 Binop (" /e ");
|
|
|
763
|
|
|
764 when Negate_Expr =>
|
|
131
|
765 Unop ("-");
|
|
111
|
766
|
|
|
767 when Min_Expr =>
|
|
|
768 Binop (" min ");
|
|
|
769
|
|
|
770 when Max_Expr =>
|
|
|
771 Binop (" max ");
|
|
|
772
|
|
|
773 when Abs_Expr =>
|
|
131
|
774 Unop ("abs ");
|
|
111
|
775
|
|
|
776 when Truth_And_Expr =>
|
|
|
777 Binop (" and ");
|
|
|
778
|
|
|
779 when Truth_Or_Expr =>
|
|
|
780 Binop (" or ");
|
|
|
781
|
|
|
782 when Truth_Xor_Expr =>
|
|
|
783 Binop (" xor ");
|
|
|
784
|
|
|
785 when Truth_Not_Expr =>
|
|
131
|
786 Unop ("not ");
|
|
111
|
787
|
|
|
788 when Lt_Expr =>
|
|
|
789 Binop (" < ");
|
|
|
790
|
|
|
791 when Le_Expr =>
|
|
|
792 Binop (" <= ");
|
|
|
793
|
|
|
794 when Gt_Expr =>
|
|
|
795 Binop (" > ");
|
|
|
796
|
|
|
797 when Ge_Expr =>
|
|
|
798 Binop (" >= ");
|
|
|
799
|
|
|
800 when Eq_Expr =>
|
|
|
801 Binop (" == ");
|
|
|
802
|
|
|
803 when Ne_Expr =>
|
|
|
804 Binop (" != ");
|
|
|
805
|
|
131
|
806 when Bit_And_Expr =>
|
|
|
807 Binop (" & ");
|
|
|
808
|
|
111
|
809 when Discrim_Val =>
|
|
131
|
810 Unop ("#");
|
|
111
|
811
|
|
|
812 when Dynamic_Val =>
|
|
131
|
813 Unop ("var");
|
|
111
|
814 end case;
|
|
|
815 end;
|
|
|
816 end if;
|
|
|
817 end Print_Expr;
|
|
|
818
|
|
|
819 -- Start of processing for List_GCC_Expression
|
|
|
820
|
|
|
821 begin
|
|
|
822 if U = No_Uint then
|
|
131
|
823 Write_Unknown_Val;
|
|
111
|
824 else
|
|
|
825 Print_Expr (U);
|
|
|
826 end if;
|
|
|
827 end List_GCC_Expression;
|
|
|
828
|
|
|
829 -------------------------
|
|
|
830 -- List_Linker_Section --
|
|
|
831 -------------------------
|
|
|
832
|
|
|
833 procedure List_Linker_Section (Ent : Entity_Id) is
|
|
131
|
834 function Expr_Value_S (N : Node_Id) return Node_Id;
|
|
|
835 -- Returns the folded value of the expression. This function is called
|
|
|
836 -- in instances where it has already been determined that the expression
|
|
|
837 -- is static or its value is known at compile time. This version is used
|
|
|
838 -- for string types and returns the corresponding N_String_Literal node.
|
|
|
839 -- NOTE: This is an exact copy of Sem_Eval.Expr_Value_S. Licensing stops
|
|
|
840 -- Repinfo from within Sem_Eval. Once ASIS is removed, and the licenses
|
|
|
841 -- are modified, Repinfo should be able to rely on Sem_Eval.
|
|
|
842
|
|
|
843 ------------------
|
|
|
844 -- Expr_Value_S --
|
|
|
845 ------------------
|
|
|
846
|
|
|
847 function Expr_Value_S (N : Node_Id) return Node_Id is
|
|
|
848 begin
|
|
|
849 if Nkind (N) = N_String_Literal then
|
|
|
850 return N;
|
|
|
851 else
|
|
|
852 pragma Assert (Ekind (Entity (N)) = E_Constant);
|
|
|
853 return Expr_Value_S (Constant_Value (Entity (N)));
|
|
|
854 end if;
|
|
|
855 end Expr_Value_S;
|
|
|
856
|
|
|
857 -- Local variables
|
|
|
858
|
|
|
859 Args : List_Id;
|
|
|
860 Sect : Node_Id;
|
|
|
861
|
|
|
862 -- Start of processing for List_Linker_Section
|
|
111
|
863
|
|
|
864 begin
|
|
|
865 if Present (Linker_Section_Pragma (Ent)) then
|
|
131
|
866 Args := Pragma_Argument_Associations (Linker_Section_Pragma (Ent));
|
|
|
867 Sect := Expr_Value_S (Get_Pragma_Arg (Last (Args)));
|
|
|
868
|
|
|
869 if List_Representation_Info_To_JSON then
|
|
|
870 Write_Line (",");
|
|
|
871 Write_Str (" ""Linker_Section"": """);
|
|
|
872 else
|
|
|
873 Write_Str ("pragma Linker_Section (");
|
|
|
874 List_Name (Ent);
|
|
|
875 Write_Str (", """);
|
|
111
|
876 end if;
|
|
|
877
|
|
131
|
878 pragma Assert (Nkind (Sect) = N_String_Literal);
|
|
|
879 String_To_Name_Buffer (Strval (Sect));
|
|
111
|
880 Write_Str (Name_Buffer (1 .. Name_Len));
|
|
131
|
881 Write_Str ("""");
|
|
|
882 if not List_Representation_Info_To_JSON then
|
|
|
883 Write_Line (");");
|
|
|
884 end if;
|
|
111
|
885 end if;
|
|
|
886 end List_Linker_Section;
|
|
|
887
|
|
131
|
888 -------------------
|
|
|
889 -- List_Location --
|
|
|
890 -------------------
|
|
|
891
|
|
|
892 procedure List_Location (Ent : Entity_Id) is
|
|
|
893 begin
|
|
|
894 pragma Assert (List_Representation_Info_To_JSON);
|
|
|
895 Write_Str (" ""location"": """);
|
|
|
896 Write_Location (Sloc (Ent));
|
|
|
897 Write_Line (""",");
|
|
|
898 end List_Location;
|
|
|
899
|
|
111
|
900 ---------------
|
|
|
901 -- List_Name --
|
|
|
902 ---------------
|
|
|
903
|
|
|
904 procedure List_Name (Ent : Entity_Id) is
|
|
145
|
905 C : Character;
|
|
|
906
|
|
111
|
907 begin
|
|
131
|
908 -- List the qualified name recursively, except
|
|
|
909 -- at compilation unit level in default mode.
|
|
|
910
|
|
|
911 if Is_Compilation_Unit (Ent) then
|
|
|
912 null;
|
|
|
913 elsif not Is_Compilation_Unit (Scope (Ent))
|
|
|
914 or else List_Representation_Info_To_JSON
|
|
|
915 then
|
|
111
|
916 List_Name (Scope (Ent));
|
|
|
917 Write_Char ('.');
|
|
|
918 end if;
|
|
|
919
|
|
|
920 Get_Unqualified_Decoded_Name_String (Chars (Ent));
|
|
|
921 Set_Casing (Unit_Casing);
|
|
145
|
922
|
|
|
923 -- The name of operators needs to be properly escaped for JSON
|
|
|
924
|
|
|
925 for J in 1 .. Name_Len loop
|
|
|
926 C := Name_Buffer (J);
|
|
|
927 if C = '"' and then List_Representation_Info_To_JSON then
|
|
|
928 Write_Char ('\');
|
|
|
929 end if;
|
|
|
930 Write_Char (C);
|
|
|
931 end loop;
|
|
111
|
932 end List_Name;
|
|
|
933
|
|
|
934 ---------------------
|
|
|
935 -- List_Object_Info --
|
|
|
936 ---------------------
|
|
|
937
|
|
|
938 procedure List_Object_Info (Ent : Entity_Id) is
|
|
|
939 begin
|
|
145
|
940 Write_Separator;
|
|
111
|
941
|
|
131
|
942 if List_Representation_Info_To_JSON then
|
|
|
943 Write_Line ("{");
|
|
|
944
|
|
|
945 Write_Str (" ""name"": """);
|
|
|
946 List_Name (Ent);
|
|
|
947 Write_Line (""",");
|
|
|
948 List_Location (Ent);
|
|
|
949
|
|
|
950 Write_Str (" ""Size"": ");
|
|
|
951 Write_Val (Esize (Ent));
|
|
|
952 Write_Line (",");
|
|
|
953
|
|
|
954 Write_Str (" ""Alignment"": ");
|
|
|
955 Write_Val (Alignment (Ent));
|
|
|
956
|
|
|
957 List_Linker_Section (Ent);
|
|
|
958
|
|
|
959 Write_Eol;
|
|
|
960 Write_Line ("}");
|
|
|
961 else
|
|
|
962 Write_Str ("for ");
|
|
|
963 List_Name (Ent);
|
|
|
964 Write_Str ("'Size use ");
|
|
|
965 Write_Val (Esize (Ent));
|
|
|
966 Write_Line (";");
|
|
|
967
|
|
|
968 Write_Str ("for ");
|
|
|
969 List_Name (Ent);
|
|
|
970 Write_Str ("'Alignment use ");
|
|
|
971 Write_Val (Alignment (Ent));
|
|
|
972 Write_Line (";");
|
|
|
973
|
|
|
974 List_Linker_Section (Ent);
|
|
|
975 end if;
|
|
145
|
976
|
|
|
977 -- The type is relevant for an object
|
|
|
978
|
|
|
979 if List_Representation_Info = 4 and then Is_Itype (Etype (Ent)) then
|
|
|
980 Relevant_Entities.Set (Etype (Ent), True);
|
|
|
981 end if;
|
|
111
|
982 end List_Object_Info;
|
|
|
983
|
|
|
984 ----------------------
|
|
|
985 -- List_Record_Info --
|
|
|
986 ----------------------
|
|
|
987
|
|
|
988 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
|
|
|
989 procedure Compute_Max_Length
|
|
|
990 (Ent : Entity_Id;
|
|
|
991 Starting_Position : Uint := Uint_0;
|
|
|
992 Starting_First_Bit : Uint := Uint_0;
|
|
|
993 Prefix_Length : Natural := 0);
|
|
|
994 -- Internal recursive procedure to compute the max length
|
|
|
995
|
|
131
|
996 procedure List_Component_Layout
|
|
|
997 (Ent : Entity_Id;
|
|
|
998 Starting_Position : Uint := Uint_0;
|
|
|
999 Starting_First_Bit : Uint := Uint_0;
|
|
|
1000 Prefix : String := "";
|
|
|
1001 Indent : Natural := 0);
|
|
|
1002 -- Procedure to display the layout of a single component
|
|
|
1003
|
|
111
|
1004 procedure List_Record_Layout
|
|
|
1005 (Ent : Entity_Id;
|
|
|
1006 Starting_Position : Uint := Uint_0;
|
|
|
1007 Starting_First_Bit : Uint := Uint_0;
|
|
|
1008 Prefix : String := "");
|
|
|
1009 -- Internal recursive procedure to display the layout
|
|
|
1010
|
|
131
|
1011 procedure List_Structural_Record_Layout
|
|
|
1012 (Ent : Entity_Id;
|
|
|
1013 Outer_Ent : Entity_Id;
|
|
|
1014 Variant : Node_Id := Empty;
|
|
|
1015 Indent : Natural := 0);
|
|
|
1016 -- Internal recursive procedure to display the structural layout
|
|
|
1017
|
|
145
|
1018 Incomplete_Layout : exception;
|
|
|
1019 -- Exception raised if the layout is incomplete in -gnatc mode
|
|
|
1020
|
|
|
1021 Not_In_Extended_Main : exception;
|
|
|
1022 -- Exception raised when an ancestor is not declared in the main unit
|
|
|
1023
|
|
111
|
1024 Max_Name_Length : Natural := 0;
|
|
|
1025 Max_Spos_Length : Natural := 0;
|
|
|
1026
|
|
|
1027 ------------------------
|
|
|
1028 -- Compute_Max_Length --
|
|
|
1029 ------------------------
|
|
|
1030
|
|
|
1031 procedure Compute_Max_Length
|
|
|
1032 (Ent : Entity_Id;
|
|
|
1033 Starting_Position : Uint := Uint_0;
|
|
|
1034 Starting_First_Bit : Uint := Uint_0;
|
|
|
1035 Prefix_Length : Natural := 0)
|
|
|
1036 is
|
|
|
1037 Comp : Entity_Id;
|
|
|
1038
|
|
|
1039 begin
|
|
|
1040 Comp := First_Component_Or_Discriminant (Ent);
|
|
|
1041 while Present (Comp) loop
|
|
|
1042
|
|
|
1043 -- Skip discriminant in unchecked union (since it is not there!)
|
|
|
1044
|
|
|
1045 if Ekind (Comp) = E_Discriminant
|
|
|
1046 and then Is_Unchecked_Union (Ent)
|
|
|
1047 then
|
|
|
1048 goto Continue;
|
|
|
1049 end if;
|
|
|
1050
|
|
131
|
1051 -- Skip _Parent component in extension (to avoid overlap)
|
|
|
1052
|
|
|
1053 if Chars (Comp) = Name_uParent then
|
|
|
1054 goto Continue;
|
|
|
1055 end if;
|
|
|
1056
|
|
111
|
1057 -- All other cases
|
|
|
1058
|
|
|
1059 declare
|
|
|
1060 Ctyp : constant Entity_Id := Underlying_Type (Etype (Comp));
|
|
|
1061 Bofs : constant Uint := Component_Bit_Offset (Comp);
|
|
|
1062 Npos : Uint;
|
|
|
1063 Fbit : Uint;
|
|
|
1064 Spos : Uint;
|
|
|
1065 Sbit : Uint;
|
|
|
1066
|
|
|
1067 Name_Length : Natural;
|
|
|
1068
|
|
|
1069 begin
|
|
|
1070 Get_Decoded_Name_String (Chars (Comp));
|
|
|
1071 Name_Length := Prefix_Length + Name_Len;
|
|
|
1072
|
|
|
1073 if Rep_Not_Constant (Bofs) then
|
|
|
1074
|
|
|
1075 -- If the record is not packed, then we know that all fields
|
|
|
1076 -- whose position is not specified have starting normalized
|
|
|
1077 -- bit position of zero.
|
|
|
1078
|
|
|
1079 if Unknown_Normalized_First_Bit (Comp)
|
|
|
1080 and then not Is_Packed (Ent)
|
|
|
1081 then
|
|
|
1082 Set_Normalized_First_Bit (Comp, Uint_0);
|
|
|
1083 end if;
|
|
|
1084
|
|
|
1085 UI_Image_Length := 2; -- For "??" marker
|
|
|
1086 else
|
|
|
1087 Npos := Bofs / SSU;
|
|
|
1088 Fbit := Bofs mod SSU;
|
|
|
1089
|
|
|
1090 -- Complete annotation in case not done
|
|
|
1091
|
|
|
1092 if Unknown_Normalized_First_Bit (Comp) then
|
|
|
1093 Set_Normalized_Position (Comp, Npos);
|
|
|
1094 Set_Normalized_First_Bit (Comp, Fbit);
|
|
|
1095 end if;
|
|
|
1096
|
|
|
1097 Spos := Starting_Position + Npos;
|
|
|
1098 Sbit := Starting_First_Bit + Fbit;
|
|
|
1099
|
|
|
1100 if Sbit >= SSU then
|
|
|
1101 Spos := Spos + 1;
|
|
|
1102 Sbit := Sbit - SSU;
|
|
|
1103 end if;
|
|
|
1104
|
|
|
1105 -- If extended information is requested, recurse fully into
|
|
|
1106 -- record components, i.e. skip the outer level.
|
|
|
1107
|
|
|
1108 if List_Representation_Info_Extended
|
|
|
1109 and then Is_Record_Type (Ctyp)
|
|
|
1110 then
|
|
|
1111 Compute_Max_Length (Ctyp, Spos, Sbit, Name_Length + 1);
|
|
|
1112 goto Continue;
|
|
|
1113 end if;
|
|
|
1114
|
|
|
1115 UI_Image (Spos);
|
|
|
1116 end if;
|
|
|
1117
|
|
|
1118 Max_Name_Length := Natural'Max (Max_Name_Length, Name_Length);
|
|
|
1119 Max_Spos_Length :=
|
|
|
1120 Natural'Max (Max_Spos_Length, UI_Image_Length);
|
|
|
1121 end;
|
|
|
1122
|
|
|
1123 <<Continue>>
|
|
|
1124 Next_Component_Or_Discriminant (Comp);
|
|
|
1125 end loop;
|
|
|
1126 end Compute_Max_Length;
|
|
|
1127
|
|
131
|
1128 ---------------------------
|
|
|
1129 -- List_Component_Layout --
|
|
|
1130 ---------------------------
|
|
|
1131
|
|
|
1132 procedure List_Component_Layout
|
|
|
1133 (Ent : Entity_Id;
|
|
|
1134 Starting_Position : Uint := Uint_0;
|
|
|
1135 Starting_First_Bit : Uint := Uint_0;
|
|
|
1136 Prefix : String := "";
|
|
|
1137 Indent : Natural := 0)
|
|
|
1138 is
|
|
|
1139 Esiz : constant Uint := Esize (Ent);
|
|
|
1140 Npos : constant Uint := Normalized_Position (Ent);
|
|
|
1141 Fbit : constant Uint := Normalized_First_Bit (Ent);
|
|
|
1142 Spos : Uint;
|
|
|
1143 Sbit : Uint;
|
|
|
1144 Lbit : Uint;
|
|
|
1145
|
|
|
1146 begin
|
|
|
1147 if List_Representation_Info_To_JSON then
|
|
|
1148 Spaces (Indent);
|
|
|
1149 Write_Line (" {");
|
|
|
1150 Spaces (Indent);
|
|
|
1151 Write_Str (" ""name"": """);
|
|
|
1152 Write_Str (Prefix);
|
|
|
1153 Write_Str (Name_Buffer (1 .. Name_Len));
|
|
|
1154 Write_Line (""",");
|
|
|
1155 if Ekind (Ent) = E_Discriminant then
|
|
|
1156 Spaces (Indent);
|
|
|
1157 Write_Str (" ""discriminant"": ");
|
|
145
|
1158 UI_Write (Discriminant_Number (Ent), Decimal);
|
|
131
|
1159 Write_Line (",");
|
|
|
1160 end if;
|
|
|
1161 Spaces (Indent);
|
|
|
1162 Write_Str (" ""Position"": ");
|
|
|
1163 else
|
|
|
1164 Write_Str (" ");
|
|
|
1165 Write_Str (Prefix);
|
|
|
1166 Write_Str (Name_Buffer (1 .. Name_Len));
|
|
|
1167 Spaces (Max_Name_Length - Prefix'Length - Name_Len);
|
|
|
1168 Write_Str (" at ");
|
|
|
1169 end if;
|
|
|
1170
|
|
|
1171 if Known_Static_Normalized_Position (Ent) then
|
|
|
1172 Spos := Starting_Position + Npos;
|
|
|
1173 Sbit := Starting_First_Bit + Fbit;
|
|
|
1174
|
|
|
1175 if Sbit >= SSU then
|
|
|
1176 Spos := Spos + 1;
|
|
|
1177 end if;
|
|
|
1178
|
|
|
1179 UI_Image (Spos);
|
|
|
1180 Spaces (Max_Spos_Length - UI_Image_Length);
|
|
|
1181 Write_Str (UI_Image_Buffer (1 .. UI_Image_Length));
|
|
|
1182
|
|
|
1183 elsif Known_Normalized_Position (Ent)
|
|
145
|
1184 and then List_Representation_Info >= 3
|
|
131
|
1185 then
|
|
|
1186 Spaces (Max_Spos_Length - 2);
|
|
|
1187
|
|
|
1188 if Starting_Position /= Uint_0 then
|
|
145
|
1189 UI_Write (Starting_Position, Decimal);
|
|
131
|
1190 Write_Str (" + ");
|
|
|
1191 end if;
|
|
|
1192
|
|
|
1193 Write_Val (Npos);
|
|
|
1194
|
|
|
1195 else
|
|
|
1196 Write_Unknown_Val;
|
|
|
1197 end if;
|
|
|
1198
|
|
|
1199 if List_Representation_Info_To_JSON then
|
|
|
1200 Write_Line (",");
|
|
|
1201 Spaces (Indent);
|
|
|
1202 Write_Str (" ""First_Bit"": ");
|
|
|
1203 else
|
|
|
1204 Write_Str (" range ");
|
|
|
1205 end if;
|
|
|
1206
|
|
|
1207 Sbit := Starting_First_Bit + Fbit;
|
|
|
1208
|
|
|
1209 if Sbit >= SSU then
|
|
|
1210 Sbit := Sbit - SSU;
|
|
|
1211 end if;
|
|
|
1212
|
|
145
|
1213 UI_Write (Sbit, Decimal);
|
|
131
|
1214
|
|
|
1215 if List_Representation_Info_To_JSON then
|
|
|
1216 Write_Line (", ");
|
|
|
1217 Spaces (Indent);
|
|
|
1218 Write_Str (" ""Size"": ");
|
|
|
1219 else
|
|
|
1220 Write_Str (" .. ");
|
|
|
1221 end if;
|
|
|
1222
|
|
|
1223 -- Allowing Uint_0 here is an annoying special case. Really this
|
|
|
1224 -- should be a fine Esize value but currently it means unknown,
|
|
|
1225 -- except that we know after gigi has back annotated that a size
|
|
|
1226 -- of zero is real, since otherwise gigi back annotates using
|
|
|
1227 -- No_Uint as the value to indicate unknown.
|
|
|
1228
|
|
|
1229 if (Esize (Ent) = Uint_0 or else Known_Static_Esize (Ent))
|
|
|
1230 and then Known_Static_Normalized_First_Bit (Ent)
|
|
|
1231 then
|
|
|
1232 Lbit := Sbit + Esiz - 1;
|
|
|
1233
|
|
|
1234 if List_Representation_Info_To_JSON then
|
|
145
|
1235 UI_Write (Esiz, Decimal);
|
|
131
|
1236 else
|
|
145
|
1237 if Lbit >= 0 and then Lbit < 10 then
|
|
131
|
1238 Write_Char (' ');
|
|
|
1239 end if;
|
|
|
1240
|
|
145
|
1241 UI_Write (Lbit, Decimal);
|
|
131
|
1242 end if;
|
|
|
1243
|
|
|
1244 -- The test for Esize (Ent) not Uint_0 here is an annoying special
|
|
|
1245 -- case. Officially a value of zero for Esize means unknown, but
|
|
|
1246 -- here we use the fact that we know that gigi annotates Esize with
|
|
|
1247 -- No_Uint, not Uint_0. Really everyone should use No_Uint???
|
|
|
1248
|
|
|
1249 elsif List_Representation_Info < 3
|
|
|
1250 or else (Esize (Ent) /= Uint_0 and then Unknown_Esize (Ent))
|
|
|
1251 then
|
|
|
1252 Write_Unknown_Val;
|
|
|
1253
|
|
|
1254 -- List_Representation >= 3 and Known_Esize (Ent)
|
|
|
1255
|
|
|
1256 else
|
|
|
1257 Write_Val (Esiz, Paren => not List_Representation_Info_To_JSON);
|
|
|
1258
|
|
|
1259 -- If in front-end layout mode, then dynamic size is stored in
|
|
|
1260 -- storage units, so renormalize for output.
|
|
|
1261
|
|
|
1262 if not Back_End_Layout then
|
|
|
1263 Write_Str (" * ");
|
|
|
1264 Write_Int (SSU);
|
|
|
1265 end if;
|
|
|
1266
|
|
|
1267 -- Add appropriate first bit offset
|
|
|
1268
|
|
|
1269 if not List_Representation_Info_To_JSON then
|
|
|
1270 if Sbit = 0 then
|
|
|
1271 Write_Str (" - 1");
|
|
|
1272
|
|
|
1273 elsif Sbit = 1 then
|
|
|
1274 null;
|
|
|
1275
|
|
|
1276 else
|
|
|
1277 Write_Str (" + ");
|
|
|
1278 Write_Int (UI_To_Int (Sbit) - 1);
|
|
|
1279 end if;
|
|
|
1280 end if;
|
|
|
1281 end if;
|
|
|
1282
|
|
|
1283 if List_Representation_Info_To_JSON then
|
|
|
1284 Write_Eol;
|
|
|
1285 Spaces (Indent);
|
|
|
1286 Write_Str (" }");
|
|
|
1287 else
|
|
|
1288 Write_Line (";");
|
|
|
1289 end if;
|
|
145
|
1290
|
|
|
1291 -- The type is relevant for a component
|
|
|
1292
|
|
|
1293 if List_Representation_Info = 4 and then Is_Itype (Etype (Ent)) then
|
|
|
1294 Relevant_Entities.Set (Etype (Ent), True);
|
|
|
1295 end if;
|
|
131
|
1296 end List_Component_Layout;
|
|
|
1297
|
|
111
|
1298 ------------------------
|
|
|
1299 -- List_Record_Layout --
|
|
|
1300 ------------------------
|
|
|
1301
|
|
|
1302 procedure List_Record_Layout
|
|
|
1303 (Ent : Entity_Id;
|
|
|
1304 Starting_Position : Uint := Uint_0;
|
|
|
1305 Starting_First_Bit : Uint := Uint_0;
|
|
|
1306 Prefix : String := "")
|
|
|
1307 is
|
|
131
|
1308 Comp : Entity_Id;
|
|
|
1309 First : Boolean := True;
|
|
111
|
1310
|
|
|
1311 begin
|
|
|
1312 Comp := First_Component_Or_Discriminant (Ent);
|
|
|
1313 while Present (Comp) loop
|
|
|
1314
|
|
|
1315 -- Skip discriminant in unchecked union (since it is not there!)
|
|
|
1316
|
|
|
1317 if Ekind (Comp) = E_Discriminant
|
|
|
1318 and then Is_Unchecked_Union (Ent)
|
|
|
1319 then
|
|
|
1320 goto Continue;
|
|
|
1321 end if;
|
|
|
1322
|
|
131
|
1323 -- Skip _Parent component in extension (to avoid overlap)
|
|
|
1324
|
|
|
1325 if Chars (Comp) = Name_uParent then
|
|
|
1326 goto Continue;
|
|
|
1327 end if;
|
|
|
1328
|
|
111
|
1329 -- All other cases
|
|
|
1330
|
|
|
1331 declare
|
|
|
1332 Ctyp : constant Entity_Id := Underlying_Type (Etype (Comp));
|
|
|
1333 Npos : constant Uint := Normalized_Position (Comp);
|
|
|
1334 Fbit : constant Uint := Normalized_First_Bit (Comp);
|
|
|
1335 Spos : Uint;
|
|
|
1336 Sbit : Uint;
|
|
|
1337
|
|
|
1338 begin
|
|
|
1339 Get_Decoded_Name_String (Chars (Comp));
|
|
|
1340 Set_Casing (Unit_Casing);
|
|
|
1341
|
|
|
1342 -- If extended information is requested, recurse fully into
|
|
|
1343 -- record components, i.e. skip the outer level.
|
|
|
1344
|
|
|
1345 if List_Representation_Info_Extended
|
|
|
1346 and then Is_Record_Type (Ctyp)
|
|
|
1347 and then Known_Static_Normalized_Position (Comp)
|
|
|
1348 and then Known_Static_Normalized_First_Bit (Comp)
|
|
|
1349 then
|
|
|
1350 Spos := Starting_Position + Npos;
|
|
|
1351 Sbit := Starting_First_Bit + Fbit;
|
|
|
1352
|
|
|
1353 if Sbit >= SSU then
|
|
|
1354 Spos := Spos + 1;
|
|
|
1355 Sbit := Sbit - SSU;
|
|
|
1356 end if;
|
|
|
1357
|
|
|
1358 List_Record_Layout (Ctyp,
|
|
|
1359 Spos, Sbit, Prefix & Name_Buffer (1 .. Name_Len) & ".");
|
|
|
1360
|
|
|
1361 goto Continue;
|
|
|
1362 end if;
|
|
|
1363
|
|
131
|
1364 if List_Representation_Info_To_JSON then
|
|
|
1365 if First then
|
|
|
1366 Write_Eol;
|
|
|
1367 First := False;
|
|
111
|
1368 else
|
|
131
|
1369 Write_Line (",");
|
|
111
|
1370 end if;
|
|
|
1371 end if;
|
|
|
1372
|
|
131
|
1373 List_Component_Layout (Comp,
|
|
|
1374 Starting_Position, Starting_First_Bit, Prefix);
|
|
111
|
1375 end;
|
|
|
1376
|
|
|
1377 <<Continue>>
|
|
|
1378 Next_Component_Or_Discriminant (Comp);
|
|
|
1379 end loop;
|
|
|
1380 end List_Record_Layout;
|
|
|
1381
|
|
131
|
1382 -----------------------------------
|
|
|
1383 -- List_Structural_Record_Layout --
|
|
|
1384 -----------------------------------
|
|
|
1385
|
|
|
1386 procedure List_Structural_Record_Layout
|
|
|
1387 (Ent : Entity_Id;
|
|
|
1388 Outer_Ent : Entity_Id;
|
|
|
1389 Variant : Node_Id := Empty;
|
|
|
1390 Indent : Natural := 0)
|
|
|
1391 is
|
|
|
1392 function Derived_Discriminant (Disc : Entity_Id) return Entity_Id;
|
|
|
1393 -- This function assumes that Outer_Ent is an extension of Ent.
|
|
|
1394 -- Disc is a discriminant of Ent that does not itself constrain a
|
|
|
1395 -- discriminant of the parent type of Ent. Return the discriminant
|
|
|
1396 -- of Outer_Ent that ultimately constrains Disc, if any.
|
|
|
1397
|
|
|
1398 ----------------------------
|
|
|
1399 -- Derived_Discriminant --
|
|
|
1400 ----------------------------
|
|
|
1401
|
|
|
1402 function Derived_Discriminant (Disc : Entity_Id) return Entity_Id is
|
|
|
1403 Corr_Disc : Entity_Id;
|
|
|
1404 Derived_Disc : Entity_Id;
|
|
|
1405
|
|
|
1406 begin
|
|
|
1407 Derived_Disc := First_Stored_Discriminant (Outer_Ent);
|
|
|
1408
|
|
|
1409 -- Loop over the discriminants of the extension
|
|
|
1410
|
|
|
1411 while Present (Derived_Disc) loop
|
|
|
1412
|
|
|
1413 -- Check if this discriminant constrains another discriminant.
|
|
|
1414 -- If so, find the ultimately constrained discriminant and
|
|
|
1415 -- compare with the original components in the base type.
|
|
|
1416
|
|
|
1417 if Present (Corresponding_Discriminant (Derived_Disc)) then
|
|
|
1418 Corr_Disc := Corresponding_Discriminant (Derived_Disc);
|
|
|
1419
|
|
|
1420 while Present (Corresponding_Discriminant (Corr_Disc)) loop
|
|
|
1421 Corr_Disc := Corresponding_Discriminant (Corr_Disc);
|
|
|
1422 end loop;
|
|
|
1423
|
|
|
1424 if Original_Record_Component (Corr_Disc) =
|
|
|
1425 Original_Record_Component (Disc)
|
|
|
1426 then
|
|
|
1427 return Derived_Disc;
|
|
|
1428 end if;
|
|
|
1429 end if;
|
|
|
1430
|
|
|
1431 Next_Stored_Discriminant (Derived_Disc);
|
|
|
1432 end loop;
|
|
|
1433
|
|
|
1434 -- Disc is not constrained by a discriminant of Outer_Ent
|
|
|
1435
|
|
|
1436 return Empty;
|
|
|
1437 end Derived_Discriminant;
|
|
|
1438
|
|
|
1439 -- Local declarations
|
|
|
1440
|
|
|
1441 Comp : Node_Id;
|
|
|
1442 Comp_List : Node_Id;
|
|
|
1443 First : Boolean := True;
|
|
|
1444 Var : Node_Id;
|
|
|
1445
|
|
|
1446 -- Start of processing for List_Structural_Record_Layout
|
|
|
1447
|
|
|
1448 begin
|
|
|
1449 -- If we are dealing with a variant, just process the components
|
|
|
1450
|
|
|
1451 if Present (Variant) then
|
|
|
1452 Comp_List := Component_List (Variant);
|
|
|
1453
|
|
|
1454 -- Otherwise, we are dealing with the full record and need to get
|
|
|
1455 -- to its definition in order to retrieve its structural layout.
|
|
|
1456
|
|
|
1457 else
|
|
|
1458 declare
|
|
|
1459 Definition : Node_Id :=
|
|
|
1460 Type_Definition (Declaration_Node (Ent));
|
|
|
1461
|
|
|
1462 Is_Extension : constant Boolean :=
|
|
|
1463 Is_Tagged_Type (Ent)
|
|
|
1464 and then Nkind (Definition) =
|
|
|
1465 N_Derived_Type_Definition;
|
|
|
1466
|
|
|
1467 Disc : Entity_Id;
|
|
|
1468 Listed_Disc : Entity_Id;
|
|
145
|
1469 Parent_Type : Entity_Id;
|
|
131
|
1470
|
|
|
1471 begin
|
|
|
1472 -- If this is an extension, first list the layout of the parent
|
|
|
1473 -- and then proceed to the extension part, if any.
|
|
|
1474
|
|
|
1475 if Is_Extension then
|
|
145
|
1476 Parent_Type := Parent_Subtype (Ent);
|
|
|
1477 if No (Parent_Type) then
|
|
|
1478 raise Incomplete_Layout;
|
|
|
1479 end if;
|
|
|
1480
|
|
|
1481 if Is_Private_Type (Parent_Type) then
|
|
|
1482 Parent_Type := Full_View (Parent_Type);
|
|
|
1483 pragma Assert (Present (Parent_Type));
|
|
|
1484 end if;
|
|
|
1485
|
|
|
1486 Parent_Type := Base_Type (Parent_Type);
|
|
|
1487 if not In_Extended_Main_Source_Unit (Parent_Type) then
|
|
|
1488 raise Not_In_Extended_Main;
|
|
|
1489 end if;
|
|
|
1490
|
|
|
1491 List_Structural_Record_Layout (Parent_Type, Outer_Ent);
|
|
131
|
1492 First := False;
|
|
|
1493
|
|
|
1494 if Present (Record_Extension_Part (Definition)) then
|
|
|
1495 Definition := Record_Extension_Part (Definition);
|
|
|
1496 end if;
|
|
|
1497 end if;
|
|
|
1498
|
|
|
1499 -- If the record has discriminants and is not an unchecked
|
|
|
1500 -- union, then display them now.
|
|
|
1501
|
|
|
1502 if Has_Discriminants (Ent)
|
|
|
1503 and then not Is_Unchecked_Union (Ent)
|
|
|
1504 then
|
|
|
1505 Disc := First_Stored_Discriminant (Ent);
|
|
|
1506 while Present (Disc) loop
|
|
|
1507
|
|
|
1508 -- If this is a record extension and the discriminant is
|
|
|
1509 -- the renaming of another discriminant, skip it.
|
|
|
1510
|
|
|
1511 if Is_Extension
|
|
|
1512 and then Present (Corresponding_Discriminant (Disc))
|
|
|
1513 then
|
|
|
1514 goto Continue_Disc;
|
|
|
1515 end if;
|
|
|
1516
|
|
|
1517 -- If this is the parent type of an extension, retrieve
|
|
|
1518 -- the derived discriminant from the extension, if any.
|
|
|
1519
|
|
|
1520 if Ent /= Outer_Ent then
|
|
|
1521 Listed_Disc := Derived_Discriminant (Disc);
|
|
|
1522
|
|
|
1523 if No (Listed_Disc) then
|
|
|
1524 goto Continue_Disc;
|
|
|
1525 end if;
|
|
|
1526 else
|
|
|
1527 Listed_Disc := Disc;
|
|
|
1528 end if;
|
|
|
1529
|
|
|
1530 Get_Decoded_Name_String (Chars (Listed_Disc));
|
|
|
1531 Set_Casing (Unit_Casing);
|
|
|
1532
|
|
|
1533 if First then
|
|
|
1534 Write_Eol;
|
|
|
1535 First := False;
|
|
|
1536 else
|
|
|
1537 Write_Line (",");
|
|
|
1538 end if;
|
|
|
1539
|
|
|
1540 List_Component_Layout (Listed_Disc, Indent => Indent);
|
|
|
1541
|
|
|
1542 <<Continue_Disc>>
|
|
|
1543 Next_Stored_Discriminant (Disc);
|
|
|
1544 end loop;
|
|
|
1545 end if;
|
|
|
1546
|
|
|
1547 Comp_List := Component_List (Definition);
|
|
|
1548 end;
|
|
|
1549 end if;
|
|
|
1550
|
|
|
1551 -- Bail out for the null record
|
|
|
1552
|
|
|
1553 if No (Comp_List) then
|
|
|
1554 return;
|
|
|
1555 end if;
|
|
|
1556
|
|
|
1557 -- Now deal with the regular components, if any
|
|
|
1558
|
|
|
1559 if Present (Component_Items (Comp_List)) then
|
|
|
1560 Comp := First_Non_Pragma (Component_Items (Comp_List));
|
|
|
1561 while Present (Comp) loop
|
|
|
1562
|
|
|
1563 -- Skip _Parent component in extension (to avoid overlap)
|
|
|
1564
|
|
|
1565 if Chars (Defining_Identifier (Comp)) = Name_uParent then
|
|
|
1566 goto Continue_Comp;
|
|
|
1567 end if;
|
|
|
1568
|
|
|
1569 Get_Decoded_Name_String (Chars (Defining_Identifier (Comp)));
|
|
|
1570 Set_Casing (Unit_Casing);
|
|
|
1571
|
|
|
1572 if First then
|
|
|
1573 Write_Eol;
|
|
|
1574 First := False;
|
|
|
1575 else
|
|
|
1576 Write_Line (",");
|
|
|
1577 end if;
|
|
|
1578
|
|
|
1579 List_Component_Layout
|
|
|
1580 (Defining_Identifier (Comp), Indent => Indent);
|
|
|
1581
|
|
|
1582 <<Continue_Comp>>
|
|
|
1583 Next_Non_Pragma (Comp);
|
|
|
1584 end loop;
|
|
|
1585 end if;
|
|
|
1586
|
|
|
1587 -- We are done if there is no variant part
|
|
|
1588
|
|
|
1589 if No (Variant_Part (Comp_List)) then
|
|
|
1590 return;
|
|
|
1591 end if;
|
|
|
1592
|
|
|
1593 Write_Eol;
|
|
|
1594 Spaces (Indent);
|
|
|
1595 Write_Line (" ],");
|
|
|
1596 Spaces (Indent);
|
|
|
1597 Write_Str (" ""variant"" : [");
|
|
|
1598
|
|
|
1599 -- Otherwise we recurse on each variant
|
|
|
1600
|
|
|
1601 Var := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
|
|
|
1602 First := True;
|
|
|
1603 while Present (Var) loop
|
|
|
1604 if First then
|
|
|
1605 Write_Eol;
|
|
|
1606 First := False;
|
|
|
1607 else
|
|
|
1608 Write_Line (",");
|
|
|
1609 end if;
|
|
|
1610
|
|
|
1611 Spaces (Indent);
|
|
|
1612 Write_Line (" {");
|
|
|
1613 Spaces (Indent);
|
|
|
1614 Write_Str (" ""present"": ");
|
|
|
1615 Write_Val (Present_Expr (Var));
|
|
|
1616 Write_Line (",");
|
|
|
1617 Spaces (Indent);
|
|
|
1618 Write_Str (" ""record"": [");
|
|
|
1619
|
|
|
1620 List_Structural_Record_Layout (Ent, Outer_Ent, Var, Indent + 4);
|
|
|
1621
|
|
|
1622 Write_Eol;
|
|
|
1623 Spaces (Indent);
|
|
|
1624 Write_Line (" ]");
|
|
|
1625 Spaces (Indent);
|
|
|
1626 Write_Str (" }");
|
|
|
1627 Next_Non_Pragma (Var);
|
|
|
1628 end loop;
|
|
|
1629 end List_Structural_Record_Layout;
|
|
|
1630
|
|
111
|
1631 -- Start of processing for List_Record_Info
|
|
|
1632
|
|
|
1633 begin
|
|
145
|
1634 Write_Separator;
|
|
131
|
1635
|
|
|
1636 if List_Representation_Info_To_JSON then
|
|
|
1637 Write_Line ("{");
|
|
|
1638 end if;
|
|
|
1639
|
|
145
|
1640 List_Common_Type_Info (Ent);
|
|
111
|
1641
|
|
|
1642 -- First find out max line length and max starting position
|
|
|
1643 -- length, for the purpose of lining things up nicely.
|
|
|
1644
|
|
|
1645 Compute_Max_Length (Ent);
|
|
|
1646
|
|
|
1647 -- Then do actual output based on those values
|
|
|
1648
|
|
131
|
1649 if List_Representation_Info_To_JSON then
|
|
|
1650 Write_Line (",");
|
|
|
1651 Write_Str (" ""record"": [");
|
|
|
1652
|
|
145
|
1653 -- ??? We can output structural layout only for base types fully
|
|
|
1654 -- declared in the extended main source unit for the time being,
|
|
|
1655 -- because otherwise declarations might not be processed at all.
|
|
|
1656
|
|
131
|
1657 if Is_Base_Type (Ent) then
|
|
145
|
1658 begin
|
|
|
1659 List_Structural_Record_Layout (Ent, Ent);
|
|
|
1660
|
|
|
1661 exception
|
|
|
1662 when Incomplete_Layout
|
|
|
1663 | Not_In_Extended_Main
|
|
|
1664 =>
|
|
|
1665 List_Record_Layout (Ent);
|
|
|
1666
|
|
|
1667 when others =>
|
|
|
1668 raise Program_Error;
|
|
|
1669 end;
|
|
131
|
1670 else
|
|
|
1671 List_Record_Layout (Ent);
|
|
|
1672 end if;
|
|
|
1673
|
|
|
1674 Write_Eol;
|
|
|
1675 Write_Str (" ]");
|
|
|
1676 else
|
|
|
1677 Write_Str ("for ");
|
|
|
1678 List_Name (Ent);
|
|
|
1679 Write_Line (" use record");
|
|
|
1680
|
|
|
1681 List_Record_Layout (Ent);
|
|
|
1682
|
|
|
1683 Write_Line ("end record;");
|
|
|
1684 end if;
|
|
111
|
1685
|
|
|
1686 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
|
|
131
|
1687
|
|
|
1688 List_Linker_Section (Ent);
|
|
|
1689
|
|
|
1690 if List_Representation_Info_To_JSON then
|
|
|
1691 Write_Eol;
|
|
|
1692 Write_Line ("}");
|
|
|
1693 end if;
|
|
145
|
1694
|
|
|
1695 -- The type is relevant for a record subtype
|
|
|
1696
|
|
|
1697 if List_Representation_Info = 4
|
|
|
1698 and then not Is_Base_Type (Ent)
|
|
|
1699 and then Is_Itype (Etype (Ent))
|
|
|
1700 then
|
|
|
1701 Relevant_Entities.Set (Etype (Ent), True);
|
|
|
1702 end if;
|
|
111
|
1703 end List_Record_Info;
|
|
|
1704
|
|
|
1705 -------------------
|
|
|
1706 -- List_Rep_Info --
|
|
|
1707 -------------------
|
|
|
1708
|
|
|
1709 procedure List_Rep_Info (Bytes_Big_Endian : Boolean) is
|
|
|
1710 Col : Nat;
|
|
|
1711
|
|
|
1712 begin
|
|
|
1713 if List_Representation_Info /= 0
|
|
|
1714 or else List_Representation_Info_Mechanisms
|
|
|
1715 then
|
|
145
|
1716 -- For the normal case, we output a single JSON stream
|
|
|
1717
|
|
|
1718 if not List_Representation_Info_To_File
|
|
|
1719 and then List_Representation_Info_To_JSON
|
|
|
1720 then
|
|
|
1721 Write_Line ("[");
|
|
|
1722 Need_Separator := False;
|
|
|
1723 end if;
|
|
|
1724
|
|
111
|
1725 for U in Main_Unit .. Last_Unit loop
|
|
|
1726 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
|
|
|
1727 Unit_Casing := Identifier_Casing (Source_Index (U));
|
|
|
1728
|
|
145
|
1729 if List_Representation_Info = 4 then
|
|
|
1730 Relevant_Entities.Reset;
|
|
|
1731 end if;
|
|
|
1732
|
|
111
|
1733 -- Normal case, list to standard output
|
|
|
1734
|
|
|
1735 if not List_Representation_Info_To_File then
|
|
131
|
1736 if not List_Representation_Info_To_JSON then
|
|
|
1737 Write_Eol;
|
|
|
1738 Write_Str ("Representation information for unit ");
|
|
|
1739 Write_Unit_Name (Unit_Name (U));
|
|
|
1740 Col := Column;
|
|
|
1741 Write_Eol;
|
|
|
1742
|
|
|
1743 for J in 1 .. Col - 1 loop
|
|
|
1744 Write_Char ('-');
|
|
|
1745 end loop;
|
|
|
1746
|
|
|
1747 Write_Eol;
|
|
145
|
1748 Need_Separator := True;
|
|
131
|
1749 end if;
|
|
|
1750
|
|
111
|
1751 List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
|
|
|
1752
|
|
|
1753 -- List representation information to file
|
|
|
1754
|
|
|
1755 else
|
|
|
1756 Create_Repinfo_File_Access.all
|
|
|
1757 (Get_Name_String (File_Name (Source_Index (U))));
|
|
|
1758 Set_Special_Output (Write_Info_Line'Access);
|
|
145
|
1759 if List_Representation_Info_To_JSON then
|
|
|
1760 Write_Line ("[");
|
|
|
1761 end if;
|
|
|
1762 Need_Separator := False;
|
|
111
|
1763 List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
|
|
145
|
1764 if List_Representation_Info_To_JSON then
|
|
|
1765 Write_Line ("]");
|
|
|
1766 end if;
|
|
|
1767 Cancel_Special_Output;
|
|
111
|
1768 Close_Repinfo_File_Access.all;
|
|
|
1769 end if;
|
|
|
1770 end if;
|
|
|
1771 end loop;
|
|
145
|
1772
|
|
|
1773 if not List_Representation_Info_To_File
|
|
|
1774 and then List_Representation_Info_To_JSON
|
|
|
1775 then
|
|
|
1776 Write_Line ("]");
|
|
|
1777 end if;
|
|
111
|
1778 end if;
|
|
|
1779 end List_Rep_Info;
|
|
|
1780
|
|
|
1781 -------------------------------
|
|
|
1782 -- List_Scalar_Storage_Order --
|
|
|
1783 -------------------------------
|
|
|
1784
|
|
|
1785 procedure List_Scalar_Storage_Order
|
|
|
1786 (Ent : Entity_Id;
|
|
|
1787 Bytes_Big_Endian : Boolean)
|
|
|
1788 is
|
|
|
1789 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean);
|
|
|
1790 -- Show attribute definition clause for Attr_Name (an endianness
|
|
|
1791 -- attribute), depending on whether or not the endianness is reversed
|
|
|
1792 -- compared to native endianness.
|
|
|
1793
|
|
|
1794 ---------------
|
|
|
1795 -- List_Attr --
|
|
|
1796 ---------------
|
|
|
1797
|
|
|
1798 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean) is
|
|
|
1799 begin
|
|
131
|
1800 if List_Representation_Info_To_JSON then
|
|
|
1801 Write_Line (",");
|
|
|
1802 Write_Str (" """);
|
|
|
1803 Write_Str (Attr_Name);
|
|
|
1804 Write_Str (""": ""System.");
|
|
|
1805 else
|
|
|
1806 Write_Str ("for ");
|
|
|
1807 List_Name (Ent);
|
|
|
1808 Write_Char (''');
|
|
|
1809 Write_Str (Attr_Name);
|
|
|
1810 Write_Str (" use System.");
|
|
|
1811 end if;
|
|
111
|
1812
|
|
|
1813 if Bytes_Big_Endian xor Is_Reversed then
|
|
|
1814 Write_Str ("High");
|
|
|
1815 else
|
|
|
1816 Write_Str ("Low");
|
|
|
1817 end if;
|
|
|
1818
|
|
131
|
1819 Write_Str ("_Order_First");
|
|
|
1820 if List_Representation_Info_To_JSON then
|
|
|
1821 Write_Str ("""");
|
|
|
1822 else
|
|
|
1823 Write_Line (";");
|
|
|
1824 end if;
|
|
111
|
1825 end List_Attr;
|
|
|
1826
|
|
|
1827 List_SSO : constant Boolean :=
|
|
|
1828 Has_Rep_Item (Ent, Name_Scalar_Storage_Order)
|
|
|
1829 or else SSO_Set_Low_By_Default (Ent)
|
|
|
1830 or else SSO_Set_High_By_Default (Ent);
|
|
145
|
1831 -- Scalar_Storage_Order is displayed if specified explicitly or set by
|
|
|
1832 -- Default_Scalar_Storage_Order.
|
|
111
|
1833
|
|
|
1834 -- Start of processing for List_Scalar_Storage_Order
|
|
|
1835
|
|
|
1836 begin
|
|
|
1837 -- For record types, list Bit_Order if not default, or if SSO is shown
|
|
|
1838
|
|
145
|
1839 -- Also, when -gnatR4 is in effect always list bit order and scalar
|
|
|
1840 -- storage order explicitly, so that you don't need to know the native
|
|
|
1841 -- endianness of the target for which the output was produced in order
|
|
|
1842 -- to interpret it.
|
|
|
1843
|
|
111
|
1844 if Is_Record_Type (Ent)
|
|
145
|
1845 and then (List_SSO
|
|
|
1846 or else Reverse_Bit_Order (Ent)
|
|
|
1847 or else List_Representation_Info = 4)
|
|
111
|
1848 then
|
|
|
1849 List_Attr ("Bit_Order", Reverse_Bit_Order (Ent));
|
|
|
1850 end if;
|
|
|
1851
|
|
|
1852 -- List SSO if required. If not, then storage is supposed to be in
|
|
|
1853 -- native order.
|
|
|
1854
|
|
145
|
1855 if List_SSO or else List_Representation_Info = 4 then
|
|
111
|
1856 List_Attr ("Scalar_Storage_Order", Reverse_Storage_Order (Ent));
|
|
|
1857 else
|
|
|
1858 pragma Assert (not Reverse_Storage_Order (Ent));
|
|
|
1859 null;
|
|
|
1860 end if;
|
|
|
1861 end List_Scalar_Storage_Order;
|
|
|
1862
|
|
145
|
1863 --------------------------
|
|
|
1864 -- List_Subprogram_Info --
|
|
|
1865 --------------------------
|
|
|
1866
|
|
|
1867 procedure List_Subprogram_Info (Ent : Entity_Id) is
|
|
|
1868 First : Boolean := True;
|
|
|
1869 Plen : Natural;
|
|
|
1870 Form : Entity_Id;
|
|
|
1871
|
|
|
1872 begin
|
|
|
1873 Write_Separator;
|
|
|
1874
|
|
|
1875 if List_Representation_Info_To_JSON then
|
|
|
1876 Write_Line ("{");
|
|
|
1877 Write_Str (" ""name"": """);
|
|
|
1878 List_Name (Ent);
|
|
|
1879 Write_Line (""",");
|
|
|
1880 List_Location (Ent);
|
|
|
1881
|
|
|
1882 Write_Str (" ""Convention"": """);
|
|
|
1883 else
|
|
|
1884 case Ekind (Ent) is
|
|
|
1885 when E_Function =>
|
|
|
1886 Write_Str ("function ");
|
|
|
1887
|
|
|
1888 when E_Operator =>
|
|
|
1889 Write_Str ("operator ");
|
|
|
1890
|
|
|
1891 when E_Procedure =>
|
|
|
1892 Write_Str ("procedure ");
|
|
|
1893
|
|
|
1894 when E_Subprogram_Type =>
|
|
|
1895 Write_Str ("type ");
|
|
|
1896
|
|
|
1897 when E_Entry
|
|
|
1898 | E_Entry_Family
|
|
|
1899 =>
|
|
|
1900 Write_Str ("entry ");
|
|
|
1901
|
|
|
1902 when others =>
|
|
|
1903 raise Program_Error;
|
|
|
1904 end case;
|
|
|
1905
|
|
|
1906 List_Name (Ent);
|
|
|
1907 Write_Str (" declared at ");
|
|
|
1908 Write_Location (Sloc (Ent));
|
|
|
1909 Write_Eol;
|
|
|
1910
|
|
|
1911 Write_Str ("convention : ");
|
|
|
1912 end if;
|
|
|
1913
|
|
|
1914 case Convention (Ent) is
|
|
|
1915 when Convention_Ada =>
|
|
|
1916 Write_Str ("Ada");
|
|
|
1917
|
|
|
1918 when Convention_Ada_Pass_By_Copy =>
|
|
|
1919 Write_Str ("Ada_Pass_By_Copy");
|
|
|
1920
|
|
|
1921 when Convention_Ada_Pass_By_Reference =>
|
|
|
1922 Write_Str ("Ada_Pass_By_Reference");
|
|
|
1923
|
|
|
1924 when Convention_Intrinsic =>
|
|
|
1925 Write_Str ("Intrinsic");
|
|
|
1926
|
|
|
1927 when Convention_Entry =>
|
|
|
1928 Write_Str ("Entry");
|
|
|
1929
|
|
|
1930 when Convention_Protected =>
|
|
|
1931 Write_Str ("Protected");
|
|
|
1932
|
|
|
1933 when Convention_Assembler =>
|
|
|
1934 Write_Str ("Assembler");
|
|
|
1935
|
|
|
1936 when Convention_C =>
|
|
|
1937 Write_Str ("C");
|
|
|
1938
|
|
|
1939 when Convention_COBOL =>
|
|
|
1940 Write_Str ("COBOL");
|
|
|
1941
|
|
|
1942 when Convention_CPP =>
|
|
|
1943 Write_Str ("C++");
|
|
|
1944
|
|
|
1945 when Convention_Fortran =>
|
|
|
1946 Write_Str ("Fortran");
|
|
|
1947
|
|
|
1948 when Convention_Stdcall =>
|
|
|
1949 Write_Str ("Stdcall");
|
|
|
1950
|
|
|
1951 when Convention_Stubbed =>
|
|
|
1952 Write_Str ("Stubbed");
|
|
|
1953 end case;
|
|
|
1954
|
|
|
1955 if List_Representation_Info_To_JSON then
|
|
|
1956 Write_Line (""",");
|
|
|
1957 Write_Str (" ""formal"": [");
|
|
|
1958 else
|
|
|
1959 Write_Eol;
|
|
|
1960 end if;
|
|
|
1961
|
|
|
1962 -- Find max length of formal name
|
|
|
1963
|
|
|
1964 Plen := 0;
|
|
|
1965 Form := First_Formal (Ent);
|
|
|
1966 while Present (Form) loop
|
|
|
1967 Get_Unqualified_Decoded_Name_String (Chars (Form));
|
|
|
1968
|
|
|
1969 if Name_Len > Plen then
|
|
|
1970 Plen := Name_Len;
|
|
|
1971 end if;
|
|
|
1972
|
|
|
1973 Next_Formal (Form);
|
|
|
1974 end loop;
|
|
|
1975
|
|
|
1976 -- Output formals and mechanisms
|
|
|
1977
|
|
|
1978 Form := First_Formal (Ent);
|
|
|
1979 while Present (Form) loop
|
|
|
1980 Get_Unqualified_Decoded_Name_String (Chars (Form));
|
|
|
1981 Set_Casing (Unit_Casing);
|
|
|
1982
|
|
|
1983 if List_Representation_Info_To_JSON then
|
|
|
1984 if First then
|
|
|
1985 Write_Eol;
|
|
|
1986 First := False;
|
|
|
1987 else
|
|
|
1988 Write_Line (",");
|
|
|
1989 end if;
|
|
|
1990
|
|
|
1991 Write_Line (" {");
|
|
|
1992 Write_Str (" ""name"": """);
|
|
|
1993 Write_Str (Name_Buffer (1 .. Name_Len));
|
|
|
1994 Write_Line (""",");
|
|
|
1995
|
|
|
1996 Write_Str (" ""mechanism"": """);
|
|
|
1997 Write_Mechanism (Mechanism (Form));
|
|
|
1998 Write_Line ("""");
|
|
|
1999 Write_Str (" }");
|
|
|
2000 else
|
|
|
2001 while Name_Len <= Plen loop
|
|
|
2002 Name_Len := Name_Len + 1;
|
|
|
2003 Name_Buffer (Name_Len) := ' ';
|
|
|
2004 end loop;
|
|
|
2005
|
|
|
2006 Write_Str (" ");
|
|
|
2007 Write_Str (Name_Buffer (1 .. Plen + 1));
|
|
|
2008 Write_Str (": passed by ");
|
|
|
2009
|
|
|
2010 Write_Mechanism (Mechanism (Form));
|
|
|
2011 Write_Eol;
|
|
|
2012 end if;
|
|
|
2013
|
|
|
2014 Next_Formal (Form);
|
|
|
2015 end loop;
|
|
|
2016
|
|
|
2017 if List_Representation_Info_To_JSON then
|
|
|
2018 Write_Eol;
|
|
|
2019 Write_Str (" ]");
|
|
|
2020 end if;
|
|
|
2021
|
|
|
2022 if Ekind (Ent) = E_Function then
|
|
|
2023 if List_Representation_Info_To_JSON then
|
|
|
2024 Write_Line (",");
|
|
|
2025 Write_Str (" ""mechanism"": """);
|
|
|
2026 Write_Mechanism (Mechanism (Ent));
|
|
|
2027 Write_Str ("""");
|
|
|
2028 else
|
|
|
2029 Write_Str ("returns by ");
|
|
|
2030 Write_Mechanism (Mechanism (Ent));
|
|
|
2031 Write_Eol;
|
|
|
2032 end if;
|
|
|
2033 end if;
|
|
|
2034
|
|
|
2035 if not Is_Entry (Ent) then
|
|
|
2036 List_Linker_Section (Ent);
|
|
|
2037 end if;
|
|
|
2038
|
|
|
2039 if List_Representation_Info_To_JSON then
|
|
|
2040 Write_Eol;
|
|
|
2041 Write_Line ("}");
|
|
|
2042 end if;
|
|
|
2043 end List_Subprogram_Info;
|
|
|
2044
|
|
111
|
2045 --------------------
|
|
|
2046 -- List_Type_Info --
|
|
|
2047 --------------------
|
|
|
2048
|
|
|
2049 procedure List_Type_Info (Ent : Entity_Id) is
|
|
|
2050 begin
|
|
145
|
2051 Write_Separator;
|
|
111
|
2052
|
|
131
|
2053 if List_Representation_Info_To_JSON then
|
|
145
|
2054 Write_Line ("{");
|
|
131
|
2055 end if;
|
|
111
|
2056
|
|
145
|
2057 List_Common_Type_Info (Ent);
|
|
|
2058
|
|
111
|
2059 -- Special stuff for fixed-point
|
|
|
2060
|
|
|
2061 if Is_Fixed_Point_Type (Ent) then
|
|
|
2062
|
|
|
2063 -- Write small (always a static constant)
|
|
|
2064
|
|
131
|
2065 if List_Representation_Info_To_JSON then
|
|
|
2066 Write_Line (",");
|
|
|
2067 Write_Str (" ""Small"": ");
|
|
|
2068 UR_Write (Small_Value (Ent));
|
|
|
2069 else
|
|
|
2070 Write_Str ("for ");
|
|
|
2071 List_Name (Ent);
|
|
|
2072 Write_Str ("'Small use ");
|
|
|
2073 UR_Write (Small_Value (Ent));
|
|
|
2074 Write_Line (";");
|
|
|
2075 end if;
|
|
111
|
2076
|
|
|
2077 -- Write range if static
|
|
|
2078
|
|
|
2079 declare
|
|
|
2080 R : constant Node_Id := Scalar_Range (Ent);
|
|
|
2081
|
|
|
2082 begin
|
|
|
2083 if Nkind (Low_Bound (R)) = N_Real_Literal
|
|
|
2084 and then
|
|
|
2085 Nkind (High_Bound (R)) = N_Real_Literal
|
|
|
2086 then
|
|
131
|
2087 if List_Representation_Info_To_JSON then
|
|
|
2088 Write_Line (",");
|
|
|
2089 Write_Str (" ""Range"": [ ");
|
|
|
2090 UR_Write (Realval (Low_Bound (R)));
|
|
|
2091 Write_Str (", ");
|
|
|
2092 UR_Write (Realval (High_Bound (R)));
|
|
|
2093 Write_Str (" ]");
|
|
|
2094 else
|
|
|
2095 Write_Str ("for ");
|
|
|
2096 List_Name (Ent);
|
|
|
2097 Write_Str ("'Range use ");
|
|
|
2098 UR_Write (Realval (Low_Bound (R)));
|
|
|
2099 Write_Str (" .. ");
|
|
|
2100 UR_Write (Realval (High_Bound (R)));
|
|
|
2101 Write_Line (";");
|
|
|
2102 end if;
|
|
111
|
2103 end if;
|
|
|
2104 end;
|
|
|
2105 end if;
|
|
145
|
2106
|
|
|
2107 List_Linker_Section (Ent);
|
|
|
2108
|
|
|
2109 if List_Representation_Info_To_JSON then
|
|
|
2110 Write_Eol;
|
|
|
2111 Write_Line ("}");
|
|
|
2112 end if;
|
|
111
|
2113 end List_Type_Info;
|
|
|
2114
|
|
|
2115 ----------------------
|
|
|
2116 -- Rep_Not_Constant --
|
|
|
2117 ----------------------
|
|
|
2118
|
|
|
2119 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is
|
|
|
2120 begin
|
|
|
2121 if Val = No_Uint or else Val < 0 then
|
|
|
2122 return True;
|
|
|
2123 else
|
|
|
2124 return False;
|
|
|
2125 end if;
|
|
|
2126 end Rep_Not_Constant;
|
|
|
2127
|
|
|
2128 ---------------
|
|
|
2129 -- Rep_Value --
|
|
|
2130 ---------------
|
|
|
2131
|
|
131
|
2132 function Rep_Value (Val : Node_Ref_Or_Val; D : Discrim_List) return Uint is
|
|
|
2133
|
|
111
|
2134 function B (Val : Boolean) return Uint;
|
|
|
2135 -- Returns Uint_0 for False, Uint_1 for True
|
|
|
2136
|
|
|
2137 function T (Val : Node_Ref_Or_Val) return Boolean;
|
|
|
2138 -- Returns True for 0, False for any non-zero (i.e. True)
|
|
|
2139
|
|
|
2140 function V (Val : Node_Ref_Or_Val) return Uint;
|
|
|
2141 -- Internal recursive routine to evaluate tree
|
|
|
2142
|
|
|
2143 function W (Val : Uint) return Word;
|
|
|
2144 -- Convert Val to Word, assuming Val is always in the Int range. This
|
|
|
2145 -- is a helper function for the evaluation of bitwise expressions like
|
|
|
2146 -- Bit_And_Expr, for which there is no direct support in uintp. Uint
|
|
|
2147 -- values out of the Int range are expected to be seen in such
|
|
|
2148 -- expressions only with overflowing byte sizes around, introducing
|
|
|
2149 -- inherent unreliabilities in computations anyway.
|
|
|
2150
|
|
|
2151 -------
|
|
|
2152 -- B --
|
|
|
2153 -------
|
|
|
2154
|
|
|
2155 function B (Val : Boolean) return Uint is
|
|
|
2156 begin
|
|
|
2157 if Val then
|
|
|
2158 return Uint_1;
|
|
|
2159 else
|
|
|
2160 return Uint_0;
|
|
|
2161 end if;
|
|
|
2162 end B;
|
|
|
2163
|
|
|
2164 -------
|
|
|
2165 -- T --
|
|
|
2166 -------
|
|
|
2167
|
|
|
2168 function T (Val : Node_Ref_Or_Val) return Boolean is
|
|
|
2169 begin
|
|
|
2170 if V (Val) = 0 then
|
|
|
2171 return False;
|
|
|
2172 else
|
|
|
2173 return True;
|
|
|
2174 end if;
|
|
|
2175 end T;
|
|
|
2176
|
|
|
2177 -------
|
|
|
2178 -- V --
|
|
|
2179 -------
|
|
|
2180
|
|
|
2181 function V (Val : Node_Ref_Or_Val) return Uint is
|
|
|
2182 L, R, Q : Uint;
|
|
|
2183
|
|
|
2184 begin
|
|
|
2185 if Val >= 0 then
|
|
|
2186 return Val;
|
|
|
2187
|
|
|
2188 else
|
|
|
2189 declare
|
|
|
2190 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
|
|
|
2191
|
|
|
2192 begin
|
|
|
2193 case Node.Expr is
|
|
|
2194 when Cond_Expr =>
|
|
|
2195 if T (Node.Op1) then
|
|
|
2196 return V (Node.Op2);
|
|
|
2197 else
|
|
|
2198 return V (Node.Op3);
|
|
|
2199 end if;
|
|
|
2200
|
|
|
2201 when Plus_Expr =>
|
|
|
2202 return V (Node.Op1) + V (Node.Op2);
|
|
|
2203
|
|
|
2204 when Minus_Expr =>
|
|
|
2205 return V (Node.Op1) - V (Node.Op2);
|
|
|
2206
|
|
|
2207 when Mult_Expr =>
|
|
|
2208 return V (Node.Op1) * V (Node.Op2);
|
|
|
2209
|
|
|
2210 when Trunc_Div_Expr =>
|
|
|
2211 return V (Node.Op1) / V (Node.Op2);
|
|
|
2212
|
|
|
2213 when Ceil_Div_Expr =>
|
|
|
2214 return
|
|
|
2215 UR_Ceiling
|
|
|
2216 (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
|
|
|
2217
|
|
|
2218 when Floor_Div_Expr =>
|
|
|
2219 return
|
|
|
2220 UR_Floor
|
|
|
2221 (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
|
|
|
2222
|
|
|
2223 when Trunc_Mod_Expr =>
|
|
|
2224 return V (Node.Op1) rem V (Node.Op2);
|
|
|
2225
|
|
|
2226 when Floor_Mod_Expr =>
|
|
|
2227 return V (Node.Op1) mod V (Node.Op2);
|
|
|
2228
|
|
|
2229 when Ceil_Mod_Expr =>
|
|
|
2230 L := V (Node.Op1);
|
|
|
2231 R := V (Node.Op2);
|
|
|
2232 Q := UR_Ceiling (L / UR_From_Uint (R));
|
|
|
2233 return L - R * Q;
|
|
|
2234
|
|
|
2235 when Exact_Div_Expr =>
|
|
|
2236 return V (Node.Op1) / V (Node.Op2);
|
|
|
2237
|
|
|
2238 when Negate_Expr =>
|
|
|
2239 return -V (Node.Op1);
|
|
|
2240
|
|
|
2241 when Min_Expr =>
|
|
|
2242 return UI_Min (V (Node.Op1), V (Node.Op2));
|
|
|
2243
|
|
|
2244 when Max_Expr =>
|
|
|
2245 return UI_Max (V (Node.Op1), V (Node.Op2));
|
|
|
2246
|
|
|
2247 when Abs_Expr =>
|
|
|
2248 return UI_Abs (V (Node.Op1));
|
|
|
2249
|
|
|
2250 when Truth_And_Expr =>
|
|
|
2251 return B (T (Node.Op1) and then T (Node.Op2));
|
|
|
2252
|
|
|
2253 when Truth_Or_Expr =>
|
|
|
2254 return B (T (Node.Op1) or else T (Node.Op2));
|
|
|
2255
|
|
|
2256 when Truth_Xor_Expr =>
|
|
|
2257 return B (T (Node.Op1) xor T (Node.Op2));
|
|
|
2258
|
|
|
2259 when Truth_Not_Expr =>
|
|
|
2260 return B (not T (Node.Op1));
|
|
|
2261
|
|
|
2262 when Bit_And_Expr =>
|
|
|
2263 L := V (Node.Op1);
|
|
|
2264 R := V (Node.Op2);
|
|
|
2265 return UI_From_Int (Int (W (L) and W (R)));
|
|
|
2266
|
|
|
2267 when Lt_Expr =>
|
|
|
2268 return B (V (Node.Op1) < V (Node.Op2));
|
|
|
2269
|
|
|
2270 when Le_Expr =>
|
|
|
2271 return B (V (Node.Op1) <= V (Node.Op2));
|
|
|
2272
|
|
|
2273 when Gt_Expr =>
|
|
|
2274 return B (V (Node.Op1) > V (Node.Op2));
|
|
|
2275
|
|
|
2276 when Ge_Expr =>
|
|
|
2277 return B (V (Node.Op1) >= V (Node.Op2));
|
|
|
2278
|
|
|
2279 when Eq_Expr =>
|
|
|
2280 return B (V (Node.Op1) = V (Node.Op2));
|
|
|
2281
|
|
|
2282 when Ne_Expr =>
|
|
|
2283 return B (V (Node.Op1) /= V (Node.Op2));
|
|
|
2284
|
|
|
2285 when Discrim_Val =>
|
|
|
2286 declare
|
|
|
2287 Sub : constant Int := UI_To_Int (Node.Op1);
|
|
|
2288 begin
|
|
|
2289 pragma Assert (Sub in D'Range);
|
|
|
2290 return D (Sub);
|
|
|
2291 end;
|
|
|
2292
|
|
|
2293 when Dynamic_Val =>
|
|
|
2294 return No_Uint;
|
|
|
2295 end case;
|
|
|
2296 end;
|
|
|
2297 end if;
|
|
|
2298 end V;
|
|
|
2299
|
|
|
2300 -------
|
|
|
2301 -- W --
|
|
|
2302 -------
|
|
|
2303
|
|
|
2304 -- We use an unchecked conversion to map Int values to their Word
|
|
|
2305 -- bitwise equivalent, which we could not achieve with a normal type
|
|
|
2306 -- conversion for negative Ints. We want bitwise equivalents because W
|
|
|
2307 -- is used as a helper for bit operators like Bit_And_Expr, and can be
|
|
|
2308 -- called for negative Ints in the context of aligning expressions like
|
|
|
2309 -- X+Align & -Align.
|
|
|
2310
|
|
|
2311 function W (Val : Uint) return Word is
|
|
|
2312 function To_Word is new Ada.Unchecked_Conversion (Int, Word);
|
|
|
2313 begin
|
|
|
2314 return To_Word (UI_To_Int (Val));
|
|
|
2315 end W;
|
|
|
2316
|
|
|
2317 -- Start of processing for Rep_Value
|
|
|
2318
|
|
|
2319 begin
|
|
|
2320 if Val = No_Uint then
|
|
|
2321 return No_Uint;
|
|
|
2322
|
|
|
2323 else
|
|
|
2324 return V (Val);
|
|
|
2325 end if;
|
|
|
2326 end Rep_Value;
|
|
|
2327
|
|
|
2328 ------------
|
|
|
2329 -- Spaces --
|
|
|
2330 ------------
|
|
|
2331
|
|
|
2332 procedure Spaces (N : Natural) is
|
|
|
2333 begin
|
|
|
2334 for J in 1 .. N loop
|
|
|
2335 Write_Char (' ');
|
|
|
2336 end loop;
|
|
|
2337 end Spaces;
|
|
|
2338
|
|
|
2339 ---------------
|
|
|
2340 -- Tree_Read --
|
|
|
2341 ---------------
|
|
|
2342
|
|
|
2343 procedure Tree_Read is
|
|
|
2344 begin
|
|
|
2345 Rep_Table.Tree_Read;
|
|
|
2346 end Tree_Read;
|
|
|
2347
|
|
|
2348 ----------------
|
|
|
2349 -- Tree_Write --
|
|
|
2350 ----------------
|
|
|
2351
|
|
|
2352 procedure Tree_Write is
|
|
|
2353 begin
|
|
|
2354 Rep_Table.Tree_Write;
|
|
|
2355 end Tree_Write;
|
|
|
2356
|
|
|
2357 ---------------------
|
|
|
2358 -- Write_Info_Line --
|
|
|
2359 ---------------------
|
|
|
2360
|
|
|
2361 procedure Write_Info_Line (S : String) is
|
|
|
2362 begin
|
|
|
2363 Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1));
|
|
|
2364 end Write_Info_Line;
|
|
|
2365
|
|
|
2366 ---------------------
|
|
|
2367 -- Write_Mechanism --
|
|
|
2368 ---------------------
|
|
|
2369
|
|
|
2370 procedure Write_Mechanism (M : Mechanism_Type) is
|
|
|
2371 begin
|
|
|
2372 case M is
|
|
|
2373 when 0 =>
|
|
|
2374 Write_Str ("default");
|
|
|
2375
|
|
|
2376 when -1 =>
|
|
|
2377 Write_Str ("copy");
|
|
|
2378
|
|
|
2379 when -2 =>
|
|
|
2380 Write_Str ("reference");
|
|
|
2381
|
|
|
2382 when others =>
|
|
|
2383 raise Program_Error;
|
|
|
2384 end case;
|
|
|
2385 end Write_Mechanism;
|
|
|
2386
|
|
145
|
2387 ---------------------
|
|
|
2388 -- Write_Separator --
|
|
|
2389 ---------------------
|
|
|
2390
|
|
|
2391 procedure Write_Separator is
|
|
|
2392 begin
|
|
|
2393 if Need_Separator then
|
|
|
2394 if List_Representation_Info_To_JSON then
|
|
|
2395 Write_Line (",");
|
|
|
2396 else
|
|
|
2397 Write_Eol;
|
|
|
2398 end if;
|
|
|
2399 else
|
|
|
2400 Need_Separator := True;
|
|
|
2401 end if;
|
|
|
2402 end Write_Separator;
|
|
|
2403
|
|
131
|
2404 -----------------------
|
|
|
2405 -- Write_Unknown_Val --
|
|
|
2406 -----------------------
|
|
|
2407
|
|
|
2408 procedure Write_Unknown_Val is
|
|
|
2409 begin
|
|
|
2410 if List_Representation_Info_To_JSON then
|
|
|
2411 Write_Str ("""??""");
|
|
|
2412 else
|
|
|
2413 Write_Str ("??");
|
|
|
2414 end if;
|
|
|
2415 end Write_Unknown_Val;
|
|
|
2416
|
|
111
|
2417 ---------------
|
|
|
2418 -- Write_Val --
|
|
|
2419 ---------------
|
|
|
2420
|
|
|
2421 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is
|
|
|
2422 begin
|
|
|
2423 if Rep_Not_Constant (Val) then
|
|
|
2424 if List_Representation_Info < 3 or else Val = No_Uint then
|
|
131
|
2425 Write_Unknown_Val;
|
|
111
|
2426
|
|
|
2427 else
|
|
|
2428 if Paren then
|
|
|
2429 Write_Char ('(');
|
|
|
2430 end if;
|
|
|
2431
|
|
|
2432 if Back_End_Layout then
|
|
|
2433 List_GCC_Expression (Val);
|
|
|
2434 else
|
|
|
2435 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
|
|
|
2436 end if;
|
|
|
2437
|
|
|
2438 if Paren then
|
|
|
2439 Write_Char (')');
|
|
|
2440 end if;
|
|
|
2441 end if;
|
|
|
2442
|
|
|
2443 else
|
|
145
|
2444 UI_Write (Val, Decimal);
|
|
111
|
2445 end if;
|
|
|
2446 end Write_Val;
|
|
|
2447
|
|
|
2448 end Repinfo;
|
