1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Ada
.Unchecked_Conversion
;
27 with Namet
; use Namet
;
28 with Nlists
; use Nlists
;
31 with Output
; use Output
;
32 with Sinfo
.Utils
; use Sinfo
.Utils
;
33 with System
.Storage_Elements
;
43 -- Suppose you find that node 12345 is messed up. You might want to find
44 -- the code that created that node. See sinfo-utils.adb for how to do that.
46 Ignored_Ghost_Recording_Proc
: Ignored_Ghost_Record_Proc
:= null;
47 -- This soft link captures the procedure invoked during the creation of an
48 -- ignored Ghost node or entity.
50 Locked
: Boolean := False;
51 -- Compiling with assertions enabled, node contents modifications are
52 -- permitted only when this switch is set to False; compiling without
53 -- assertions this lock has no effect.
55 Reporting_Proc
: Report_Proc
:= null;
56 -- Set_Reporting_Proc sets this. Set_Reporting_Proc must be called only
59 Rewriting_Proc
: Rewrite_Proc
:= null;
60 -- This soft link captures the procedure invoked during a node rewrite
62 -----------------------------
63 -- Local Objects and Types --
64 -----------------------------
66 Comes_From_Source_Default
: Boolean := False;
68 use Atree_Private_Part
;
69 -- We are also allowed to see our private data structures
71 --------------------------------------------------
72 -- Implementation of Tree Substitution Routines --
73 --------------------------------------------------
75 -- A separate table keeps track of the mapping between rewritten nodes and
76 -- their corresponding original tree nodes. Rewrite makes an entry in this
77 -- table for use by Original_Node. By default the entry in this table
78 -- points to the original unwritten node. Note that if a node is rewritten
79 -- more than once, there is no easy way to get to the intermediate
80 -- rewrites; the node itself is the latest version, and the entry in this
81 -- table is the original.
83 -- Note: This could be a node field.
85 package Orig_Nodes
is new Table
.Table
(
86 Table_Component_Type
=> Node_Id
,
87 Table_Index_Type
=> Node_Id
'Base,
88 Table_Low_Bound
=> First_Node_Id
,
89 Table_Initial
=> Alloc
.Node_Offsets_Initial
,
90 Table_Increment
=> Alloc
.Node_Offsets_Increment
,
91 Table_Name
=> "Orig_Nodes");
97 -- A separate table is used to traverse trees. It passes the parent field
98 -- of each node to the called process subprogram. It is defined global to
99 -- avoid adding performance overhead if allocated each time the traversal
100 -- functions are invoked.
102 package Parents_Stack
is new Table
.Table
103 (Table_Component_Type
=> Node_Id
,
104 Table_Index_Type
=> Nat
,
105 Table_Low_Bound
=> 1,
106 Table_Initial
=> 256,
107 Table_Increment
=> 100,
108 Table_Name
=> "Parents_Stack");
110 --------------------------
111 -- Paren_Count Handling --
112 --------------------------
114 -- The Small_Paren_Count field has range 0 .. 3. If the Paren_Count is
115 -- in the range 0 .. 2, then it is stored as Small_Paren_Count. Otherwise,
116 -- Small_Paren_Count = 3, and the actual Paren_Count is stored in the
117 -- Paren_Counts table.
119 -- We use linear search on the Paren_Counts table, which is plenty
120 -- efficient because only pathological programs will use it. Nobody
121 -- writes (((X + Y))).
123 type Paren_Count_Entry
is record
125 -- The node to which this count applies
127 Count
: Nat
range 3 .. Nat
'Last;
128 -- The count of parentheses, which will be in the indicated range
131 package Paren_Counts
is new Table
.Table
(
132 Table_Component_Type
=> Paren_Count_Entry
,
133 Table_Index_Type
=> Int
,
134 Table_Low_Bound
=> 0,
136 Table_Increment
=> 200,
137 Table_Name
=> "Paren_Counts");
139 procedure Set_Paren_Count_Of_Copy
(Target
, Source
: Node_Id
);
140 pragma Inline
(Set_Paren_Count_Of_Copy
);
141 -- Called when copying a node. Makes sure the Paren_Count of the copy is
144 -----------------------
145 -- Local Subprograms --
146 -----------------------
148 function Allocate_New_Node
(Kind
: Node_Kind
) return Node_Id
;
149 pragma Inline
(Allocate_New_Node
);
150 -- Allocate a new node or first part of a node extension. Initialize the
151 -- Nodes.Table entry, Flags, Orig_Nodes, and List tables.
153 procedure Fix_Parents
(Ref_Node
, Fix_Node
: Node_Id
);
154 -- Fix up parent pointers for the children of Fix_Node after a copy,
155 -- setting them to Fix_Node when they pointed to Ref_Node.
158 with function Process
159 (Parent_Node
: Node_Id
;
160 Node
: Node_Id
) return Traverse_Result
is <>;
161 function Internal_Traverse_With_Parent
162 (Node
: Node_Id
) return Traverse_Final_Result
;
163 pragma Inline
(Internal_Traverse_With_Parent
);
164 -- Internal function that provides a functionality similar to Traverse_Func
165 -- but extended to pass the Parent node to the called Process subprogram;
166 -- delegates to Traverse_Func_With_Parent the initialization of the stack
167 -- data structure which stores the parent nodes (cf. Parents_Stack).
168 -- ??? Could we factorize the common code of Internal_Traverse_Func and
171 procedure Mark_New_Ghost_Node
(N
: Node_Or_Entity_Id
);
172 -- Mark arbitrary node or entity N as Ghost when it is created within a
175 procedure Report
(Target
, Source
: Node_Id
);
176 pragma Inline
(Report
);
177 -- Invoke the reporting procedure if available
179 function Size_In_Slots
(N
: Node_Or_Entity_Id
) return Slot_Count
;
180 -- Number of slots belonging to N. This can be less than
181 -- Size_In_Slots_To_Alloc for entities. Includes both header
182 -- and dynamic slots.
184 function Size_In_Slots_Dynamic
(N
: Node_Or_Entity_Id
) return Slot_Count
;
185 -- Just counts the number of dynamic slots
187 function Size_In_Slots_To_Alloc
(N
: Node_Or_Entity_Id
) return Slot_Count
;
188 function Size_In_Slots_To_Alloc
(Kind
: Node_Kind
) return Slot_Count
;
189 -- Number of slots to allocate for a node or entity. For entities, we have
190 -- to allocate the max, because we don't know the Ekind when this is
193 function Off_F
(N
: Node_Id
) return Node_Offset
with Inline
;
194 -- Offset of the first dynamic slot of N in Slots.Table.
195 -- The actual offset of this slot from the start of the node
196 -- is not 0; this is logically the first slot after the header
199 function Off_0
(N
: Node_Id
) return Node_Offset
'Base with Inline
;
200 -- This is for zero-origin addressing of the dynamic slots.
201 -- It points to slot 0 of N in Slots.Table, which does not exist,
202 -- because the first few slots are stored in the header.
204 function Off_L
(N
: Node_Id
) return Node_Offset
with Inline
;
205 -- Offset of the last slot of N in Slots.Table
207 procedure Zero_Dynamic_Slots
(First
, Last
: Node_Offset
'Base) with Inline
;
208 -- Set dynamic slots in the range First..Last to zero
210 procedure Zero_Header_Slots
(N
: Node_Or_Entity_Id
) with Inline
;
211 -- Zero the header slots belonging to N
213 procedure Zero_Slots
(N
: Node_Or_Entity_Id
) with Inline
;
214 -- Zero the slots belonging to N (both header and dynamic)
216 procedure Copy_Dynamic_Slots
217 (From
, To
: Node_Offset
; Num_Slots
: Slot_Count
)
219 -- Copy Num_Slots slots from From to To. Caller is responsible for ensuring
220 -- that the Num_Slots at To are a reasonable place to copy to.
222 procedure Copy_Slots
(Source
, Destination
: Node_Id
) with Inline
;
223 -- Copies the slots (both header and dynamic) of Source to Destination;
224 -- uses the node kind to determine the Num_Slots.
226 function Get_Field_Value
227 (N
: Node_Id
; Field
: Node_Or_Entity_Field
) return Field_Size_32_Bit
;
228 -- Get any field value as a Field_Size_32_Bit. If the field is smaller than
229 -- 32 bits, convert it to Field_Size_32_Bit. The Field must be present in
232 procedure Set_Field_Value
233 (N
: Node_Id
; Field
: Node_Or_Entity_Field
; Val
: Field_Size_32_Bit
);
234 -- Set any field value as a Field_Size_32_Bit. If the field is smaller than
235 -- 32 bits, convert it from Field_Size_32_Bit, and Val had better be small
236 -- enough. The Field must be present in the Nkind of N.
238 procedure Check_Vanishing_Fields
239 (Old_N
: Node_Id
; New_Kind
: Node_Kind
);
240 -- Called whenever Nkind is modified. Raises an exception if not all
241 -- vanishing fields are in their initial zero state.
243 procedure Check_Vanishing_Fields
244 (Old_N
: Entity_Id
; New_Kind
: Entity_Kind
);
245 -- Above are the same as the ones for nodes, but for entities
247 procedure Init_Nkind
(N
: Node_Id
; Val
: Node_Kind
);
248 -- Initialize the Nkind field, which must not have been set already. This
249 -- cannot be used to modify an already-initialized Nkind field. See also
252 procedure Mutate_Nkind
253 (N
: Node_Id
; Val
: Node_Kind
; Old_Size
: Slot_Count
);
254 -- Called by the other Mutate_Nkind to do all the work. This is needed
255 -- because the call in Change_Node, which calls this one directly, happens
256 -- after zeroing N's slots, which destroys its Nkind, which prevents us
257 -- from properly computing Old_Size.
259 package Field_Checking
is
260 -- Functions for checking field access, used only in assertions
262 function Field_Present
263 (Kind
: Node_Kind
; Field
: Node_Field
) return Boolean;
264 function Field_Present
265 (Kind
: Entity_Kind
; Field
: Entity_Field
) return Boolean;
266 -- True if a node/entity of the given Kind has the given Field.
267 -- Always True if assertions are disabled.
269 function Field_Present
270 (N
: Node_Id
; Field
: Node_Or_Entity_Field
) return Boolean;
271 -- Same for a node, which could be an entity
275 package body Field_Checking
is
277 -- Tables used by Field_Present
279 type Node_Field_Sets
is array (Node_Kind
) of Node_Field_Set
;
280 type Node_Field_Sets_Ptr
is access all Node_Field_Sets
;
281 Node_Fields_Present
: Node_Field_Sets_Ptr
;
283 type Entity_Field_Sets
is array (Entity_Kind
) of Entity_Field_Set
;
284 type Entity_Field_Sets_Ptr
is access all Entity_Field_Sets
;
285 Entity_Fields_Present
: Entity_Field_Sets_Ptr
;
287 procedure Init_Tables
;
289 function Create_Node_Fields_Present
290 (Kind
: Node_Kind
) return Node_Field_Set
;
291 function Create_Entity_Fields_Present
292 (Kind
: Entity_Kind
) return Entity_Field_Set
;
293 -- Computes the set of fields present in each Node/Entity Kind. Used to
294 -- initialize the above tables.
296 --------------------------------
297 -- Create_Node_Fields_Present --
298 --------------------------------
300 function Create_Node_Fields_Present
301 (Kind
: Node_Kind
) return Node_Field_Set
303 Result
: Node_Field_Set
:= (others => False);
305 for J
in Node_Field_Table
(Kind
)'Range loop
306 Result
(Node_Field_Table
(Kind
) (J
)) := True;
310 end Create_Node_Fields_Present
;
312 --------------------------------
313 -- Create_Entity_Fields_Present --
314 --------------------------------
316 function Create_Entity_Fields_Present
317 (Kind
: Entity_Kind
) return Entity_Field_Set
319 Result
: Entity_Field_Set
:= (others => False);
321 for J
in Entity_Field_Table
(Kind
)'Range loop
322 Result
(Entity_Field_Table
(Kind
) (J
)) := True;
326 end Create_Entity_Fields_Present
;
332 procedure Init_Tables
is
334 Node_Fields_Present
:= new Node_Field_Sets
;
336 for Kind
in Node_Kind
loop
337 Node_Fields_Present
(Kind
) := Create_Node_Fields_Present
(Kind
);
340 Entity_Fields_Present
:= new Entity_Field_Sets
;
342 for Kind
in Entity_Kind
loop
343 Entity_Fields_Present
(Kind
) :=
344 Create_Entity_Fields_Present
(Kind
);
348 -- In production mode, we leave Node_Fields_Present and
349 -- Entity_Fields_Present null. Field_Present is only for
350 -- use in assertions.
352 pragma Debug
(Init_Tables
);
354 function Field_Present
355 (Kind
: Node_Kind
; Field
: Node_Field
) return Boolean is
357 if Node_Fields_Present
= null then
361 return Node_Fields_Present
(Kind
) (Field
);
364 function Field_Present
365 (Kind
: Entity_Kind
; Field
: Entity_Field
) return Boolean is
367 if Entity_Fields_Present
= null then
371 return Entity_Fields_Present
(Kind
) (Field
);
374 function Field_Present
375 (N
: Node_Id
; Field
: Node_Or_Entity_Field
) return Boolean is
379 return Field_Present
(Nkind
(N
), Field
);
381 return Field_Present
(Ekind
(N
), Field
);
387 ------------------------
388 -- Atree_Private_Part --
389 ------------------------
391 package body Atree_Private_Part
is
393 -- The following validators are disabled in production builds, by being
394 -- called in pragma Debug. They are also disabled by default in debug
395 -- builds, by setting the flags below, because they make the compiler
396 -- very slow (10 to 20 times slower). Validate can be set True to debug
397 -- the low-level accessors.
399 -- Even if Validate is True, validation is disabled during
400 -- Validate_... calls to prevent infinite recursion
401 -- (Validate_... procedures call field getters, which call
402 -- Validate_... procedures). That's what the Enable_Validate_...
403 -- flags are for; they are toggled so that when we're inside one
404 -- of them, and enter it again, the inner call doesn't do anything.
405 -- These flags are irrelevant when Validate is False.
407 Validate
: constant Boolean := False;
409 Enable_Validate_Node
,
410 Enable_Validate_Node_Write
,
411 Enable_Validate_Node_And_Offset
,
412 Enable_Validate_Node_And_Offset_Write
:
415 procedure Validate_Node_And_Offset
416 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
);
417 procedure Validate_Node_And_Offset_Write
418 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
);
419 -- Asserts N is OK, and the Offset in slots is within N. Note that this
420 -- does not guarantee that the offset is valid, just that it's not past
421 -- the last slot. It could be pointing at unused bits within the node,
422 -- or unused padding at the end. The "_Write" version is used when we're
423 -- about to modify the node.
425 procedure Validate_Node_And_Offset
426 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) is
428 if Enable_Validate_Node_And_Offset
then
429 Enable_Validate_Node_And_Offset
:= False;
431 pragma Debug
(Validate_Node
(N
));
432 pragma Assert
(Offset
'Valid);
433 pragma Assert
(Offset
< Size_In_Slots
(N
));
435 Enable_Validate_Node_And_Offset
:= True;
437 end Validate_Node_And_Offset
;
439 procedure Validate_Node_And_Offset_Write
440 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) is
442 if Enable_Validate_Node_And_Offset_Write
then
443 Enable_Validate_Node_And_Offset_Write
:= False;
445 pragma Debug
(Validate_Node_Write
(N
));
446 pragma Assert
(Offset
'Valid);
447 pragma Assert
(Offset
< Size_In_Slots
(N
));
449 Enable_Validate_Node_And_Offset_Write
:= True;
451 end Validate_Node_And_Offset_Write
;
453 procedure Validate_Node
(N
: Node_Or_Entity_Id
) is
455 if Enable_Validate_Node
then
456 Enable_Validate_Node
:= False;
458 pragma Assert
(N
'Valid);
459 pragma Assert
(N
<= Node_Offsets
.Last
);
460 pragma Assert
(Off_L
(N
) >= Off_0
(N
));
461 pragma Assert
(Off_L
(N
) >= Off_F
(N
) - 1);
462 pragma Assert
(Off_L
(N
) <= Slots
.Last
);
463 pragma Assert
(Nkind
(N
)'Valid);
464 pragma Assert
(Nkind
(N
) /= N_Unused_At_End
);
466 if Nkind
(N
) in N_Entity
then
467 pragma Assert
(Ekind
(N
)'Valid);
472 | N_Attribute_Definition_Clause
473 | N_Aspect_Specification
474 | N_Extension_Aggregate
476 | N_Freeze_Generic_Entity
478 | N_Selected_Component
479 | N_Use_Package_Clause
481 pragma Assert
(Entity_Or_Associated_Node
(N
)'Valid);
484 Enable_Validate_Node
:= True;
488 procedure Validate_Node_Write
(N
: Node_Or_Entity_Id
) is
490 if Enable_Validate_Node_Write
then
491 Enable_Validate_Node_Write
:= False;
493 pragma Debug
(Validate_Node
(N
));
494 pragma Assert
(not Locked
);
496 Enable_Validate_Node_Write
:= True;
498 end Validate_Node_Write
;
500 function Is_Valid_Node
(U
: Union_Id
) return Boolean is
502 return Node_Id
'Base (U
) <= Node_Offsets
.Last
;
505 function Alloc_Node_Id
return Node_Id
is
507 Node_Offsets
.Increment_Last
;
508 return Node_Offsets
.Last
;
511 function Alloc_Slots
(Num_Slots
: Slot_Count
) return Node_Offset
is
513 return Result
: constant Node_Offset
:= Slots
.Last
+ 1 do
514 Slots
.Set_Last
(Slots
.Last
+ Num_Slots
);
518 function Get_1_Bit_Field
519 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
521 pragma Assert
(Field_Type
'Size = 1);
524 Ada
.Unchecked_Conversion
(Field_Size_1_Bit
, Field_Type
);
525 Val
: constant Field_Size_1_Bit
:= Get_1_Bit_Val
(N
, Offset
);
530 function Get_2_Bit_Field
531 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
533 pragma Assert
(Field_Type
'Size = 2);
536 Ada
.Unchecked_Conversion
(Field_Size_2_Bit
, Field_Type
);
537 Val
: constant Field_Size_2_Bit
:= Get_2_Bit_Val
(N
, Offset
);
542 function Get_4_Bit_Field
543 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
545 pragma Assert
(Field_Type
'Size = 4);
548 Ada
.Unchecked_Conversion
(Field_Size_4_Bit
, Field_Type
);
549 Val
: constant Field_Size_4_Bit
:= Get_4_Bit_Val
(N
, Offset
);
554 function Get_8_Bit_Field
555 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
557 pragma Assert
(Field_Type
'Size = 8);
560 Ada
.Unchecked_Conversion
(Field_Size_8_Bit
, Field_Type
);
561 Val
: constant Field_Size_8_Bit
:= Get_8_Bit_Val
(N
, Offset
);
566 function Get_32_Bit_Field
567 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
569 pragma Assert
(Field_Type
'Size = 32);
572 Ada
.Unchecked_Conversion
(Field_Size_32_Bit
, Field_Type
);
574 Val
: constant Field_Size_32_Bit
:= Get_32_Bit_Val
(N
, Offset
);
575 Result
: constant Field_Type
:= Cast
(Val
);
576 -- Note: declaring Result here instead of directly returning
577 -- Cast (...) helps CodePeer understand that there are no issues
578 -- around uninitialized variables.
581 end Get_32_Bit_Field
;
583 function Get_32_Bit_Field_With_Default
584 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
586 function Get_Field
is new Get_32_Bit_Field
(Field_Type
) with Inline
;
589 -- If the field has not yet been set, it will be equal to zero.
590 -- That is of the "wrong" type, so we fetch it as a
591 -- Field_Size_32_Bit.
593 if Get_32_Bit_Val
(N
, Offset
) = 0 then
594 Result
:= Default_Val
;
597 Result
:= Get_Field
(N
, Offset
);
601 end Get_32_Bit_Field_With_Default
;
603 function Get_Valid_32_Bit_Field
604 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
606 pragma Assert
(Get_32_Bit_Val
(N
, Offset
) /= 0);
607 -- If the field has not yet been set, it will be equal to zero.
608 -- This asserts that we don't call Get_ before Set_. Note that
609 -- the predicate on the Val parameter of Set_ checks for the No_...
610 -- value, so it can't possibly be (for example) No_Uint here.
612 function Get_Field
is new Get_32_Bit_Field
(Field_Type
) with Inline
;
613 Result
: constant Field_Type
:= Get_Field
(N
, Offset
);
616 end Get_Valid_32_Bit_Field
;
618 procedure Set_1_Bit_Field
619 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Type
)
621 pragma Assert
(Field_Type
'Size = 1);
624 Ada
.Unchecked_Conversion
(Field_Type
, Field_Size_1_Bit
);
626 Set_1_Bit_Val
(N
, Offset
, Cast
(Val
));
629 procedure Set_2_Bit_Field
630 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Type
)
632 pragma Assert
(Field_Type
'Size = 2);
635 Ada
.Unchecked_Conversion
(Field_Type
, Field_Size_2_Bit
);
637 Set_2_Bit_Val
(N
, Offset
, Cast
(Val
));
640 procedure Set_4_Bit_Field
641 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Type
)
643 pragma Assert
(Field_Type
'Size = 4);
646 Ada
.Unchecked_Conversion
(Field_Type
, Field_Size_4_Bit
);
648 Set_4_Bit_Val
(N
, Offset
, Cast
(Val
));
651 procedure Set_8_Bit_Field
652 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Type
)
654 pragma Assert
(Field_Type
'Size = 8);
657 Ada
.Unchecked_Conversion
(Field_Type
, Field_Size_8_Bit
);
659 Set_8_Bit_Val
(N
, Offset
, Cast
(Val
));
662 procedure Set_32_Bit_Field
663 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Type
)
665 pragma Assert
(Field_Type
'Size = 32);
668 Ada
.Unchecked_Conversion
(Field_Type
, Field_Size_32_Bit
);
670 Set_32_Bit_Val
(N
, Offset
, Cast
(Val
));
671 end Set_32_Bit_Field
;
673 pragma Style_Checks
("M90");
675 -----------------------------------
676 -- Low-level getters and setters --
677 -----------------------------------
679 -- In the getters and setters below, we use shifting and masking to
680 -- simulate packed arrays. F_Size is the field size in bits. Mask is
681 -- that number of 1 bits in the low-order bits. F_Per_Slot is the number
682 -- of fields per slot. Slot_Off is the offset of the slot of interest.
683 -- S is the slot at that offset. V is the amount to shift by.
685 function In_NH
(Slot_Off
: Field_Offset
) return Boolean is
687 -- In_NH stands for "in Node_Header", not "in New Hampshire"
690 (N
: Node_Or_Entity_Id
; Slot_Off
: Field_Offset
)
692 (if In_NH
(Slot_Off
) then
693 Node_Offsets
.Table
(N
).Slots
(Slot_Off
)
694 else Slots
.Table
(Node_Offsets
.Table
(N
).Offset
+ Slot_Off
));
695 -- Get the slot value, either directly from the node header, or
696 -- indirectly from the Slots table.
699 (N
: Node_Or_Entity_Id
; Slot_Off
: Field_Offset
; S
: Slot
);
700 -- Set the slot value, either directly from the node header, or
701 -- indirectly from the Slots table, to S.
703 function Get_1_Bit_Val
704 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Size_1_Bit
706 F_Size
: constant := 1;
707 Mask
: constant := 2**F_Size
- 1;
708 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
709 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
710 S
: constant Slot
:= Get_Slot
(N
, Slot_Off
);
711 V
: constant Natural := Natural ((Offset
mod F_Per_Slot
) * F_Size
);
712 pragma Debug
(Validate_Node_And_Offset
(N
, Slot_Off
));
713 Raw
: constant Field_Size_1_Bit
:=
714 Field_Size_1_Bit
(Shift_Right
(S
, V
) and Mask
);
719 function Get_2_Bit_Val
720 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Size_2_Bit
722 F_Size
: constant := 2;
723 Mask
: constant := 2**F_Size
- 1;
724 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
725 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
726 S
: constant Slot
:= Get_Slot
(N
, Slot_Off
);
727 V
: constant Natural := Natural ((Offset
mod F_Per_Slot
) * F_Size
);
728 pragma Debug
(Validate_Node_And_Offset
(N
, Slot_Off
));
729 Raw
: constant Field_Size_2_Bit
:=
730 Field_Size_2_Bit
(Shift_Right
(S
, V
) and Mask
);
735 function Get_4_Bit_Val
736 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Size_4_Bit
738 F_Size
: constant := 4;
739 Mask
: constant := 2**F_Size
- 1;
740 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
741 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
742 S
: constant Slot
:= Get_Slot
(N
, Slot_Off
);
743 V
: constant Natural := Natural ((Offset
mod F_Per_Slot
) * F_Size
);
744 pragma Debug
(Validate_Node_And_Offset
(N
, Slot_Off
));
745 Raw
: constant Field_Size_4_Bit
:=
746 Field_Size_4_Bit
(Shift_Right
(S
, V
) and Mask
);
751 function Get_8_Bit_Val
752 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Size_8_Bit
754 F_Size
: constant := 8;
755 Mask
: constant := 2**F_Size
- 1;
756 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
757 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
758 S
: constant Slot
:= Get_Slot
(N
, Slot_Off
);
759 V
: constant Natural := Natural ((Offset
mod F_Per_Slot
) * F_Size
);
760 pragma Debug
(Validate_Node_And_Offset
(N
, Slot_Off
));
761 Raw
: constant Field_Size_8_Bit
:=
762 Field_Size_8_Bit
(Shift_Right
(S
, V
) and Mask
);
767 function Get_32_Bit_Val
768 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Size_32_Bit
770 F_Size
: constant := 32;
772 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
773 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
774 S
: constant Slot
:= Get_Slot
(N
, Slot_Off
);
775 pragma Debug
(Validate_Node_And_Offset
(N
, Slot_Off
));
776 Raw
: constant Field_Size_32_Bit
:=
777 Field_Size_32_Bit
(S
);
783 (N
: Node_Or_Entity_Id
; Slot_Off
: Field_Offset
; S
: Slot
) is
785 if In_NH
(Slot_Off
) then
786 Node_Offsets
.Table
(N
).Slots
(Slot_Off
) := S
;
788 Slots
.Table
(Node_Offsets
.Table
(N
).Offset
+ Slot_Off
) := S
;
792 procedure Set_1_Bit_Val
793 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Size_1_Bit
)
795 F_Size
: constant := 1;
796 Mask
: constant := 2**F_Size
- 1;
797 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
798 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
799 S
: constant Slot
:= Get_Slot
(N
, Slot_Off
);
800 V
: constant Natural := Natural ((Offset
mod F_Per_Slot
) * F_Size
);
801 pragma Debug
(Validate_Node_And_Offset_Write
(N
, Slot_Off
));
805 (S
and not Shift_Left
(Mask
, V
)) or Shift_Left
(Slot
(Val
), V
));
808 procedure Set_2_Bit_Val
809 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Size_2_Bit
)
811 F_Size
: constant := 2;
812 Mask
: constant := 2**F_Size
- 1;
813 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
814 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
815 S
: constant Slot
:= Get_Slot
(N
, Slot_Off
);
816 V
: constant Natural := Natural ((Offset
mod F_Per_Slot
) * F_Size
);
817 pragma Debug
(Validate_Node_And_Offset_Write
(N
, Slot_Off
));
821 (S
and not Shift_Left
(Mask
, V
)) or Shift_Left
(Slot
(Val
), V
));
824 procedure Set_4_Bit_Val
825 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Size_4_Bit
)
827 F_Size
: constant := 4;
828 Mask
: constant := 2**F_Size
- 1;
829 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
830 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
831 S
: constant Slot
:= Get_Slot
(N
, Slot_Off
);
832 V
: constant Natural := Natural ((Offset
mod F_Per_Slot
) * F_Size
);
833 pragma Debug
(Validate_Node_And_Offset_Write
(N
, Slot_Off
));
837 (S
and not Shift_Left
(Mask
, V
)) or Shift_Left
(Slot
(Val
), V
));
840 procedure Set_8_Bit_Val
841 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Size_8_Bit
)
843 F_Size
: constant := 8;
844 Mask
: constant := 2**F_Size
- 1;
845 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
846 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
847 S
: constant Slot
:= Get_Slot
(N
, Slot_Off
);
848 V
: constant Natural := Natural ((Offset
mod F_Per_Slot
) * F_Size
);
849 pragma Debug
(Validate_Node_And_Offset_Write
(N
, Slot_Off
));
853 (S
and not Shift_Left
(Mask
, V
)) or Shift_Left
(Slot
(Val
), V
));
856 procedure Set_32_Bit_Val
857 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Size_32_Bit
)
859 F_Size
: constant := 32;
860 -- No Mask needed; this one doesn't do read-modify-write
861 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
862 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
863 pragma Debug
(Validate_Node_And_Offset_Write
(N
, Slot_Off
));
865 Set_Slot
(N
, Slot_Off
, Slot
(Val
));
868 ----------------------
869 -- Print_Atree_Info --
870 ----------------------
872 procedure Print_Atree_Info
(N
: Node_Or_Entity_Id
) is
873 function Cast
is new Ada
.Unchecked_Conversion
(Slot
, Int
);
875 Write_Int
(Int
(Size_In_Slots
(N
)));
876 Write_Str
(" slots (");
877 Write_Int
(Int
(Off_0
(N
)));
879 Write_Int
(Int
(Off_L
(N
)));
882 for Off
in Off_0
(N
) .. Off_L
(N
) loop
884 Write_Int
(Cast
(Get_Slot
(N
, Off
)));
888 end Print_Atree_Info
;
890 end Atree_Private_Part
;
892 ---------------------
893 -- Get_Field_Value --
894 ---------------------
896 function Get_Node_Field_Union
is new Get_32_Bit_Field
(Union_Id
)
898 -- Called when we don't know whether a field is a Node_Id or a List_Id,
901 function Get_Field_Value
902 (N
: Node_Id
; Field
: Node_Or_Entity_Field
) return Field_Size_32_Bit
904 pragma Assert
(Field_Checking
.Field_Present
(N
, Field
));
905 Desc
: Field_Descriptor
renames Field_Descriptors
(Field
);
906 NN
: constant Node_Or_Entity_Id
:= Node_To_Fetch_From
(N
, Field
);
909 case Field_Size
(Desc
.Kind
) is
910 when 1 => return Field_Size_32_Bit
(Get_1_Bit_Val
(NN
, Desc
.Offset
));
911 when 2 => return Field_Size_32_Bit
(Get_2_Bit_Val
(NN
, Desc
.Offset
));
912 when 4 => return Field_Size_32_Bit
(Get_4_Bit_Val
(NN
, Desc
.Offset
));
913 when 8 => return Field_Size_32_Bit
(Get_8_Bit_Val
(NN
, Desc
.Offset
));
914 when others => return Get_32_Bit_Val
(NN
, Desc
.Offset
); -- 32
918 ---------------------
919 -- Set_Field_Value --
920 ---------------------
922 procedure Set_Field_Value
923 (N
: Node_Id
; Field
: Node_Or_Entity_Field
; Val
: Field_Size_32_Bit
)
925 pragma Assert
(Field_Checking
.Field_Present
(N
, Field
));
926 Desc
: Field_Descriptor
renames Field_Descriptors
(Field
);
929 case Field_Size
(Desc
.Kind
) is
930 when 1 => Set_1_Bit_Val
(N
, Desc
.Offset
, Field_Size_1_Bit
(Val
));
931 when 2 => Set_2_Bit_Val
(N
, Desc
.Offset
, Field_Size_2_Bit
(Val
));
932 when 4 => Set_4_Bit_Val
(N
, Desc
.Offset
, Field_Size_4_Bit
(Val
));
933 when 8 => Set_8_Bit_Val
(N
, Desc
.Offset
, Field_Size_8_Bit
(Val
));
934 when others => Set_32_Bit_Val
(N
, Desc
.Offset
, Val
); -- 32
938 procedure Reinit_Field_To_Zero
939 (N
: Node_Id
; Field
: Node_Or_Entity_Field
)
942 Set_Field_Value
(N
, Field
, 0);
943 end Reinit_Field_To_Zero
;
945 function Field_Is_Initial_Zero
946 (N
: Node_Id
; Field
: Node_Or_Entity_Field
) return Boolean is
948 return Get_Field_Value
(N
, Field
) = 0;
949 end Field_Is_Initial_Zero
;
951 procedure Reinit_Field_To_Zero
952 (N
: Node_Id
; Field
: Entity_Field
; Old_Ekind
: Entity_Kind_Set
) is
954 pragma Assert
(Old_Ekind
(Ekind
(N
)), "Reinit: " & Ekind
(N
)'Img);
955 Reinit_Field_To_Zero
(N
, Field
);
956 end Reinit_Field_To_Zero
;
958 procedure Reinit_Field_To_Zero
959 (N
: Node_Id
; Field
: Entity_Field
; Old_Ekind
: Entity_Kind
) is
960 Old_Ekind_Set
: Entity_Kind_Set
:= (others => False);
962 Old_Ekind_Set
(Old_Ekind
) := True;
963 Reinit_Field_To_Zero
(N
, Field
, Old_Ekind
=> Old_Ekind_Set
);
964 end Reinit_Field_To_Zero
;
966 procedure Check_Vanishing_Fields
967 (Old_N
: Node_Id
; New_Kind
: Node_Kind
)
969 -- If this fails, see comments in the spec of Mutate_Nkind and in
970 -- Check_Vanishing_Fields for entities below.
972 Old_Kind
: constant Node_Kind
:= Nkind
(Old_N
);
974 for J
in Node_Field_Table
(Old_Kind
)'Range loop
976 F
: constant Node_Field
:= Node_Field_Table
(Old_Kind
) (J
);
978 if not Field_Checking
.Field_Present
(New_Kind
, F
) then
979 if not Field_Is_Initial_Zero
(Old_N
, F
) then
980 Write_Str
(Old_Kind
'Img);
982 Write_Str
(New_Kind
'Img);
983 Write_Str
(" Nonzero field ");
985 Write_Str
(" is vanishing for node ");
986 Write_Int
(Nat
(Old_N
));
994 end Check_Vanishing_Fields
;
996 procedure Check_Vanishing_Fields
997 (Old_N
: Entity_Id
; New_Kind
: Entity_Kind
)
999 -- If this fails, it means Mutate_Ekind is changing the Ekind from
1000 -- Old_Kind to New_Kind, such that some field F exists in Old_Kind but
1001 -- not in New_Kind, and F contains non-default information. The usual
1002 -- solution is to call Reinit_Field_To_Zero before calling Mutate_Ekind.
1003 -- Another solution is to change Gen_IL so that the new field DOES exist
1004 -- in New_Kind. See also comments in the spec of Mutate_Ekind.
1006 Old_Kind
: constant Entity_Kind
:= Ekind
(Old_N
);
1008 function Same_Node_To_Fetch_From
1009 (N
: Node_Or_Entity_Id
; Field
: Node_Or_Entity_Field
)
1011 -- True if the field should be fetched from N. For most fields, this is
1012 -- true. However, if the field is a "root type only" field, then this is
1013 -- true only if N is the root type. If this is false, then we should not
1014 -- do Reinit_Field_To_Zero, and we should not fail below, because the
1015 -- field is not vanishing from the root type. Similar comments apply to
1016 -- "base type only" and "implementation base type only" fields.
1018 -- We need to ignore exceptions here, because in some cases,
1019 -- Node_To_Fetch_From is being called before the relevant (root, base)
1020 -- type has been set, so we fail some assertions.
1022 function Same_Node_To_Fetch_From
1023 (N
: Node_Or_Entity_Id
; Field
: Node_Or_Entity_Field
)
1026 return N
= Node_To_Fetch_From
(N
, Field
);
1028 when others => return False; -- ignore the exception
1029 end Same_Node_To_Fetch_From
;
1031 -- Start of processing for Check_Vanishing_Fields
1034 for J
in Entity_Field_Table
(Old_Kind
)'Range loop
1036 F
: constant Entity_Field
:= Entity_Field_Table
(Old_Kind
) (J
);
1038 if not Same_Node_To_Fetch_From
(Old_N
, F
) then
1039 null; -- no check in this case
1040 elsif not Field_Checking
.Field_Present
(New_Kind
, F
) then
1041 if not Field_Is_Initial_Zero
(Old_N
, F
) then
1043 Write_Str
(Osint
.Get_First_Main_File_Name
);
1045 Write_Str
(Old_Kind
'Img);
1046 Write_Str
(" --> ");
1047 Write_Str
(New_Kind
'Img);
1048 Write_Str
(" Nonzero field ");
1050 Write_Str
(" is vanishing ");
1052 if New_Kind
= E_Void
or else Old_Kind
= E_Void
then
1053 Write_Line
("(E_Void case)");
1055 Write_Line
("(non-E_Void case)");
1058 Write_Str
(" ...mutating node ");
1059 Write_Int
(Nat
(Old_N
));
1061 raise Program_Error
;
1066 end Check_Vanishing_Fields
;
1068 Nkind_Offset
: constant Field_Offset
:= Field_Descriptors
(F_Nkind
).Offset
;
1070 procedure Set_Node_Kind_Type
is new Set_8_Bit_Field
(Node_Kind
) with Inline
;
1072 procedure Init_Nkind
(N
: Node_Id
; Val
: Node_Kind
) is
1073 pragma Assert
(Field_Is_Initial_Zero
(N
, F_Nkind
));
1075 if Atree_Statistics_Enabled
then
1076 Set_Count
(F_Nkind
) := Set_Count
(F_Nkind
) + 1;
1079 Set_Node_Kind_Type
(N
, Nkind_Offset
, Val
);
1082 procedure Mutate_Nkind
1083 (N
: Node_Id
; Val
: Node_Kind
; Old_Size
: Slot_Count
)
1085 New_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Val
);
1087 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
1088 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
1090 pragma Assert
(Nkind
(N
) /= Val
);
1092 pragma Debug
(Check_Vanishing_Fields
(N
, Val
));
1094 -- Grow the slots if necessary
1096 if Old_Size
< New_Size
then
1098 Old_Last_Slot
: constant Node_Offset
:= Slots
.Last
;
1099 Old_Off_F
: constant Node_Offset
:= Off_F
(N
);
1101 if Old_Last_Slot
= Old_Off_F
+ Old_Size
- 1 then
1102 -- In this case, the slots are at the end of Slots.Table, so we
1103 -- don't need to move them.
1104 Slots
.Set_Last
(Old_Last_Slot
+ New_Size
- Old_Size
);
1110 New_Off_F
: constant Node_Offset
:= Alloc_Slots
(New_Size
);
1112 All_Node_Offsets
(N
).Offset
:= New_Off_F
- N_Head
;
1113 Copy_Dynamic_Slots
(Old_Off_F
, New_Off_F
, Old_Size
);
1115 (Zero_Dynamic_Slots
(Old_Off_F
, Old_Off_F
+ Old_Size
- 1));
1120 Zero_Dynamic_Slots
(Off_F
(N
) + Old_Size
, Slots
.Last
);
1123 if Atree_Statistics_Enabled
then
1124 Set_Count
(F_Nkind
) := Set_Count
(F_Nkind
) + 1;
1127 Set_Node_Kind_Type
(N
, Nkind_Offset
, Val
);
1128 pragma Debug
(Validate_Node_Write
(N
));
1130 New_Node_Debugging_Output
(N
);
1133 procedure Mutate_Nkind
(N
: Node_Id
; Val
: Node_Kind
) is
1135 Mutate_Nkind
(N
, Val
, Old_Size
=> Size_In_Slots_Dynamic
(N
));
1138 Ekind_Offset
: constant Field_Offset
:= Field_Descriptors
(F_Ekind
).Offset
;
1140 procedure Set_Entity_Kind_Type
is new Set_8_Bit_Field
(Entity_Kind
)
1143 procedure Mutate_Ekind
(N
: Entity_Id
; Val
: Entity_Kind
) is
1145 if Ekind
(N
) = Val
then
1149 pragma Assert
(Val
/= E_Void
);
1150 pragma Debug
(Check_Vanishing_Fields
(N
, Val
));
1152 -- For now, we are allocating all entities with the same size, so we
1153 -- don't need to reallocate slots here.
1155 if Atree_Statistics_Enabled
then
1156 Set_Count
(F_Ekind
) := Set_Count
(F_Ekind
) + 1;
1159 Set_Entity_Kind_Type
(N
, Ekind_Offset
, Val
);
1160 pragma Debug
(Validate_Node_Write
(N
));
1162 New_Node_Debugging_Output
(N
);
1165 -----------------------
1166 -- Allocate_New_Node --
1167 -----------------------
1169 function Allocate_New_Node
(Kind
: Node_Kind
) return Node_Id
is
1171 return Result
: constant Node_Id
:= Alloc_Node_Id
do
1173 Sz
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Kind
);
1174 Sl
: constant Node_Offset
:= Alloc_Slots
(Sz
);
1176 Node_Offsets
.Table
(Result
).Offset
:= Sl
- N_Head
;
1177 Zero_Dynamic_Slots
(Sl
, Sl
+ Sz
- 1);
1178 Zero_Header_Slots
(Result
);
1181 Init_Nkind
(Result
, Kind
);
1183 Orig_Nodes
.Append
(Result
);
1184 Set_Comes_From_Source
(Result
, Comes_From_Source_Default
);
1185 Allocate_List_Tables
(Result
);
1186 Report
(Target
=> Result
, Source
=> Empty
);
1188 end Allocate_New_Node
;
1190 --------------------------
1191 -- Check_Error_Detected --
1192 --------------------------
1194 procedure Check_Error_Detected
is
1196 -- An anomaly has been detected which is assumed to be a consequence of
1197 -- a previous serious error or configurable run time violation. Raise
1198 -- an exception if no such error has been detected.
1200 if Serious_Errors_Detected
= 0
1201 and then Configurable_Run_Time_Violations
= 0
1203 raise Program_Error
;
1205 end Check_Error_Detected
;
1211 procedure Change_Node
(N
: Node_Id
; New_Kind
: Node_Kind
) is
1212 pragma Debug
(Validate_Node_Write
(N
));
1213 pragma Assert
(Nkind
(N
) not in N_Entity
);
1214 pragma Assert
(New_Kind
not in N_Entity
);
1216 Old_Size
: constant Slot_Count
:= Size_In_Slots_Dynamic
(N
);
1217 New_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(New_Kind
);
1219 Save_Sloc
: constant Source_Ptr
:= Sloc
(N
);
1220 Save_In_List
: constant Boolean := In_List
(N
);
1221 Save_CFS
: constant Boolean := Comes_From_Source
(N
);
1222 Save_Posted
: constant Boolean := Error_Posted
(N
);
1223 Save_CA
: constant Boolean := Check_Actuals
(N
);
1224 Save_Is_IGN
: constant Boolean := Is_Ignored_Ghost_Node
(N
);
1225 Save_Link
: constant Union_Id
:= Link
(N
);
1227 Par_Count
: Nat
:= 0;
1230 if Nkind
(N
) in N_Subexpr
then
1231 Par_Count
:= Paren_Count
(N
);
1234 if New_Size
> Old_Size
then
1236 New_Offset
: constant Field_Offset
:= Alloc_Slots
(New_Size
);
1238 pragma Debug
(Zero_Slots
(N
));
1239 Node_Offsets
.Table
(N
).Offset
:= New_Offset
- N_Head
;
1240 Zero_Dynamic_Slots
(New_Offset
, New_Offset
+ New_Size
- 1);
1241 Zero_Header_Slots
(N
);
1248 Init_Nkind
(N
, New_Kind
); -- Not Mutate, because of Zero_Slots above
1250 Set_Sloc
(N
, Save_Sloc
);
1251 Set_In_List
(N
, Save_In_List
);
1252 Set_Comes_From_Source
(N
, Save_CFS
);
1253 Set_Error_Posted
(N
, Save_Posted
);
1254 Set_Check_Actuals
(N
, Save_CA
);
1255 Set_Is_Ignored_Ghost_Node
(N
, Save_Is_IGN
);
1256 Set_Link
(N
, Save_Link
);
1258 if New_Kind
in N_Subexpr
then
1259 Set_Paren_Count
(N
, Par_Count
);
1263 ------------------------
1264 -- Copy_Dynamic_Slots --
1265 ------------------------
1267 procedure Copy_Dynamic_Slots
1268 (From
, To
: Node_Offset
; Num_Slots
: Slot_Count
)
1270 pragma Assert
(if Num_Slots
/= 0 then From
/= To
);
1272 All_Slots
: Slots
.Table_Type
renames
1273 Slots
.Table
(Slots
.First
.. Slots
.Last
);
1275 Source_Slots
: Slots
.Table_Type
renames
1276 All_Slots
(From
.. From
+ Num_Slots
- 1);
1278 Destination_Slots
: Slots
.Table_Type
renames
1279 All_Slots
(To
.. To
+ Num_Slots
- 1);
1282 Destination_Slots
:= Source_Slots
;
1283 end Copy_Dynamic_Slots
;
1289 procedure Copy_Slots
(Source
, Destination
: Node_Id
) is
1290 pragma Debug
(Validate_Node
(Source
));
1291 pragma Assert
(Source
/= Destination
);
1293 S_Size
: constant Slot_Count
:= Size_In_Slots_Dynamic
(Source
);
1295 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
1296 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
1299 -- Empty_Or_Error use as described in types.ads
1300 if Destination
<= Empty_Or_Error
or No
(Source
) then
1301 pragma Assert
(Serious_Errors_Detected
> 0);
1306 (Off_F
(Source
), Off_F
(Destination
), S_Size
);
1307 All_Node_Offsets
(Destination
).Slots
:= All_Node_Offsets
(Source
).Slots
;
1314 procedure Copy_Node
(Source
, Destination
: Node_Or_Entity_Id
) is
1315 pragma Assert
(Source
/= Destination
);
1317 Save_In_List
: constant Boolean := In_List
(Destination
);
1318 Save_Link
: constant Union_Id
:= Link
(Destination
);
1320 S_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Source
);
1321 D_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Destination
);
1324 New_Node_Debugging_Output
(Source
);
1325 New_Node_Debugging_Output
(Destination
);
1327 -- Currently all entities are allocated the same number of slots.
1328 -- Hopefully that won't always be the case, but if it is, the following
1329 -- is suboptimal if D_Size < S_Size, because in fact the Destination was
1330 -- allocated the max.
1332 -- If Source doesn't fit in Destination, we need to allocate
1334 if D_Size
< S_Size
then
1335 pragma Debug
(Zero_Slots
(Destination
)); -- destroy old slots
1336 Node_Offsets
.Table
(Destination
).Offset
:=
1337 Alloc_Slots
(S_Size
) - N_Head
;
1340 Copy_Slots
(Source
, Destination
);
1342 Set_In_List
(Destination
, Save_In_List
);
1343 Set_Link
(Destination
, Save_Link
);
1344 Set_Paren_Count_Of_Copy
(Target
=> Destination
, Source
=> Source
);
1347 ------------------------
1348 -- Copy_Separate_List --
1349 ------------------------
1351 function Copy_Separate_List
(Source
: List_Id
) return List_Id
is
1352 Result
: constant List_Id
:= New_List
;
1353 Nod
: Node_Id
:= First
(Source
);
1356 while Present
(Nod
) loop
1357 Append
(Copy_Separate_Tree
(Nod
), Result
);
1362 end Copy_Separate_List
;
1364 ------------------------
1365 -- Copy_Separate_Tree --
1366 ------------------------
1368 function Copy_Separate_Tree
(Source
: Node_Id
) return Node_Id
is
1370 pragma Debug
(Validate_Node
(Source
));
1374 function Copy_Entity
(E
: Entity_Id
) return Entity_Id
;
1375 -- Copy Entity, copying only Chars field
1377 function Copy_List
(List
: List_Id
) return List_Id
;
1380 function Possible_Copy
(Field
: Union_Id
) return Union_Id
;
1381 -- Given a field, returns a copy of the node or list if its parent is
1382 -- the current source node, and otherwise returns the input.
1388 function Copy_Entity
(E
: Entity_Id
) return Entity_Id
is
1390 pragma Assert
(Nkind
(E
) in N_Entity
);
1392 return Result
: constant Entity_Id
:= New_Entity
(Nkind
(E
), Sloc
(E
))
1394 Set_Chars
(Result
, Chars
(E
));
1402 function Copy_List
(List
: List_Id
) return List_Id
is
1407 if List
= No_List
then
1414 while Present
(E
) loop
1415 Append
(Copy_Separate_Tree
(E
), NL
);
1427 function Possible_Copy
(Field
: Union_Id
) return Union_Id
is
1431 if Field
in Node_Range
then
1432 New_N
:= Union_Id
(Copy_Separate_Tree
(Node_Id
(Field
)));
1434 if Present
(Node_Id
(Field
))
1435 and then Is_Syntactic_Node
(Source
, Node_Id
(Field
))
1437 Set_Parent
(Node_Id
(New_N
), New_Id
);
1442 elsif Field
in List_Range
then
1443 New_N
:= Union_Id
(Copy_List
(List_Id
(Field
)));
1445 if Parent
(List_Id
(Field
)) = Source
then
1446 Set_Parent
(List_Id
(New_N
), New_Id
);
1456 procedure Walk
is new Walk_Sinfo_Fields_Pairwise
(Possible_Copy
);
1458 -- Start of processing for Copy_Separate_Tree
1461 if Source
<= Empty_Or_Error
then
1464 elsif Is_Entity
(Source
) then
1465 return Copy_Entity
(Source
);
1468 New_Id
:= New_Copy
(Source
);
1470 Walk
(New_Id
, Source
);
1472 -- Set Entity field to Empty to ensure that no entity references
1473 -- are shared between the two, if the source is already analyzed.
1475 if Nkind
(New_Id
) in N_Has_Entity
1476 or else Nkind
(New_Id
) = N_Freeze_Entity
1478 Set_Entity
(New_Id
, Empty
);
1481 -- Reset all Etype fields and Analyzed flags, because input tree may
1482 -- have been fully or partially analyzed.
1484 if Nkind
(New_Id
) in N_Has_Etype
then
1485 Set_Etype
(New_Id
, Empty
);
1488 Set_Analyzed
(New_Id
, False);
1490 -- Rather special case, if we have an expanded name, then change
1491 -- it back into a selected component, so that the tree looks the
1492 -- way it did coming out of the parser. This will change back
1493 -- when we analyze the selected component node.
1495 if Nkind
(New_Id
) = N_Expanded_Name
then
1497 -- The following code is a bit kludgy. It would be cleaner to
1498 -- Add an entry Change_Expanded_Name_To_Selected_Component to
1499 -- Sinfo.CN, but that's delicate because Atree is used in the
1500 -- binder, so we don't want to add that dependency.
1501 -- ??? Revisit now that ASIS is no longer using this unit.
1503 -- Consequently we have no choice but to hold our noses and do the
1504 -- change manually. At least we are Atree, so this is at least all
1507 -- Clear the Chars field which is not present in a selected
1508 -- component node, so we don't want a junk value around. Note that
1509 -- we can't just call Set_Chars, because Empty is of the wrong
1510 -- type, and is outside the range of Name_Id.
1512 Reinit_Field_To_Zero
(New_Id
, F_Chars
);
1513 Reinit_Field_To_Zero
(New_Id
, F_Has_Private_View
);
1514 Reinit_Field_To_Zero
(New_Id
, F_Is_Elaboration_Checks_OK_Node
);
1515 Reinit_Field_To_Zero
(New_Id
, F_Is_Elaboration_Warnings_OK_Node
);
1516 Reinit_Field_To_Zero
(New_Id
, F_Is_SPARK_Mode_On_Node
);
1518 -- Change the node type
1520 Mutate_Nkind
(New_Id
, N_Selected_Component
);
1523 -- All done, return copied node
1527 end Copy_Separate_Tree
;
1529 -----------------------
1530 -- Exchange_Entities --
1531 -----------------------
1533 procedure Exchange_Entities
(E1
: Entity_Id
; E2
: Entity_Id
) is
1534 pragma Debug
(Validate_Node_Write
(E1
));
1535 pragma Debug
(Validate_Node_Write
(E2
));
1537 (Is_Entity
(E1
) and then Is_Entity
(E2
)
1538 and then not In_List
(E1
) and then not In_List
(E2
));
1540 Old_E1
: constant Node_Header
:= Node_Offsets
.Table
(E1
);
1543 Node_Offsets
.Table
(E1
) := Node_Offsets
.Table
(E2
);
1544 Node_Offsets
.Table
(E2
) := Old_E1
;
1546 -- That exchange exchanged the parent pointers as well, which is what
1547 -- we want, but we need to patch up the defining identifier pointers
1548 -- in the parent nodes (the child pointers) to match this switch
1549 -- unless for Implicit types entities which have no parent, in which
1550 -- case we don't do anything otherwise we won't be able to revert back
1551 -- to the original situation.
1553 -- Shouldn't this use Is_Itype instead of the Parent test???
1555 if Present
(Parent
(E1
)) and then Present
(Parent
(E2
)) then
1556 Set_Defining_Identifier
(Parent
(E1
), E1
);
1557 Set_Defining_Identifier
(Parent
(E2
), E2
);
1560 New_Node_Debugging_Output
(E1
);
1561 New_Node_Debugging_Output
(E2
);
1562 end Exchange_Entities
;
1568 procedure Extend_Node
(Source
: Node_Id
) is
1569 pragma Assert
(Present
(Source
));
1570 pragma Assert
(not Is_Entity
(Source
));
1572 Old_Kind
: constant Node_Kind
:= Nkind
(Source
);
1573 pragma Assert
(Old_Kind
in N_Direct_Name
);
1574 New_Kind
: constant Node_Kind
:=
1576 when N_Character_Literal
=> N_Defining_Character_Literal
,
1577 when N_Identifier
=> N_Defining_Identifier
,
1578 when N_Operator_Symbol
=> N_Defining_Operator_Symbol
,
1579 when others => N_Unused_At_Start
); -- can't happen
1580 -- The new NKind, which is the appropriate value of N_Entity based on
1581 -- the old Nkind. N_xxx is mapped to N_Defining_xxx.
1582 pragma Assert
(New_Kind
in N_Entity
);
1584 -- Start of processing for Extend_Node
1587 Set_Check_Actuals
(Source
, False);
1588 Mutate_Nkind
(Source
, New_Kind
);
1589 Report
(Target
=> Source
, Source
=> Source
);
1596 procedure Fix_Parents
(Ref_Node
, Fix_Node
: Node_Id
) is
1597 pragma Assert
(Nkind
(Ref_Node
) = Nkind
(Fix_Node
));
1599 procedure Fix_Parent
(Field
: Union_Id
);
1600 -- Fix up one parent pointer. Field is checked to see if it points to
1601 -- a node, list, or element list that has a parent that points to
1602 -- Ref_Node. If so, the parent is reset to point to Fix_Node.
1608 procedure Fix_Parent
(Field
: Union_Id
) is
1610 -- Fix parent of node that is referenced by Field. Note that we must
1611 -- exclude the case where the node is a member of a list, because in
1612 -- this case the parent is the parent of the list.
1614 if Field
in Node_Range
1615 and then Present
(Node_Id
(Field
))
1616 and then not In_List
(Node_Id
(Field
))
1617 and then Parent
(Node_Id
(Field
)) = Ref_Node
1619 Set_Parent
(Node_Id
(Field
), Fix_Node
);
1621 -- Fix parent of list that is referenced by Field
1623 elsif Field
in List_Range
1624 and then Present
(List_Id
(Field
))
1625 and then Parent
(List_Id
(Field
)) = Ref_Node
1627 Set_Parent
(List_Id
(Field
), Fix_Node
);
1631 Fields
: Node_Field_Array
renames
1632 Node_Field_Table
(Nkind
(Fix_Node
)).all;
1634 -- Start of processing for Fix_Parents
1637 for J
in Fields
'Range loop
1639 Desc
: Field_Descriptor
renames Field_Descriptors
(Fields
(J
));
1641 if Desc
.Kind
in Node_Id_Field | List_Id_Field
then
1642 Fix_Parent
(Get_Node_Field_Union
(Fix_Node
, Desc
.Offset
));
1648 -----------------------------------
1649 -- Get_Comes_From_Source_Default --
1650 -----------------------------------
1652 function Get_Comes_From_Source_Default
return Boolean is
1654 return Comes_From_Source_Default
;
1655 end Get_Comes_From_Source_Default
;
1661 function Is_Entity
(N
: Node_Or_Entity_Id
) return Boolean is
1663 return Nkind
(N
) in N_Entity
;
1666 -----------------------
1667 -- Is_Syntactic_Node --
1668 -----------------------
1670 function Is_Syntactic_Node
1675 function Has_More_Ids
(N
: Node_Id
) return Boolean;
1676 -- Return True when N has attribute More_Ids set to True
1682 function Has_More_Ids
(N
: Node_Id
) return Boolean is
1684 if Nkind
(N
) in N_Component_Declaration
1685 | N_Discriminant_Specification
1686 | N_Exception_Declaration
1687 | N_Formal_Object_Declaration
1688 | N_Number_Declaration
1689 | N_Object_Declaration
1690 | N_Parameter_Specification
1691 | N_Use_Package_Clause
1694 return More_Ids
(N
);
1700 -- Start of processing for Is_Syntactic_Node
1703 if Parent
(Field
) = Source
then
1706 -- Perform the check using the last id in the syntactic chain
1708 elsif Has_More_Ids
(Source
) then
1710 N
: Node_Id
:= Source
;
1713 while Present
(N
) and then More_Ids
(N
) loop
1717 pragma Assert
(Prev_Ids
(N
));
1718 return Parent
(Field
) = N
;
1724 end Is_Syntactic_Node
;
1730 procedure Initialize
is
1732 pragma Warnings
(Off
, Dummy
);
1735 -- Allocate Empty node
1737 Dummy
:= New_Node
(N_Empty
, No_Location
);
1738 Set_Chars
(Empty
, No_Name
);
1739 pragma Assert
(Dummy
= Empty
);
1741 -- Allocate Error node, and set Error_Posted, since we certainly
1742 -- only generate an Error node if we do post some kind of error.
1744 Dummy
:= New_Node
(N_Error
, No_Location
);
1745 Set_Chars
(Error
, Error_Name
);
1746 Set_Error_Posted
(Error
, True);
1747 pragma Assert
(Dummy
= Error
);
1750 --------------------------
1751 -- Is_Rewrite_Insertion --
1752 --------------------------
1754 function Is_Rewrite_Insertion
(Node
: Node_Id
) return Boolean is
1756 return Rewrite_Ins
(Node
);
1757 end Is_Rewrite_Insertion
;
1759 -----------------------------
1760 -- Is_Rewrite_Substitution --
1761 -----------------------------
1763 function Is_Rewrite_Substitution
(Node
: Node_Id
) return Boolean is
1765 return Orig_Nodes
.Table
(Node
) /= Node
;
1766 end Is_Rewrite_Substitution
;
1772 function Last_Node_Id
return Node_Id
is
1774 return Node_Offsets
.Last
;
1783 Orig_Nodes
.Locked
:= True;
1790 procedure Lock_Nodes
is
1792 pragma Assert
(not Locked
);
1796 -------------------------
1797 -- Mark_New_Ghost_Node --
1798 -------------------------
1800 procedure Mark_New_Ghost_Node
(N
: Node_Or_Entity_Id
) is
1802 pragma Debug
(Validate_Node_Write
(N
));
1804 -- The Ghost node is created within a Ghost region
1806 if Ghost_Mode
= Check
then
1807 if Nkind
(N
) in N_Entity
then
1808 Set_Is_Checked_Ghost_Entity
(N
);
1811 elsif Ghost_Mode
= Ignore
then
1812 if Nkind
(N
) in N_Entity
then
1813 Set_Is_Ignored_Ghost_Entity
(N
);
1816 Set_Is_Ignored_Ghost_Node
(N
);
1818 -- Record the ignored Ghost node or entity in order to eliminate it
1819 -- from the tree later.
1821 if Ignored_Ghost_Recording_Proc
/= null then
1822 Ignored_Ghost_Recording_Proc
.all (N
);
1825 end Mark_New_Ghost_Node
;
1827 ----------------------------
1828 -- Mark_Rewrite_Insertion --
1829 ----------------------------
1831 procedure Mark_Rewrite_Insertion
(New_Node
: Node_Id
) is
1833 Set_Rewrite_Ins
(New_Node
);
1834 end Mark_Rewrite_Insertion
;
1840 function New_Copy
(Source
: Node_Id
) return Node_Id
is
1841 pragma Debug
(Validate_Node
(Source
));
1842 S_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Source
);
1844 if Source
<= Empty_Or_Error
then
1848 return New_Id
: constant Node_Id
:= Alloc_Node_Id
do
1849 Node_Offsets
.Table
(New_Id
).Offset
:=
1850 Alloc_Slots
(S_Size
) - N_Head
;
1851 Orig_Nodes
.Append
(New_Id
);
1852 Copy_Slots
(Source
, New_Id
);
1854 Set_Check_Actuals
(New_Id
, False);
1855 Set_Paren_Count_Of_Copy
(Target
=> New_Id
, Source
=> Source
);
1857 Allocate_List_Tables
(New_Id
);
1858 Report
(Target
=> New_Id
, Source
=> Source
);
1860 Set_In_List
(New_Id
, False);
1861 Set_Link
(New_Id
, Empty_List_Or_Node
);
1863 -- If the original is marked as a rewrite insertion, then unmark the
1864 -- copy, since we inserted the original, not the copy.
1866 Set_Rewrite_Ins
(New_Id
, False);
1868 -- Clear Is_Overloaded since we cannot have semantic interpretations
1869 -- of this new node.
1871 if Nkind
(Source
) in N_Subexpr
then
1872 Set_Is_Overloaded
(New_Id
, False);
1875 -- Mark the copy as Ghost depending on the current Ghost region
1877 if Nkind
(New_Id
) in N_Entity
then
1878 Set_Is_Checked_Ghost_Entity
(New_Id
, False);
1879 Set_Is_Ignored_Ghost_Entity
(New_Id
, False);
1882 Mark_New_Ghost_Node
(New_Id
);
1884 New_Node_Debugging_Output
(New_Id
);
1886 pragma Assert
(New_Id
/= Source
);
1895 (New_Node_Kind
: Node_Kind
;
1896 New_Sloc
: Source_Ptr
) return Entity_Id
1898 pragma Assert
(New_Node_Kind
in N_Entity
);
1899 New_Id
: constant Entity_Id
:= Allocate_New_Node
(New_Node_Kind
);
1900 pragma Assert
(Original_Node
(Node_Offsets
.Last
) = Node_Offsets
.Last
);
1902 -- If this is a node with a real location and we are generating
1903 -- source nodes, then reset Current_Error_Node. This is useful
1904 -- if we bomb during parsing to get a error location for the bomb.
1906 if New_Sloc
> No_Location
and then Comes_From_Source_Default
then
1907 Current_Error_Node
:= New_Id
;
1910 Set_Sloc
(New_Id
, New_Sloc
);
1912 -- Mark the new entity as Ghost depending on the current Ghost region
1914 Mark_New_Ghost_Node
(New_Id
);
1916 New_Node_Debugging_Output
(New_Id
);
1926 (New_Node_Kind
: Node_Kind
;
1927 New_Sloc
: Source_Ptr
) return Node_Id
1929 pragma Assert
(New_Node_Kind
not in N_Entity
);
1930 New_Id
: constant Node_Id
:= Allocate_New_Node
(New_Node_Kind
);
1931 pragma Assert
(Original_Node
(Node_Offsets
.Last
) = Node_Offsets
.Last
);
1933 Set_Sloc
(New_Id
, New_Sloc
);
1935 -- If this is a node with a real location and we are generating source
1936 -- nodes, then reset Current_Error_Node. This is useful if we bomb
1937 -- during parsing to get an error location for the bomb.
1939 if Comes_From_Source_Default
and then New_Sloc
> No_Location
then
1940 Current_Error_Node
:= New_Id
;
1943 -- Mark the new node as Ghost depending on the current Ghost region
1945 Mark_New_Ghost_Node
(New_Id
);
1947 New_Node_Debugging_Output
(New_Id
);
1956 function No
(N
: Node_Id
) return Boolean is
1965 function Node_Offsets_Address
return System
.Address
is
1967 return Node_Offsets
.Table
(First_Node_Id
)'Address;
1968 end Node_Offsets_Address
;
1970 function Slots_Address
return System
.Address
is
1971 Slot_Byte_Size
: constant := 4;
1972 pragma Assert
(Slot_Byte_Size
* 8 = Slot
'Size);
1973 Extra
: constant := Slots_Low_Bound
* Slot_Byte_Size
;
1974 -- Slots does not start at 0, so we need to subtract off the extra
1975 -- amount. We are returning Slots.Table (0)'Address, except that
1976 -- that component does not exist.
1977 use System
.Storage_Elements
;
1979 return Slots
.Table
(Slots_Low_Bound
)'Address - Extra
;
1982 -----------------------------------
1983 -- Approx_Num_Nodes_And_Entities --
1984 -----------------------------------
1986 function Approx_Num_Nodes_And_Entities
return Nat
is
1988 return Nat
(Node_Offsets
.Last
- First_Node_Id
);
1989 end Approx_Num_Nodes_And_Entities
;
1995 function Off_0
(N
: Node_Id
) return Node_Offset
'Base is
1996 pragma Debug
(Validate_Node
(N
));
1998 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
1999 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
2001 return All_Node_Offsets
(N
).Offset
;
2008 function Off_F
(N
: Node_Id
) return Node_Offset
is
2010 return Off_0
(N
) + N_Head
;
2017 function Off_L
(N
: Node_Id
) return Node_Offset
is
2018 pragma Debug
(Validate_Node
(N
));
2020 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
2021 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
2023 return All_Node_Offsets
(N
).Offset
+ Size_In_Slots
(N
) - 1;
2030 function Original_Node
(Node
: Node_Id
) return Node_Id
is
2032 pragma Debug
(Validate_Node
(Node
));
2033 if Atree_Statistics_Enabled
then
2034 Get_Original_Node_Count
:= Get_Original_Node_Count
+ 1;
2037 return Orig_Nodes
.Table
(Node
);
2044 function Paren_Count
(N
: Node_Id
) return Nat
is
2045 pragma Debug
(Validate_Node
(N
));
2047 C
: constant Small_Paren_Count_Type
:= Small_Paren_Count
(N
);
2050 -- Value of 0,1,2 returned as is
2055 -- Value of 3 means we search the table, and we must find an entry
2058 for J
in Paren_Counts
.First
.. Paren_Counts
.Last
loop
2059 if N
= Paren_Counts
.Table
(J
).Nod
then
2060 return Paren_Counts
.Table
(J
).Count
;
2064 raise Program_Error
;
2068 function Node_Parent
(N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
is
2070 pragma Assert
(Present
(N
));
2072 if Is_List_Member
(N
) then
2073 return Parent
(List_Containing
(N
));
2075 return Node_Or_Entity_Id
(Link
(N
));
2083 function Present
(N
: Node_Id
) return Boolean is
2088 --------------------------------
2089 -- Preserve_Comes_From_Source --
2090 --------------------------------
2092 procedure Preserve_Comes_From_Source
(NewN
, OldN
: Node_Id
) is
2094 Set_Comes_From_Source
(NewN
, Comes_From_Source
(OldN
));
2095 end Preserve_Comes_From_Source
;
2101 function Relocate_Node
(Source
: Node_Id
) return Node_Id
is
2109 New_Node
:= New_Copy
(Source
);
2110 Fix_Parents
(Ref_Node
=> Source
, Fix_Node
=> New_Node
);
2112 -- We now set the parent of the new node to be the same as the parent of
2113 -- the source. Almost always this parent will be replaced by a new value
2114 -- when the relocated node is reattached to the tree, but by doing it
2115 -- now, we ensure that this node is not even temporarily disconnected
2116 -- from the tree. Note that this does not happen free, because in the
2117 -- list case, the parent does not get set.
2119 Set_Parent
(New_Node
, Parent
(Source
));
2121 -- If the node being relocated was a rewriting of some original node,
2122 -- then the relocated node has the same original node.
2124 if Is_Rewrite_Substitution
(Source
) then
2125 Set_Original_Node
(New_Node
, Original_Node
(Source
));
2128 -- If we're relocating a subprogram call and we're doing
2129 -- unnesting, be sure we make a new copy of any parameter associations
2130 -- so that we don't share them.
2132 if Nkind
(Source
) in N_Subprogram_Call
2133 and then Opt
.Unnest_Subprogram_Mode
2134 and then Present
(Parameter_Associations
(Source
))
2137 New_Assoc
: constant List_Id
:= Parameter_Associations
(Source
);
2139 Set_Parent
(New_Assoc
, New_Node
);
2140 Set_Parameter_Associations
(New_Node
, New_Assoc
);
2151 procedure Replace
(Old_Node
, New_Node
: Node_Id
) is
2152 Old_Post
: constant Boolean := Error_Posted
(Old_Node
);
2153 Old_CFS
: constant Boolean := Comes_From_Source
(Old_Node
);
2155 procedure Destroy_New_Node
;
2156 -- Overwrite New_Node data with junk, for debugging purposes
2158 procedure Destroy_New_Node
is
2160 Zero_Slots
(New_Node
);
2161 Node_Offsets
.Table
(New_Node
).Offset
:= Field_Offset
'Base'Last;
2162 end Destroy_New_Node;
2165 New_Node_Debugging_Output (Old_Node);
2166 New_Node_Debugging_Output (New_Node);
2169 (not Is_Entity (Old_Node)
2170 and not Is_Entity (New_Node)
2171 and not In_List (New_Node)
2172 and Old_Node /= New_Node);
2174 -- Do copy, preserving link and in list status and required flags
2176 Copy_Node (Source => New_Node, Destination => Old_Node);
2177 Set_Comes_From_Source (Old_Node, Old_CFS);
2178 Set_Error_Posted (Old_Node, Old_Post);
2180 -- Fix parents of substituted node, since it has changed identity
2182 Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);
2184 pragma Debug (Destroy_New_Node);
2186 -- Since we are doing a replace, we assume that the original node
2187 -- is intended to become the new replaced node. The call would be
2188 -- to Rewrite if there were an intention to save the original node.
2190 Set_Original_Node (Old_Node, Old_Node);
2192 -- Invoke the reporting procedure (if available)
2194 if Reporting_Proc /= null then
2195 Reporting_Proc.all (Target => Old_Node, Source => New_Node);
2203 procedure Report (Target, Source : Node_Id) is
2205 if Reporting_Proc /= null then
2206 Reporting_Proc.all (Target, Source);
2214 procedure Rewrite (Old_Node, New_Node : Node_Id) is
2215 Old_CA : constant Boolean := Check_Actuals (Old_Node);
2216 Old_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Old_Node);
2217 Old_Error_Posted : constant Boolean :=
2218 Error_Posted (Old_Node);
2220 Old_Must_Not_Freeze : constant Boolean :=
2221 (if Nkind (Old_Node) in N_Subexpr then Must_Not_Freeze (Old_Node)
2223 Old_Paren_Count : constant Nat :=
2224 (if Nkind (Old_Node) in N_Subexpr then Paren_Count (Old_Node) else 0);
2225 -- These fields are preserved in the new node only if the new node and
2226 -- the old node are both subexpression nodes. We might be changing Nkind
2227 -- (Old_Node) from not N_Subexpr to N_Subexpr, so we need a value
2228 -- (False/0) even if Old_Noed is not a N_Subexpr.
2230 -- Note: it is a violation of abstraction levels for Must_Not_Freeze
2231 -- to be referenced like this. ???
2236 New_Node_Debugging_Output (Old_Node);
2237 New_Node_Debugging_Output (New_Node);
2240 (not Is_Entity (Old_Node)
2241 and not Is_Entity (New_Node)
2242 and not In_List (New_Node));
2244 -- Allocate a new node, to be used to preserve the original contents
2245 -- of the Old_Node, for possible later retrival by Original_Node and
2246 -- make an entry in the Orig_Nodes table. This is only done if we have
2247 -- not already rewritten the node, as indicated by an Orig_Nodes entry
2248 -- that does not reference the Old_Node.
2250 if not Is_Rewrite_Substitution (Old_Node) then
2251 Sav_Node := New_Copy (Old_Node);
2252 Set_Original_Node (Sav_Node, Sav_Node);
2253 Set_Original_Node (Old_Node, Sav_Node);
2256 -- Copy substitute node into place, preserving old fields as required
2258 Copy_Node (Source => New_Node, Destination => Old_Node);
2259 Set_Error_Posted (Old_Node, Old_Error_Posted);
2261 Set_Check_Actuals (Old_Node, Old_CA);
2262 Set_Is_Ignored_Ghost_Node (Old_Node, Old_Is_IGN);
2264 if Nkind (New_Node) in N_Subexpr then
2265 Set_Paren_Count (Old_Node, Old_Paren_Count);
2266 Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze);
2269 Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);
2271 -- Invoke the reporting procedure (if available)
2273 if Reporting_Proc /= null then
2274 Reporting_Proc.all (Target => Old_Node, Source => New_Node);
2277 -- Invoke the rewriting procedure (if available)
2279 if Rewriting_Proc /= null then
2280 Rewriting_Proc.all (Target => Old_Node, Source => New_Node);
2284 -----------------------------------
2285 -- Set_Comes_From_Source_Default --
2286 -----------------------------------
2288 procedure Set_Comes_From_Source_Default (Default : Boolean) is
2290 Comes_From_Source_Default := Default;
2291 end Set_Comes_From_Source_Default;
2293 --------------------------------------
2294 -- Set_Ignored_Ghost_Recording_Proc --
2295 --------------------------------------
2297 procedure Set_Ignored_Ghost_Recording_Proc
2298 (Proc : Ignored_Ghost_Record_Proc)
2301 pragma Assert (Ignored_Ghost_Recording_Proc = null);
2302 Ignored_Ghost_Recording_Proc := Proc;
2303 end Set_Ignored_Ghost_Recording_Proc;
2305 -----------------------
2306 -- Set_Original_Node --
2307 -----------------------
2309 procedure Set_Original_Node (N : Node_Id; Val : Node_Id) is
2311 pragma Debug (Validate_Node_Write (N));
2312 if Atree_Statistics_Enabled then
2313 Set_Original_Node_Count := Set_Original_Node_Count + 1;
2316 Orig_Nodes.Table (N) := Val;
2317 end Set_Original_Node;
2319 ---------------------
2320 -- Set_Paren_Count --
2321 ---------------------
2323 procedure Set_Paren_Count (N : Node_Id; Val : Nat) is
2325 pragma Debug (Validate_Node_Write (N));
2326 pragma Assert (Nkind (N) in N_Subexpr);
2328 -- Value of 0,1,2 stored as is
2331 Set_Small_Paren_Count (N, Val);
2333 -- Value of 3 or greater stores 3 in node and makes table entry
2336 Set_Small_Paren_Count (N, 3);
2338 -- Search for existing table entry
2340 for J in Paren_Counts.First .. Paren_Counts.Last loop
2341 if N = Paren_Counts.Table (J).Nod then
2342 Paren_Counts.Table (J).Count := Val;
2347 -- No existing table entry; make a new one
2349 Paren_Counts.Append ((Nod => N, Count => Val));
2351 end Set_Paren_Count;
2353 -----------------------------
2354 -- Set_Paren_Count_Of_Copy --
2355 -----------------------------
2357 procedure Set_Paren_Count_Of_Copy (Target, Source : Node_Id) is
2359 -- We already copied the Small_Paren_Count. We need to update the
2360 -- Paren_Counts table only if greater than 2.
2362 if Nkind (Source) in N_Subexpr
2363 and then Small_Paren_Count (Source) = 3
2365 Set_Paren_Count (Target, Paren_Count (Source));
2368 pragma Assert (Paren_Count (Target) = Paren_Count (Source));
2369 end Set_Paren_Count_Of_Copy;
2375 procedure Set_Node_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is
2377 pragma Assert (Present (N));
2378 pragma Assert (not In_List (N));
2379 Set_Link (N, Union_Id (Val));
2380 end Set_Node_Parent;
2382 ------------------------
2383 -- Set_Reporting_Proc --
2384 ------------------------
2386 procedure Set_Reporting_Proc (Proc : Report_Proc) is
2388 pragma Assert (Reporting_Proc = null);
2389 Reporting_Proc := Proc;
2390 end Set_Reporting_Proc;
2392 ------------------------
2393 -- Set_Rewriting_Proc --
2394 ------------------------
2396 procedure Set_Rewriting_Proc (Proc : Rewrite_Proc) is
2398 pragma Assert (Rewriting_Proc = null);
2399 Rewriting_Proc := Proc;
2400 end Set_Rewriting_Proc;
2402 ----------------------------
2403 -- Size_In_Slots_To_Alloc --
2404 ----------------------------
2406 function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count is
2409 (if Kind in N_Entity then Einfo.Entities.Max_Entity_Size
2410 else Sinfo.Nodes.Size (Kind)) - N_Head;
2411 -- Unfortunately, we don't know the Entity_Kind, so we have to use the
2413 end Size_In_Slots_To_Alloc;
2415 function Size_In_Slots_To_Alloc
2416 (N : Node_Or_Entity_Id) return Slot_Count is
2418 return Size_In_Slots_To_Alloc (Nkind (N));
2419 end Size_In_Slots_To_Alloc;
2425 function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count is
2427 pragma Assert (Nkind (N) /= N_Unused_At_Start);
2429 (if Nkind (N) in N_Entity then Einfo.Entities.Max_Entity_Size
2430 else Sinfo.Nodes.Size (Nkind (N)));
2433 ---------------------------
2434 -- Size_In_Slots_Dynamic --
2435 ---------------------------
2437 function Size_In_Slots_Dynamic (N : Node_Or_Entity_Id) return Slot_Count is
2439 return Size_In_Slots (N) - N_Head;
2440 end Size_In_Slots_Dynamic;
2442 -----------------------------------
2443 -- Internal_Traverse_With_Parent --
2444 -----------------------------------
2446 function Internal_Traverse_With_Parent
2447 (Node : Node_Id) return Traverse_Final_Result
2449 Tail_Recursion_Counter : Natural := 0;
2451 procedure Pop_Parents;
2452 -- Pop enclosing nodes of tail recursion plus the current parent.
2454 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result;
2455 -- Fld is one of the Traversed fields of Nod, which is necessarily a
2456 -- Node_Id or List_Id. It is traversed, and the result is the result of
2463 procedure Pop_Parents is
2465 -- Pop the enclosing nodes of the tail recursion
2467 for J in 1 .. Tail_Recursion_Counter loop
2468 Parents_Stack.Decrement_Last;
2471 -- Pop the current node
2473 pragma Assert (Parents_Stack.Table (Parents_Stack.Last) = Node);
2474 Parents_Stack.Decrement_Last;
2477 --------------------
2478 -- Traverse_Field --
2479 --------------------
2481 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result is
2483 if Fld /= Union_Id (Empty) then
2485 -- Descendant is a node
2487 if Fld in Node_Range then
2488 return Internal_Traverse_With_Parent (Node_Id (Fld));
2490 -- Descendant is a list
2492 elsif Fld in List_Range then
2494 Elmt : Node_Id := First (List_Id (Fld));
2496 while Present (Elmt) loop
2497 if Internal_Traverse_With_Parent (Elmt) = Abandon then
2506 raise Program_Error;
2515 Parent_Node : Node_Id := Parents_Stack.Table (Parents_Stack.Last);
2516 Cur_Node : Node_Id := Node;
2518 -- Start of processing for Internal_Traverse_With_Parent
2521 -- If the last field is a node, we eliminate the tail recursion by
2522 -- jumping back to this label. This is because concatenations are
2523 -- sometimes deeply nested, as in X1&X2&...&Xn. Gen_IL ensures that the
2524 -- Left_Opnd field of N_Op_Concat comes last in Traversed_Fields, so the
2525 -- tail recursion is eliminated in that case. This trick prevents us
2526 -- from running out of stack memory in that case. We don't bother
2527 -- eliminating the tail recursion if the last field is a list.
2531 Parents_Stack.Append (Cur_Node);
2533 case Process (Parent_Node, Cur_Node) is
2546 Cur_Node := Original_Node (Cur_Node);
2549 -- Check for empty Traversed_Fields before entering loop below, so the
2550 -- tail recursive step won't go past the end.
2553 Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First;
2554 Offsets : Traversed_Offset_Array renames
2555 Traversed_Fields (Nkind (Cur_Node));
2558 if Offsets (Traversed_Offset_Array'First) /= No_Field_Offset then
2559 while Offsets (Cur_Field + 1) /= No_Field_Offset loop
2561 F : constant Union_Id :=
2562 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
2565 if Traverse_Field (F) = Abandon then
2571 Cur_Field := Cur_Field + 1;
2575 F : constant Union_Id :=
2576 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
2579 if F not in Node_Range then
2580 if Traverse_Field (F) = Abandon then
2585 elsif F /= Empty_List_Or_Node then
2586 -- Here is the tail recursion step, we reset Cur_Node and
2587 -- jump back to the start of the procedure, which has the
2588 -- same semantic effect as a call.
2590 Tail_Recursion_Counter := Tail_Recursion_Counter + 1;
2591 Parent_Node := Cur_Node;
2592 Cur_Node := Node_Id (F);
2601 end Internal_Traverse_With_Parent;
2607 function Traverse_Func (Node : Node_Id) return Traverse_Final_Result is
2608 pragma Debug (Validate_Node (Node));
2610 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result;
2611 -- Fld is one of the Traversed fields of Nod, which is necessarily a
2612 -- Node_Id or List_Id. It is traversed, and the result is the result of
2615 --------------------
2616 -- Traverse_Field --
2617 --------------------
2619 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result is
2621 if Fld /= Union_Id (Empty) then
2623 -- Descendant is a node
2625 if Fld in Node_Range then
2626 return Traverse_Func (Node_Id (Fld));
2628 -- Descendant is a list
2630 elsif Fld in List_Range then
2632 Elmt : Node_Id := First (List_Id (Fld));
2634 while Present (Elmt) loop
2635 if Traverse_Func (Elmt) = Abandon then
2644 raise Program_Error;
2651 Cur_Node : Node_Id := Node;
2653 -- Start of processing for Traverse_Func
2656 -- If the last field is a node, we eliminate the tail recursion by
2657 -- jumping back to this label. This is because concatenations are
2658 -- sometimes deeply nested, as in X1&X2&...&Xn. Gen_IL ensures that the
2659 -- Left_Opnd field of N_Op_Concat comes last in Traversed_Fields, so the
2660 -- tail recursion is eliminated in that case. This trick prevents us
2661 -- from running out of stack memory in that case. We don't bother
2662 -- eliminating the tail recursion if the last field is a list.
2664 -- (To check, look in the body of Sinfo.Nodes, search for the Left_Opnd
2665 -- getter, and note the offset of Left_Opnd. Then look in the spec of
2666 -- Sinfo.Nodes, look at the Traversed_Fields table, search for the
2667 -- N_Op_Concat component. The offset of Left_Opnd should be the last
2668 -- component before the No_Field_Offset sentinels.)
2672 case Process (Cur_Node) is
2683 Cur_Node := Original_Node (Cur_Node);
2686 -- Check for empty Traversed_Fields before entering loop below, so the
2687 -- tail recursive step won't go past the end.
2690 Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First;
2691 Offsets : Traversed_Offset_Array renames
2692 Traversed_Fields (Nkind (Cur_Node));
2695 if Offsets (Traversed_Offset_Array'First) /= No_Field_Offset then
2696 while Offsets (Cur_Field + 1) /= No_Field_Offset loop
2698 F : constant Union_Id :=
2699 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
2702 if Traverse_Field (F) = Abandon then
2707 Cur_Field := Cur_Field + 1;
2711 F : constant Union_Id :=
2712 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
2715 if F not in Node_Range then
2716 if Traverse_Field (F) = Abandon then
2720 elsif F /= Empty_List_Or_Node then
2721 -- Here is the tail recursion step, we reset Cur_Node and
2722 -- jump back to the start of the procedure, which has the
2723 -- same semantic effect as a call.
2725 Cur_Node := Node_Id (F);
2735 -------------------------------
2736 -- Traverse_Func_With_Parent --
2737 -------------------------------
2739 function Traverse_Func_With_Parent
2740 (Node : Node_Id) return Traverse_Final_Result
2742 function Traverse is new Internal_Traverse_With_Parent (Process);
2743 Result : Traverse_Final_Result;
2745 -- Ensure that the Parents stack is not currently in use; required since
2746 -- it is global and hence a tree traversal with parents must be finished
2747 -- before the next tree traversal with parents starts.
2749 pragma Assert (Parents_Stack.Last = 0);
2750 Parents_Stack.Set_Last (0);
2752 Parents_Stack.Append (Parent (Node));
2753 Result := Traverse (Node);
2754 Parents_Stack.Decrement_Last;
2756 pragma Assert (Parents_Stack.Last = 0);
2759 end Traverse_Func_With_Parent;
2765 procedure Traverse_Proc (Node : Node_Id) is
2766 function Traverse is new Traverse_Func (Process);
2767 Discard : Traverse_Final_Result;
2768 pragma Warnings (Off, Discard);
2770 Discard := Traverse (Node);
2773 -------------------------------
2774 -- Traverse_Proc_With_Parent --
2775 -------------------------------
2777 procedure Traverse_Proc_With_Parent (Node : Node_Id) is
2778 function Traverse is new Traverse_Func_With_Parent (Process);
2779 Discard : Traverse_Final_Result;
2780 pragma Warnings (Off, Discard);
2782 Discard := Traverse (Node);
2783 end Traverse_Proc_With_Parent;
2791 Orig_Nodes.Locked := False;
2798 procedure Unlock_Nodes is
2800 pragma Assert (Locked);
2808 procedure Zero_Dynamic_Slots (First, Last : Node_Offset'Base) is
2810 Slots.Table (First .. Last) := (others => 0);
2811 end Zero_Dynamic_Slots;
2813 procedure Zero_Header_Slots (N : Node_Or_Entity_Id) is
2814 All_Node_Offsets : Node_Offsets.Table_Type renames
2815 Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
2817 All_Node_Offsets (N).Slots := (others => 0);
2818 end Zero_Header_Slots;
2820 procedure Zero_Slots (N : Node_Or_Entity_Id) is
2822 Zero_Dynamic_Slots (Off_F (N), Off_L (N));
2823 Zero_Header_Slots (N);
2826 ----------------------
2827 -- Print_Statistics --
2828 ----------------------
2830 procedure Print_Node_Statistics;
2831 procedure Print_Field_Statistics;
2832 -- Helpers for Print_Statistics
2834 procedure Write_Ratio (X : Nat_64; Y : Pos_64);
2835 -- Write the value of (X/Y) without using 'Image
(approximately
)
2837 procedure Write_Ratio
(X
: Nat_64
; Y
: Pos_64
) is
2838 pragma Assert
(X
<= Y
);
2839 Ratio
: constant Nat
:= Nat
((Long_Float (X
) / Long_Float (Y
)) * 1000.0);
2844 Write_Str
("0.000");
2845 elsif Ratio
in 1 .. 9 then
2848 elsif Ratio
in 10 .. 99 then
2851 elsif Ratio
in 100 .. 999 then
2855 Write_Int
(Ratio
/ 1000);
2861 procedure Print_Node_Statistics
is
2862 subtype Count
is Nat_64
;
2863 Node_Counts
: array (Node_Kind
) of Count
:= (others => 0);
2864 Entity_Counts
: array (Entity_Kind
) of Count
:= (others => 0);
2866 -- We put the Node_Kinds and Entity_Kinds into a table just because
2867 -- GNAT.Table has a handy sort procedure. We're sorting in decreasing
2868 -- order of Node_Counts, for printing.
2870 package Node_Kind_Table
is new GNAT
.Table
2871 (Table_Component_Type
=> Node_Kind
,
2872 Table_Index_Type
=> Pos
,
2873 Table_Low_Bound
=> Pos
'First,
2875 Table_Increment
=> 100
2877 function Higher_Count
(X
, Y
: Node_Kind
) return Boolean is
2878 (Node_Counts
(X
) > Node_Counts
(Y
));
2879 procedure Sort_Node_Kind_Table
is new
2880 Node_Kind_Table
.Sort_Table
(Lt
=> Higher_Count
);
2882 package Entity_Kind_Table
is new GNAT
.Table
2883 (Table_Component_Type
=> Entity_Kind
,
2884 Table_Index_Type
=> Pos
,
2885 Table_Low_Bound
=> Pos
'First,
2887 Table_Increment
=> 100
2889 function Higher_Count
(X
, Y
: Entity_Kind
) return Boolean is
2890 (Entity_Counts
(X
) > Entity_Counts
(Y
));
2891 procedure Sort_Entity_Kind_Table
is new
2892 Entity_Kind_Table
.Sort_Table
(Lt
=> Higher_Count
);
2894 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
2895 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
2897 Write_Int
(Int
(Node_Offsets
.Last
));
2898 Write_Line
(" nodes (including entities)");
2899 Write_Int
(Int
(Slots
.Last
));
2900 Write_Line
(" non-header slots");
2902 -- Count up the number of each kind of node and entity
2904 for N
in All_Node_Offsets
'Range loop
2906 K
: constant Node_Kind
:= Nkind
(N
);
2909 Node_Counts
(K
) := Node_Counts
(K
) + 1;
2911 if K
in N_Entity
then
2912 Entity_Counts
(Ekind
(N
)) := Entity_Counts
(Ekind
(N
)) + 1;
2917 -- Copy kinds to tables, and sort:
2919 for K
in Node_Kind
loop
2920 Node_Kind_Table
.Append
(K
);
2922 Sort_Node_Kind_Table
;
2924 for K
in Entity_Kind
loop
2925 Entity_Kind_Table
.Append
(K
);
2927 Sort_Entity_Kind_Table
;
2929 -- Print out the counts for each kind in decreasing order. Exit the loop
2930 -- if we see a zero count, because all the rest must be zero, and the
2931 -- zero ones are boring.
2934 use Node_Kind_Table
;
2935 -- Note: the full qualification of First below is needed for
2936 -- bootstrap builds.
2937 Table
: Table_Type
renames Node_Kind_Table
.Table
2938 (Node_Kind_Table
.First
.. Last
);
2940 for J
in Table
'Range loop
2942 K
: constant Node_Kind
:= Table
(J
);
2943 Count
: constant Nat_64
:= Node_Counts
(K
);
2945 exit when Count
= 0; -- skip the rest
2947 Write_Int_64
(Count
);
2948 Write_Ratio
(Count
, Int_64
(Node_Offsets
.Last
));
2950 Write_Str
(Node_Kind
'Image (K
));
2952 Write_Int
(Int
(Sinfo
.Nodes
.Size
(K
)));
2953 Write_Str
(" slots");
2960 use Entity_Kind_Table
;
2961 -- Note: the full qualification of First below is needed for
2962 -- bootstrap builds.
2963 Table
: Table_Type
renames Entity_Kind_Table
.Table
2964 (Entity_Kind_Table
.First
.. Last
);
2966 for J
in Table
'Range loop
2968 K
: constant Entity_Kind
:= Table
(J
);
2969 Count
: constant Nat_64
:= Entity_Counts
(K
);
2971 exit when Count
= 0; -- skip the rest
2973 Write_Int_64
(Count
);
2974 Write_Ratio
(Count
, Int_64
(Node_Offsets
.Last
));
2976 Write_Str
(Entity_Kind
'Image (K
));
2978 Write_Int
(Int
(Einfo
.Entities
.Size
(K
)));
2979 Write_Str
(" slots");
2984 end Print_Node_Statistics
;
2986 procedure Print_Field_Statistics
is
2987 Total
, G_Total
, S_Total
: Call_Count
:= 0;
2989 -- Use a table for sorting, as done in Print_Node_Statistics.
2991 package Field_Table
is new GNAT
.Table
2992 (Table_Component_Type
=> Node_Or_Entity_Field
,
2993 Table_Index_Type
=> Pos
,
2994 Table_Low_Bound
=> Pos
'First,
2996 Table_Increment
=> 100
2998 function Higher_Count
(X
, Y
: Node_Or_Entity_Field
) return Boolean is
2999 (Get_Count
(X
) + Set_Count
(X
) > Get_Count
(Y
) + Set_Count
(Y
));
3000 procedure Sort_Field_Table
is new
3001 Field_Table
.Sort_Table
(Lt
=> Higher_Count
);
3003 Write_Int_64
(Get_Original_Node_Count
);
3005 Write_Int_64
(Set_Original_Node_Count
);
3006 Write_Line
(" Original_Node_Count getter and setter calls");
3009 Write_Line
("Frequency of field getter and setter calls:");
3011 for Field
in Node_Or_Entity_Field
loop
3012 G_Total
:= G_Total
+ Get_Count
(Field
);
3013 S_Total
:= S_Total
+ Set_Count
(Field
);
3014 Total
:= G_Total
+ S_Total
;
3017 -- This assertion helps CodePeer understand that Total cannot be 0 (this
3018 -- is true because GNAT does not attempt to compile empty files).
3019 pragma Assert
(Total
> 0);
3021 Write_Int_64
(Total
);
3022 Write_Str
(" (100%) = ");
3023 Write_Int_64
(G_Total
);
3025 Write_Int_64
(S_Total
);
3026 Write_Line
(" total getter and setter calls");
3028 -- Copy fields to the table, and sort:
3030 for F
in Node_Or_Entity_Field
loop
3031 Field_Table
.Append
(F
);
3035 -- Print out the counts for each field in decreasing order of
3036 -- getter+setter sum. As in Print_Node_Statistics, exit the loop
3037 -- if we see a zero sum.
3041 -- Note: the full qualification of First below is needed for
3042 -- bootstrap builds.
3043 Table
: Table_Type
renames
3044 Field_Table
.Table
(Field_Table
.First
.. Last
);
3046 for J
in Table
'Range loop
3048 Field
: constant Node_Or_Entity_Field
:= Table
(J
);
3050 G
: constant Call_Count
:= Get_Count
(Field
);
3051 S
: constant Call_Count
:= Set_Count
(Field
);
3052 GS
: constant Call_Count
:= G
+ S
;
3054 Desc
: Field_Descriptor
renames Field_Descriptors
(Field
);
3055 Slot
: constant Field_Offset
:=
3056 (Field_Size
(Desc
.Kind
) * Desc
.Offset
) / Slot_Size
;
3059 exit when GS
= 0; -- skip the rest
3062 Write_Ratio
(GS
, Total
);
3068 Write_Str
(Node_Or_Entity_Field
'Image (Field
));
3069 Write_Str
(" in slot ");
3070 Write_Int
(Int
(Slot
));
3071 Write_Str
(" size ");
3072 Write_Int
(Int
(Field_Size
(Desc
.Kind
)));
3077 end Print_Field_Statistics
;
3079 procedure Print_Statistics
is
3083 Print_Node_Statistics
;
3085 Print_Field_Statistics
;
3086 end Print_Statistics
;