]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/ada/repinfo.adb
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
c++: Handle multiple aggregate overloads [PR95319].
[thirdparty/gcc.git] / gcc / ada / repinfo.adb
CommitLineData
19235870
RK		 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- R E P I N F O --
6-- --
7-- B o d y --
8-- --
1d005acc 9-- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
19235870
RK		 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- --
748086b7 13-- ware Foundation; either version 3, or (at your option) any later ver- --
19235870
RK		 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 --
748086b7
JJ		 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-- --
19235870 27-- GNAT was originally developed by the GNAT team at New York University. --
71ff80dc 28-- Extensive contributions were provided by Ada Core Technologies Inc. --
19235870
RK		 29-- --
30------------------------------------------------------------------------------
31
851e9f19 32with Alloc;
d9f8616e
AC		 33with Atree; use Atree;
34with Casing; use Casing;
35with Debug; use Debug;
36with Einfo; use Einfo;
37with Lib; use Lib;
38with Namet; use Namet;
19992053 39with Nlists; use Nlists;
d9f8616e
AC		 40with Opt; use Opt;
41with Output; use Output;
42with Sem_Aux; use Sem_Aux;
43with Sinfo; use Sinfo;
44with Sinput; use Sinput;
45with Snames; use Snames;
19992053 46with Stringt; use Stringt;
851e9f19 47with Table;
d9f8616e
AC		 48with Uname; use Uname;
49with Urealp; use Urealp;
19235870 50
5e61ef09
TQ		 51with Ada.Unchecked_Conversion;
52
b5f581cd
EB		 53with GNAT.HTable;
54
19235870
RK		 55package 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.
fbf5a39b 61
19235870 62 ---------------------------------------
e45f84a5 63 -- Representation of GCC Expressions --
19235870
RK		 64 ---------------------------------------
65
5e61ef09
TQ		 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.
19235870 69
5e61ef09
TQ		 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.
19235870
RK		 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
1c28fe3a
RD		 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
19235870
RK		 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
19235870 114 Unit_Casing : Casing_Type;
d436b30d
AC		 115 -- Identifier casing for current unit. This is set by List_Rep_Info for
116 -- each unit, before calling subprograms which may read it.
19235870 117
b5d3d113
EB		 118 Need_Separator : Boolean;
119 -- Set True if a separator is needed before outputting any information for
120 -- the current entity.
fbf5a39b 121
89beb653
HK		 122 ------------------------------
123 -- Set of Relevant Entities --
124 ------------------------------
b5f581cd
EB		 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
143
fbf5a39b
AC		 144 -----------------------
145 -- Local Subprograms --
146 -----------------------
19235870
RK		 147
148 function Back_End_Layout return Boolean;
5e61ef09
TQ		 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)
19235870 152
1e60643a 153 procedure List_Entities
558fbeb0 154 (Ent : Entity_Id;
1e60643a
AC		 155 Bytes_Big_Endian : Boolean;
156 In_Subprogram : Boolean := False);
5e61ef09
TQ		 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.
1e60643a
AC		 160 -- When recursing within a subprogram body, Is_Subprogram suppresses
161 -- duplicate information about signature.
19235870
RK		 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
d9f8616e 167 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
19235870
RK		 168 -- List representation info for array type Ent
169
6f65c7ee
EB		 170 procedure List_Common_Type_Info (Ent : Entity_Id);
171 -- List common type info (name, size, alignment) for type Ent
172
19992053
AC		 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
1e7629b8
EB		 177 procedure List_Location (Ent : Entity_Id);
178 -- List location information for Ent
179
19235870
RK		 180 procedure List_Object_Info (Ent : Entity_Id);
181 -- List representation info for object Ent
182
d9f8616e 183 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
19235870
RK		 184 -- List representation info for record type Ent
185
d9f8616e
AC		 186 procedure List_Scalar_Storage_Order
187 (Ent : Entity_Id;
188 Bytes_Big_Endian : Boolean);
7ed57189
AC		 189 -- List scalar storage order information for record or array type Ent.
190 -- Also includes bit order information for record types, if necessary.
d9f8616e 191
6f65c7ee
EB		 192 procedure List_Subprogram_Info (Ent : Entity_Id);
193 -- List subprogram info for subprogram Ent
194
19235870
RK		 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
fbf5a39b
AC		 202 procedure Spaces (N : Natural);
203 -- Output given number of spaces
204
07fc65c4 205 procedure Write_Info_Line (S : String);
5e61ef09
TQ		 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.
07fc65c4 211
fbf5a39b
AC		 212 procedure Write_Mechanism (M : Mechanism_Type);
213 -- Writes symbolic string for mechanism represented by M
214
b5d3d113
EB		 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
76b382d9
EB		 219 procedure Write_Unknown_Val;
220 -- Writes symbolic string for an unknown or non-representable value
221
19235870
RK		 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
5e61ef09
TQ		 225 -- flag Paren is set, then the output is surrounded in parentheses if it is
226 -- other than a simple value.
19235870
RK		 227
228 ---------------------
229 -- Back_End_Layout --
230 ---------------------
231
232 function Back_End_Layout return Boolean is
233 begin
0f9ca030
EB		 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.
19235870
RK		 236
237 return Rep_Table.Last > 0;
238 end Back_End_Layout;
239
240 ------------------------
241 -- Create_Discrim_Ref --
242 ------------------------
243
a4c1cd80 244 function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref is
19235870 245 begin
1d6f10a1
TQ		 246 return Create_Node
247 (Expr => Discrim_Val,
248 Op1 => Discriminant_Number (Discr));
19235870
RK		 249 end Create_Discrim_Ref;
250
251 ---------------------------
252 -- Create_Dynamic_SO_Ref --
253 ---------------------------
254
a4c1cd80 255 function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is
19235870 256 begin
1d6f10a1
TQ		 257 Dynamic_SO_Entity_Table.Append (E);
258 return UI_From_Int (-Dynamic_SO_Entity_Table.Last);
19235870
RK		 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;
a4c1cd80 269 Op3 : Node_Ref_Or_Val := No_Uint) return Node_Ref
19235870 270 is
19235870 271 begin
1d6f10a1
TQ		 272 Rep_Table.Append (
273 (Expr => Expr,
274 Op1 => Op1,
275 Op2 => Op2,
276 Op3 => Op3));
277 return UI_From_Int (-Rep_Table.Last);
19235870
RK		 278 end Create_Node;
279
b5f581cd
EB		 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
19235870
RK		 289 ---------------------------
290 -- Get_Dynamic_SO_Entity --
291 ---------------------------
292
a4c1cd80 293 function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is
19235870
RK		 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
d9f8616e 330 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
19235870 331 begin
b5d3d113 332 Write_Separator;
1e7629b8
EB		 333
334 if List_Representation_Info_To_JSON then
335 Write_Line ("{");
336 end if;
337
6f65c7ee 338 List_Common_Type_Info (Ent);
7672ab42 339
1e7629b8
EB		 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;
d9f8616e
AC		 351
352 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
7672ab42
EB		 353
354 List_Linker_Section (Ent);
1e7629b8
EB		 355
356 if List_Representation_Info_To_JSON then
357 Write_Eol;
358 Write_Line ("}");
359 end if;
3c488e6c
EB		 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;
19235870
RK		 368 end List_Array_Info;
369
6f65c7ee
EB		 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
19235870
RK		 445 -------------------
446 -- List_Entities --
447 -------------------
448
1e60643a 449 procedure List_Entities
558fbeb0 450 (Ent : Entity_Id;
1e60643a
AC		 451 Bytes_Big_Endian : Boolean;
452 In_Subprogram : Boolean := False)
453 is
fbf5a39b
AC		 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;
a4c1cd80 467
fbf5a39b
AC		 468 begin
469 Decl := Parent (E);
fbf5a39b 470 while Present (Decl)
1155ae01 471 and then Nkind (Decl) /= N_Package_Body
fbf5a39b
AC		 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
19235870
RK		 482
483 begin
d3879a5a
RD		 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.
fbf5a39b 487
d3879a5a
RD		 488 if Present (Ent)
489 and then Nkind (Declaration_Node (Ent)) not in N_Renaming_Declaration
022c9dfe 490 and then not Is_Ignored_Ghost_Entity (Ent)
d3879a5a 491 then
fbf5a39b 492 -- If entity is a subprogram and we are listing mechanisms,
1e60643a
AC		 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.
fbf5a39b
AC		 496
497 if List_Representation_Info_Mechanisms
498 and then (Is_Subprogram (Ent)
19992053
AC		 499 or else Ekind (Ent) = E_Entry
500 or else Ekind (Ent) = E_Entry_Family)
1e60643a 501 and then not In_Subprogram
fbf5a39b 502 then
6f65c7ee 503 List_Subprogram_Info (Ent);
fbf5a39b
AC		 504 end if;
505
19235870
RK		 506 E := First_Entity (Ent);
507 while Present (E) loop
5e61ef09 508 -- We list entities that come from source (excluding private or
b5f581cd
EB		 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.
fbf5a39b 514
944e24a3
EB		 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)))))
fbf5a39b
AC		 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))))
b5f581cd
EB		 524 or else (List_Representation_Info = 4
525 and then Relevant_Entities.Get (E))
07fc65c4
GB		 526 or else Debug_Flag_AA
527 then
19992053 528 if Is_Subprogram (E) then
19992053 529 if List_Representation_Info_Mechanisms then
6f65c7ee 530 List_Subprogram_Info (E);
19992053
AC		 531 end if;
532
1e60643a
AC		 533 -- Recurse into entities local to subprogram
534
535 List_Entities (E, Bytes_Big_Endian, True);
536
19992053
AC		 537 elsif Ekind_In (E, E_Entry,
538 E_Entry_Family,
539 E_Subprogram_Type)
fbf5a39b
AC		 540 then
541 if List_Representation_Info_Mechanisms then
6f65c7ee 542 List_Subprogram_Info (E);
fbf5a39b
AC		 543 end if;
544
545 elsif Is_Record_Type (E) then
546 if List_Representation_Info >= 1 then
d9f8616e 547 List_Record_Info (E, Bytes_Big_Endian);
fbf5a39b 548 end if;
19235870 549
3c488e6c
EB		 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
19235870 556 elsif Is_Array_Type (E) then
fbf5a39b 557 if List_Representation_Info >= 1 then
d9f8616e 558 List_Array_Info (E, Bytes_Big_Endian);
fbf5a39b 559 end if;
19235870 560
fbf5a39b
AC		 561 elsif Is_Type (E) then
562 if List_Representation_Info >= 2 then
19235870 563 List_Type_Info (E);
fbf5a39b 564 end if;
19235870 565
fb95bfcc 566 -- Note that formals are not annotated so we skip them here
19992053 567
134f52b9
HK		 568 elsif Ekind_In (E, E_Constant,
569 E_Loop_Parameter,
570 E_Variable)
fb95bfcc 571 then
fbf5a39b 572 if List_Representation_Info >= 2 then
19235870
RK		 573 List_Object_Info (E);
574 end if;
575 end if;
576
5e61ef09
TQ		 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).
19235870 580
07fc65c4
GB		 581 if Ekind (E) = E_Package then
582 if No (Renamed_Object (E)) then
d9f8616e 583 List_Entities (E, Bytes_Big_Endian);
07fc65c4
GB		 584 end if;
585
586 -- Recurse into bodies
587
134f52b9
HK		 588 elsif Ekind_In (E, E_Package_Body,
589 E_Protected_Body,
590 E_Protected_Type,
19992053 591 E_Subprogram_Body,
19992053 592 E_Task_Body,
134f52b9 593 E_Task_Type)
19235870 594 then
d9f8616e 595 List_Entities (E, Bytes_Big_Endian);
07fc65c4
GB		 596
597 -- Recurse into blocks
598
599 elsif Ekind (E) = E_Block then
d9f8616e 600 List_Entities (E, Bytes_Big_Endian);
19235870
RK		 601 end if;
602 end if;
603
604 E := Next_Entity (E);
605 end loop;
fbf5a39b 606
5e61ef09
TQ		 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.
fbf5a39b
AC		 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)));
fbf5a39b
AC		 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
d9f8616e 627 List_Entities (Body_E, Bytes_Big_Endian);
fbf5a39b
AC		 628 end if;
629 end if;
630
631 Next_Entity (E);
632 end loop;
633 end if;
19235870
RK		 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
fbf5a39b 643 procedure Print_Expr (Val : Node_Ref_Or_Val);
19235870
RK		 644 -- Internal recursive procedure to print expression
645
fbf5a39b
AC		 646 ----------------
647 -- Print_Expr --
648 ----------------
649
650 procedure Print_Expr (Val : Node_Ref_Or_Val) is
19235870
RK		 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
7672ab42
EB		 659 procedure Unop (S : String);
660 -- Output text for unary operator with S being operator name
661
19235870
RK		 662 procedure Binop (S : String);
663 -- Output text for binary operator with S being operator name
664
7672ab42
EB		 665 ----------
666 -- Unop --
667 ----------
668
669 procedure Unop (S : String) is
670 begin
1e7629b8
EB		 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;
7672ab42
EB		 685 end Unop;
686
fbf5a39b
AC		 687 -----------
688 -- Binop --
689 -----------
690
19235870
RK		 691 procedure Binop (S : String) is
692 begin
1e7629b8
EB		 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;
19235870
RK		 708 end Binop;
709
fbf5a39b 710 -- Start of processing for Print_Expr
19235870
RK		 711
712 begin
713 case Node.Expr is
714 when Cond_Expr =>
1e7629b8
EB		 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;
19235870
RK		 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
19235870
RK		 755 when Ceil_Mod_Expr =>
756 Binop (" modc ");
757
7672ab42
EB		 758 when Floor_Mod_Expr =>
759 Binop (" modf ");
760
19235870
RK		 761 when Exact_Div_Expr =>
762 Binop (" /e ");
763
764 when Negate_Expr =>
7672ab42 765 Unop ("-");
19235870
RK		 766
767 when Min_Expr =>
768 Binop (" min ");
769
770 when Max_Expr =>
771 Binop (" max ");
772
773 when Abs_Expr =>
7672ab42 774 Unop ("abs ");
19235870 775
19235870
RK		 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 =>
7672ab42 786 Unop ("not ");
5e61ef09 787
19235870
RK		 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
7672ab42
EB		 806 when Bit_And_Expr =>
807 Binop (" & ");
808
19235870 809 when Discrim_Val =>
575e47bf 810 Unop ("#");
e45f84a5
EB		 811
812 when Dynamic_Val =>
575e47bf 813 Unop ("var");
19235870
RK		 814 end case;
815 end;
816 end if;
fbf5a39b 817 end Print_Expr;
19235870
RK		 818
819 -- Start of processing for List_GCC_Expression
820
821 begin
822 if U = No_Uint then
76b382d9 823 Write_Unknown_Val;
19235870 824 else
fbf5a39b 825 Print_Expr (U);
19235870
RK		 826 end if;
827 end List_GCC_Expression;
828
19992053
AC		 829 -------------------------
830 -- List_Linker_Section --
831 -------------------------
832
833 procedure List_Linker_Section (Ent : Entity_Id) is
24161618
HK		 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
19992053
AC		 863
864 begin
865 if Present (Linker_Section_Pragma (Ent)) then
24161618
HK		 866 Args := Pragma_Argument_Associations (Linker_Section_Pragma (Ent));
867 Sect := Expr_Value_S (Get_Pragma_Arg (Last (Args)));
868
1e7629b8
EB		 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 (", """);
876 end if;
19992053 877
24161618
HK		 878 pragma Assert (Nkind (Sect) = N_String_Literal);
879 String_To_Name_Buffer (Strval (Sect));
19992053 880 Write_Str (Name_Buffer (1 .. Name_Len));
1e7629b8
EB		 881 Write_Str ("""");
882 if not List_Representation_Info_To_JSON then
883 Write_Line (");");
884 end if;
19992053
AC		 885 end if;
886 end List_Linker_Section;
887
1e7629b8
EB		 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
19235870
RK		 900 ---------------
901 -- List_Name --
902 ---------------
903
904 procedure List_Name (Ent : Entity_Id) is
fb95bfcc
EB		 905 C : Character;
906
19235870 907 begin
1e7629b8
EB		 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
19235870
RK		 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);
fb95bfcc
EB		 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;
19235870
RK		 932 end List_Name;
933
934 ---------------------
935 -- List_Object_Info --
936 ---------------------
937
938 procedure List_Object_Info (Ent : Entity_Id) is
939 begin
b5d3d113 940 Write_Separator;
19235870 941
1e7629b8
EB		 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);
19235870 949
1e7629b8
EB		 950 Write_Str (" ""Size"": ");
951 Write_Val (Esize (Ent));
952 Write_Line (",");
7672ab42 953
1e7629b8
EB		 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;
3c488e6c
EB		 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;
19235870
RK		 982 end List_Object_Info;
983
984 ----------------------
985 -- List_Record_Info --
986 ----------------------
987
d9f8616e 988 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
1c912574
AC		 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
7883c42e
EB		 996 procedure List_Component_Layout
997 (Ent : Entity_Id;
998 Starting_Position : Uint := Uint_0;
999 Starting_First_Bit : Uint := Uint_0;
1e7629b8
EB		 1000 Prefix : String := "";
1001 Indent : Natural := 0);
7883c42e
EB		 1002 -- Procedure to display the layout of a single component
1003
1c912574
AC		 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
1e7629b8 1011 procedure List_Structural_Record_Layout
0f9ca030
EB		 1012 (Ent : Entity_Id;
1013 Outer_Ent : Entity_Id;
1014 Variant : Node_Id := Empty;
1015 Indent : Natural := 0);
1e7629b8
EB		 1016 -- Internal recursive procedure to display the structural layout
1017
abbc4546
EB		 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
1c912574
AC		 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
3815f967 1037 Comp : Entity_Id;
19235870 1038
1c912574
AC		 1039 begin
1040 Comp := First_Component_Or_Discriminant (Ent);
1041 while Present (Comp) loop
19235870 1042
1c912574 1043 -- Skip discriminant in unchecked union (since it is not there!)
19235870 1044
1c912574
AC		 1045 if Ekind (Comp) = E_Discriminant
1046 and then Is_Unchecked_Union (Ent)
1047 then
1048 goto Continue;
1049 end if;
19235870 1050
c8e95568
EB		 1051 -- Skip _Parent component in extension (to avoid overlap)
1052
1053 if Chars (Comp) = Name_uParent then
1054 goto Continue;
1055 end if;
1056
1c912574 1057 -- All other cases
19235870 1058
1c912574
AC		 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;
3815f967 1066
1c912574 1067 Name_Length : Natural;
3815f967 1068
1c912574
AC		 1069 begin
1070 Get_Decoded_Name_String (Chars (Comp));
1071 Name_Length := Prefix_Length + Name_Len;
19235870 1072
1c912574 1073 if Rep_Not_Constant (Bofs) then
19235870 1074
1c912574
AC		 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.
3fbbbd1e 1078
1c912574
AC		 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;
19235870 1084
1c912574
AC		 1085 UI_Image_Length := 2; -- For "??" marker
1086 else
1087 Npos := Bofs / SSU;
1088 Fbit := Bofs mod SSU;
19235870 1089
1c912574 1090 -- Complete annotation in case not done
19235870 1091
1c912574
AC		 1092 if Unknown_Normalized_First_Bit (Comp) then
1093 Set_Normalized_Position (Comp, Npos);
1094 Set_Normalized_First_Bit (Comp, Fbit);
1095 end if;
cc3a2986 1096
1c912574
AC		 1097 Spos := Starting_Position + Npos;
1098 Sbit := Starting_First_Bit + Fbit;
3815f967 1099
1c912574
AC		 1100 if Sbit >= SSU then
1101 Spos := Spos + 1;
1102 Sbit := Sbit - SSU;
1103 end if;
07fc65c4 1104
1c912574
AC		 1105 -- If extended information is requested, recurse fully into
1106 -- record components, i.e. skip the outer level.
74a78a4f 1107
1c912574
AC		 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;
19235870 1114
1c912574 1115 UI_Image (Spos);
74a78a4f 1116 end if;
3fbbbd1e 1117
1c912574
AC		 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;
19235870 1122
1c912574
AC		 1123 <<Continue>>
1124 Next_Component_Or_Discriminant (Comp);
1125 end loop;
1126 end Compute_Max_Length;
a9a5b8ac 1127
7883c42e
EB		 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;
1e7629b8
EB		 1136 Prefix : String := "";
1137 Indent : Natural := 0)
7883c42e
EB		 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
1e7629b8
EB		 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 (""",");
0f9ca030
EB		 1155 if Ekind (Ent) = E_Discriminant then
1156 Spaces (Indent);
1157 Write_Str (" ""discriminant"": ");
f9534f4b 1158 UI_Write (Discriminant_Number (Ent), Decimal);
0f9ca030
EB		 1159 Write_Line (",");
1160 end if;
1e7629b8
EB		 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;
7883c42e
EB		 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)
b5f581cd 1184 and then List_Representation_Info >= 3
7883c42e
EB		 1185 then
1186 Spaces (Max_Spos_Length - 2);
1187
1188 if Starting_Position /= Uint_0 then
f9534f4b 1189 UI_Write (Starting_Position, Decimal);
7883c42e
EB		 1190 Write_Str (" + ");
1191 end if;
1192
1193 Write_Val (Npos);
1194
1195 else
1196 Write_Unknown_Val;
1197 end if;
1198
1e7629b8
EB		 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
7883c42e
EB		 1207 Sbit := Starting_First_Bit + Fbit;
1208
1209 if Sbit >= SSU then
1210 Sbit := Sbit - SSU;
1211 end if;
1212
f9534f4b 1213 UI_Write (Sbit, Decimal);
1e7629b8
EB		 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;
7883c42e 1222
f537fc00
HK		 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.
7883c42e
EB		 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
1e7629b8 1234 if List_Representation_Info_To_JSON then
f9534f4b 1235 UI_Write (Esiz, Decimal);
1e7629b8 1236 else
683ccd05 1237 if Lbit >= 0 and then Lbit < 10 then
1e7629b8
EB		 1238 Write_Char (' ');
1239 end if;
7883c42e 1240
f9534f4b 1241 UI_Write (Lbit, Decimal);
1e7629b8 1242 end if;
7883c42e 1243
f537fc00
HK		 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???
7883c42e
EB		 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
1e7629b8 1257 Write_Val (Esiz, Paren => not List_Representation_Info_To_JSON);
7883c42e 1258
f537fc00
HK		 1259 -- If in front-end layout mode, then dynamic size is stored in
1260 -- storage units, so renormalize for output.
7883c42e
EB		 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
1e7629b8
EB		 1269 if not List_Representation_Info_To_JSON then
1270 if Sbit = 0 then
1271 Write_Str (" - 1");
7883c42e 1272
1e7629b8
EB		 1273 elsif Sbit = 1 then
1274 null;
7883c42e 1275
1e7629b8
EB		 1276 else
1277 Write_Str (" + ");
1278 Write_Int (UI_To_Int (Sbit) - 1);
1279 end if;
7883c42e
EB		 1280 end if;
1281 end if;
1282
1e7629b8
EB		 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;
3c488e6c
EB		 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;
7883c42e
EB		 1296 end List_Component_Layout;
1297
1c912574
AC		 1298 ------------------------
1299 -- List_Record_Layout --
1300 ------------------------
19235870 1301
1c912574
AC		 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
81d85d4b
EB		 1308 Comp : Entity_Id;
1309 First : Boolean := True;
19235870 1310
1c912574
AC		 1311 begin
1312 Comp := First_Component_Or_Discriminant (Ent);
1313 while Present (Comp) loop
3fbbbd1e 1314
1c912574 1315 -- Skip discriminant in unchecked union (since it is not there!)
3fbbbd1e 1316
1c912574
AC		 1317 if Ekind (Comp) = E_Discriminant
1318 and then Is_Unchecked_Union (Ent)
1319 then
1320 goto Continue;
1321 end if;
3fbbbd1e 1322
c8e95568
EB		 1323 -- Skip _Parent component in extension (to avoid overlap)
1324
1325 if Chars (Comp) = Name_uParent then
1326 goto Continue;
1327 end if;
1328
1c912574 1329 -- All other cases
3fbbbd1e 1330
1c912574
AC		 1331 declare
1332 Ctyp : constant Entity_Id := Underlying_Type (Etype (Comp));
1c912574
AC		 1333 Npos : constant Uint := Normalized_Position (Comp);
1334 Fbit : constant Uint := Normalized_First_Bit (Comp);
1335 Spos : Uint;
1336 Sbit : Uint;
a9a5b8ac 1337
1c912574
AC		 1338 begin
1339 Get_Decoded_Name_String (Chars (Comp));
1340 Set_Casing (Unit_Casing);
19235870 1341
1c912574
AC		 1342 -- If extended information is requested, recurse fully into
1343 -- record components, i.e. skip the outer level.
19235870 1344
1c912574
AC		 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;
3815f967 1352
1c912574
AC		 1353 if Sbit >= SSU then
1354 Spos := Spos + 1;
1355 Sbit := Sbit - SSU;
1356 end if;
3815f967 1357
1c912574
AC		 1358 List_Record_Layout (Ctyp,
1359 Spos, Sbit, Prefix & Name_Buffer (1 .. Name_Len) & ".");
3815f967 1360
1c912574
AC		 1361 goto Continue;
1362 end if;
19235870 1363
81d85d4b
EB		 1364 if List_Representation_Info_To_JSON then
1365 if First then
1366 Write_Eol;
1367 First := False;
1368 else
1369 Write_Line (",");
1370 end if;
1371 end if;
1372
7883c42e
EB		 1373 List_Component_Layout (Comp,
1374 Starting_Position, Starting_First_Bit, Prefix);
1c912574 1375 end;
19235870 1376
1c912574
AC		 1377 <<Continue>>
1378 Next_Component_Or_Discriminant (Comp);
1379 end loop;
1380 end List_Record_Layout;
1381
1e7629b8
EB		 1382 -----------------------------------
1383 -- List_Structural_Record_Layout --
1384 -----------------------------------
1385
1386 procedure List_Structural_Record_Layout
0f9ca030
EB		 1387 (Ent : Entity_Id;
1388 Outer_Ent : Entity_Id;
1389 Variant : Node_Id := Empty;
1390 Indent : Natural := 0)
1e7629b8 1391 is
0f9ca030
EB		 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
f537fc00
HK		 1403 Corr_Disc : Entity_Id;
1404 Derived_Disc : Entity_Id;
0f9ca030
EB		 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
f537fc00
HK		 1424 if Original_Record_Component (Corr_Disc) =
1425 Original_Record_Component (Disc)
0f9ca030
EB		 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
1e7629b8
EB		 1441 Comp : Node_Id;
1442 Comp_List : Node_Id;
1e7629b8 1443 First : Boolean := True;
f537fc00 1444 Var : Node_Id;
1e7629b8 1445
0f9ca030
EB		 1446 -- Start of processing for List_Structural_Record_Layout
1447
1e7629b8
EB		 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 :=
f537fc00
HK		 1460 Type_Definition (Declaration_Node (Ent));
1461
1e7629b8 1462 Is_Extension : constant Boolean :=
f537fc00
HK		 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;
abbc4546 1469 Parent_Type : Entity_Id;
0f9ca030 1470
1e7629b8
EB		 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
abbc4546
EB		 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);
9104d201 1492 First := False;
1e7629b8
EB		 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
0f9ca030
EB		 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));
1e7629b8
EB		 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
0f9ca030 1540 List_Component_Layout (Listed_Disc, Indent => Indent);
1e7629b8
EB		 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
0f9ca030 1620 List_Structural_Record_Layout (Ent, Outer_Ent, Var, Indent + 4);
1e7629b8
EB		 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
3815f967
AC		 1631 -- Start of processing for List_Record_Info
1632
1c912574 1633 begin
b5d3d113 1634 Write_Separator;
1c912574 1635
1e7629b8
EB		 1636 if List_Representation_Info_To_JSON then
1637 Write_Line ("{");
1638 end if;
1639
6f65c7ee 1640 List_Common_Type_Info (Ent);
1c912574
AC		 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
1e7629b8
EB		 1649 if List_Representation_Info_To_JSON then
1650 Write_Line (",");
1651 Write_Str (" ""record"": [");
1652
abbc4546
EB		 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
81d85d4b 1657 if Is_Base_Type (Ent) then
abbc4546
EB		 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;
81d85d4b
EB		 1670 else
1671 List_Record_Layout (Ent);
1672 end if;
1e7629b8
EB		 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);
19235870 1682
1e7629b8
EB		 1683 Write_Line ("end record;");
1684 end if;
d9f8616e
AC		 1685
1686 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
7672ab42
EB		 1687
1688 List_Linker_Section (Ent);
1e7629b8
EB		 1689
1690 if List_Representation_Info_To_JSON then
1691 Write_Eol;
1692 Write_Line ("}");
1693 end if;
76ccee8f
EB		 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;
19235870
RK		 1703 end List_Record_Info;
1704
1705 -------------------
1706 -- List_Rep_Info --
1707 -------------------
1708
d9f8616e 1709 procedure List_Rep_Info (Bytes_Big_Endian : Boolean) is
19235870
RK		 1710 Col : Nat;
1711
1712 begin
fbf5a39b
AC		 1713 if List_Representation_Info /= 0
1714 or else List_Representation_Info_Mechanisms
1715 then
b5d3d113
EB		 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
fbf5a39b
AC		 1725 for U in Main_Unit .. Last_Unit loop
1726 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
d436b30d 1727 Unit_Casing := Identifier_Casing (Source_Index (U));
07fc65c4 1728
b5f581cd
EB		 1729 if List_Representation_Info = 4 then
1730 Relevant_Entities.Reset;
1731 end if;
1732
fbf5a39b 1733 -- Normal case, list to standard output
07fc65c4 1734
de9b2a96
EB		 1735 if not List_Representation_Info_To_File then
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;
b5d3d113 1748 Need_Separator := True;
de9b2a96 1749 end if;
07fc65c4 1750
d9f8616e 1751 List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
07fc65c4 1752
fbf5a39b 1753 -- List representation information to file
07fc65c4 1754
fbf5a39b 1755 else
d3879a5a 1756 Create_Repinfo_File_Access.all
1c28fe3a 1757 (Get_Name_String (File_Name (Source_Index (U))));
fbf5a39b 1758 Set_Special_Output (Write_Info_Line'Access);
b5d3d113
EB		 1759 if List_Representation_Info_To_JSON then
1760 Write_Line ("[");
1761 end if;
1762 Need_Separator := False;
d9f8616e 1763 List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
b5d3d113
EB		 1764 if List_Representation_Info_To_JSON then
1765 Write_Line ("]");
1766 end if;
e3548b69 1767 Cancel_Special_Output;
fbf5a39b
AC		 1768 Close_Repinfo_File_Access.all;
1769 end if;
07fc65c4 1770 end if;
fbf5a39b 1771 end loop;
b5d3d113
EB		 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;
fbf5a39b 1778 end if;
19235870
RK		 1779 end List_Rep_Info;
1780
d9f8616e
AC		 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
7ed57189
AC		 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.
d9f8616e
AC		 1793
1794 ---------------
1795 -- List_Attr --
1796 ---------------
1797
7ed57189 1798 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean) is
d9f8616e 1799 begin
1e7629b8
EB		 1800 if List_Representation_Info_To_JSON then
1801 Write_Line (",");
972d2984
EB		 1802 Write_Str (" """);
1803 Write_Str (Attr_Name);
1804 Write_Str (""": ""System.");
1e7629b8
EB		 1805 else
1806 Write_Str ("for ");
1807 List_Name (Ent);
972d2984
EB		 1808 Write_Char (''');
1809 Write_Str (Attr_Name);
1810 Write_Str (" use System.");
1e7629b8 1811 end if;
489c6e19 1812
7ed57189 1813 if Bytes_Big_Endian xor Is_Reversed then
d9f8616e
AC		 1814 Write_Str ("High");
1815 else
1816 Write_Str ("Low");
1817 end if;
489c6e19 1818
1e7629b8
EB		 1819 Write_Str ("_Order_First");
1820 if List_Representation_Info_To_JSON then
1821 Write_Str ("""");
1822 else
1823 Write_Line (";");
1824 end if;
d9f8616e
AC		 1825 end List_Attr;
1826
7ed57189
AC		 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);
31fde973
GD		 1831 -- Scalar_Storage_Order is displayed if specified explicitly or set by
1832 -- Default_Scalar_Storage_Order.
7ed57189 1833
d9f8616e
AC		 1834 -- Start of processing for List_Scalar_Storage_Order
1835
1836 begin
7ed57189 1837 -- For record types, list Bit_Order if not default, or if SSO is shown
d9f8616e 1838
6aaab508
JS		 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
7ed57189 1844 if Is_Record_Type (Ent)
6aaab508
JS		 1845 and then (List_SSO
1846 or else Reverse_Bit_Order (Ent)
1847 or else List_Representation_Info = 4)
220d1fd9 1848 then
7ed57189
AC		 1849 List_Attr ("Bit_Order", Reverse_Bit_Order (Ent));
1850 end if;
d9f8616e 1851
7ed57189
AC		 1852 -- List SSO if required. If not, then storage is supposed to be in
1853 -- native order.
489c6e19 1854
6aaab508 1855 if List_SSO or else List_Representation_Info = 4 then
7ed57189
AC		 1856 List_Attr ("Scalar_Storage_Order", Reverse_Storage_Order (Ent));
1857 else
1858 pragma Assert (not Reverse_Storage_Order (Ent));
1859 null;
d9f8616e
AC		 1860 end if;
1861 end List_Scalar_Storage_Order;
1862
6f65c7ee
EB		 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;
19235870 1871
19235870 1872 begin
b5d3d113 1873 Write_Separator;
6f65c7ee 1874
1e7629b8 1875 if List_Representation_Info_To_JSON then
6f65c7ee 1876 Write_Line ("{");
1e7629b8
EB		 1877 Write_Str (" ""name"": """);
1878 List_Name (Ent);
1879 Write_Line (""",");
1880 List_Location (Ent);
6f65c7ee
EB		 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 : ");
1e7629b8
EB		 1912 end if;
1913
6f65c7ee
EB		 1914 case Convention (Ent) is
1915 when Convention_Ada =>
1916 Write_Str ("Ada");
07fc65c4 1917
6f65c7ee
EB		 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");
07fc65c4 1932
6f65c7ee
EB		 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"": [");
07fc65c4 1958 else
6f65c7ee
EB		 1959 Write_Eol;
1960 end if;
19235870 1961
6f65c7ee
EB		 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;
1e7629b8 1987 else
6f65c7ee 1988 Write_Line (",");
1e7629b8 1989 end if;
19235870 1990
6f65c7ee
EB		 1991 Write_Line (" {");
1992 Write_Str (" ""name"": """);
1993 Write_Str (Name_Buffer (1 .. Name_Len));
1994 Write_Line (""",");
19235870 1995
6f65c7ee
EB		 1996 Write_Str (" ""mechanism"": """);
1997 Write_Mechanism (Mechanism (Form));
1998 Write_Line ("""");
1999 Write_Str (" }");
07fc65c4 2000 else
6f65c7ee
EB		 2001 while Name_Len <= Plen loop
2002 Name_Len := Name_Len + 1;
2003 Name_Buffer (Name_Len) := ' ';
2004 end loop;
19235870 2005
6f65c7ee
EB		 2006 Write_Str (" ");
2007 Write_Str (Name_Buffer (1 .. Plen + 1));
2008 Write_Str (": passed by ");
1e7629b8 2009
6f65c7ee
EB		 2010 Write_Mechanism (Mechanism (Form));
2011 Write_Eol;
2012 end if;
1e7629b8 2013
6f65c7ee
EB		 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;
19235870
RK		 2032 end if;
2033 end if;
2034
6f65c7ee
EB		 2035 if not Is_Entry (Ent) then
2036 List_Linker_Section (Ent);
2037 end if;
2038
1e7629b8 2039 if List_Representation_Info_To_JSON then
6f65c7ee
EB		 2040 Write_Eol;
2041 Write_Line ("}");
1e7629b8 2042 end if;
6f65c7ee
EB		 2043 end List_Subprogram_Info;
2044
2045 --------------------
2046 -- List_Type_Info --
2047 --------------------
2048
2049 procedure List_Type_Info (Ent : Entity_Id) is
2050 begin
b5d3d113 2051 Write_Separator;
6f65c7ee
EB		 2052
2053 if List_Representation_Info_To_JSON then
2054 Write_Line ("{");
2055 end if;
2056
2057 List_Common_Type_Info (Ent);
0d57c6f4
RD		 2058
2059 -- Special stuff for fixed-point
2060
2061 if Is_Fixed_Point_Type (Ent) then
2062
2063 -- Write small (always a static constant)
2064
1e7629b8
EB		 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;
0d57c6f4
RD		 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
1e7629b8
EB		 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;
0d57c6f4
RD		 2103 end if;
2104 end;
2105 end if;
6f65c7ee
EB		 2106
2107 List_Linker_Section (Ent);
2108
2109 if List_Representation_Info_To_JSON then
2110 Write_Eol;
2111 Write_Line ("}");
2112 end if;
19235870
RK		 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
972d2984
EB		 2132 function Rep_Value (Val : Node_Ref_Or_Val; D : Discrim_List) return Uint is
2133
19235870
RK		 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
5e61ef09 2143 function W (Val : Uint) return Word;
0d57c6f4
RD		 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
5e61ef09
TQ		 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
276e95ca 2149 -- inherent unreliabilities in computations anyway.
5e61ef09 2150
19235870
RK		 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
19235870 2250 when Truth_And_Expr =>
d1ced162 2251 return B (T (Node.Op1) and then T (Node.Op2));
19235870
RK		 2252
2253 when Truth_Or_Expr =>
d1ced162 2254 return B (T (Node.Op1) or else T (Node.Op2));
19235870
RK		 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
5e61ef09
TQ		 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
19235870
RK		 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);
19235870
RK		 2288 begin
2289 pragma Assert (Sub in D'Range);
2290 return D (Sub);
2291 end;
e45f84a5
EB		 2292
2293 when Dynamic_Val =>
2294 return No_Uint;
19235870
RK		 2295 end case;
2296 end;
2297 end if;
2298 end V;
2299
d3879a5a
RD		 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
19235870
RK		 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
fbf5a39b
AC		 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
fbf5a39b
AC		 2382 when others =>
2383 raise Program_Error;
2384 end case;
2385 end Write_Mechanism;
2386
b5d3d113
EB		 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
76b382d9
EB		 2404 -----------------------
2405 -- Write_Unknown_Val --
2406 -----------------------
2407
2408 procedure Write_Unknown_Val is
2409 begin
1e7629b8
EB		 2410 if List_Representation_Info_To_JSON then
2411 Write_Str ("""??""");
2412 else
2413 Write_Str ("??");
2414 end if;
76b382d9
EB		 2415 end Write_Unknown_Val;
2416
19235870
RK		 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
07fc65c4 2424 if List_Representation_Info < 3 or else Val = No_Uint then
76b382d9 2425 Write_Unknown_Val;
07fc65c4 2426
19235870 2427 else
98b779ae
PMR		 2428 if Paren then
2429 Write_Char ('(');
2430 end if;
07fc65c4 2431
98b779ae
PMR		 2432 if Back_End_Layout then
2433 List_GCC_Expression (Val);
19235870 2434 else
98b779ae
PMR		 2435 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
2436 end if;
2437
2438 if Paren then
2439 Write_Char (')');
19235870
RK		 2440 end if;
2441 end if;
2442
2443 else
f9534f4b 2444 UI_Write (Val, Decimal);
19235870
RK		 2445 end if;
2446 end Write_Val;
2447
2448end Repinfo;
Mirror of https://gcc.gnu.org/git/gcc.git