1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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
);
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
;
1285 procedure Copy_Slots
(Source
, Destination
: Node_Id
) is
1286 pragma Debug
(Validate_Node
(Source
));
1287 pragma Assert
(Source
/= Destination
);
1289 S_Size
: constant Slot_Count
:= Size_In_Slots_Dynamic
(Source
);
1291 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
1292 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
1296 (Off_F
(Source
), Off_F
(Destination
), S_Size
);
1297 All_Node_Offsets
(Destination
).Slots
:= All_Node_Offsets
(Source
).Slots
;
1304 procedure Copy_Node
(Source
, Destination
: Node_Or_Entity_Id
) is
1305 pragma Assert
(Source
/= Destination
);
1307 Save_In_List
: constant Boolean := In_List
(Destination
);
1308 Save_Link
: constant Union_Id
:= Link
(Destination
);
1310 S_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Source
);
1311 D_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Destination
);
1314 New_Node_Debugging_Output
(Source
);
1315 New_Node_Debugging_Output
(Destination
);
1317 -- Currently all entities are allocated the same number of slots.
1318 -- Hopefully that won't always be the case, but if it is, the following
1319 -- is suboptimal if D_Size < S_Size, because in fact the Destination was
1320 -- allocated the max.
1322 -- If Source doesn't fit in Destination, we need to allocate
1324 if D_Size
< S_Size
then
1325 pragma Debug
(Zero_Slots
(Destination
)); -- destroy old slots
1326 Node_Offsets
.Table
(Destination
).Offset
:=
1327 Alloc_Slots
(S_Size
) - N_Head
;
1330 Copy_Slots
(Source
, Destination
);
1332 Set_In_List
(Destination
, Save_In_List
);
1333 Set_Link
(Destination
, Save_Link
);
1334 Set_Paren_Count_Of_Copy
(Target
=> Destination
, Source
=> Source
);
1337 ------------------------
1338 -- Copy_Separate_List --
1339 ------------------------
1341 function Copy_Separate_List
(Source
: List_Id
) return List_Id
is
1342 Result
: constant List_Id
:= New_List
;
1343 Nod
: Node_Id
:= First
(Source
);
1346 while Present
(Nod
) loop
1347 Append
(Copy_Separate_Tree
(Nod
), Result
);
1352 end Copy_Separate_List
;
1354 ------------------------
1355 -- Copy_Separate_Tree --
1356 ------------------------
1358 function Copy_Separate_Tree
(Source
: Node_Id
) return Node_Id
is
1360 pragma Debug
(Validate_Node
(Source
));
1364 function Copy_Entity
(E
: Entity_Id
) return Entity_Id
;
1365 -- Copy Entity, copying only Chars field
1367 function Copy_List
(List
: List_Id
) return List_Id
;
1370 function Possible_Copy
(Field
: Union_Id
) return Union_Id
;
1371 -- Given a field, returns a copy of the node or list if its parent is
1372 -- the current source node, and otherwise returns the input.
1378 function Copy_Entity
(E
: Entity_Id
) return Entity_Id
is
1380 pragma Assert
(Nkind
(E
) in N_Entity
);
1382 return Result
: constant Entity_Id
:= New_Entity
(Nkind
(E
), Sloc
(E
))
1384 Set_Chars
(Result
, Chars
(E
));
1392 function Copy_List
(List
: List_Id
) return List_Id
is
1397 if List
= No_List
then
1404 while Present
(E
) loop
1405 Append
(Copy_Separate_Tree
(E
), NL
);
1417 function Possible_Copy
(Field
: Union_Id
) return Union_Id
is
1421 if Field
in Node_Range
then
1422 New_N
:= Union_Id
(Copy_Separate_Tree
(Node_Id
(Field
)));
1424 if Present
(Node_Id
(Field
))
1425 and then Is_Syntactic_Node
(Source
, Node_Id
(Field
))
1427 Set_Parent
(Node_Id
(New_N
), New_Id
);
1432 elsif Field
in List_Range
then
1433 New_N
:= Union_Id
(Copy_List
(List_Id
(Field
)));
1435 if Parent
(List_Id
(Field
)) = Source
then
1436 Set_Parent
(List_Id
(New_N
), New_Id
);
1446 procedure Walk
is new Walk_Sinfo_Fields_Pairwise
(Possible_Copy
);
1448 -- Start of processing for Copy_Separate_Tree
1451 if Source
<= Empty_Or_Error
then
1454 elsif Is_Entity
(Source
) then
1455 return Copy_Entity
(Source
);
1458 New_Id
:= New_Copy
(Source
);
1460 Walk
(New_Id
, Source
);
1462 -- Set Entity field to Empty to ensure that no entity references
1463 -- are shared between the two, if the source is already analyzed.
1465 if Nkind
(New_Id
) in N_Has_Entity
1466 or else Nkind
(New_Id
) = N_Freeze_Entity
1468 Set_Entity
(New_Id
, Empty
);
1471 -- Reset all Etype fields and Analyzed flags, because input tree may
1472 -- have been fully or partially analyzed.
1474 if Nkind
(New_Id
) in N_Has_Etype
then
1475 Set_Etype
(New_Id
, Empty
);
1478 Set_Analyzed
(New_Id
, False);
1480 -- Rather special case, if we have an expanded name, then change
1481 -- it back into a selected component, so that the tree looks the
1482 -- way it did coming out of the parser. This will change back
1483 -- when we analyze the selected component node.
1485 if Nkind
(New_Id
) = N_Expanded_Name
then
1487 -- The following code is a bit kludgy. It would be cleaner to
1488 -- Add an entry Change_Expanded_Name_To_Selected_Component to
1489 -- Sinfo.CN, but that's delicate because Atree is used in the
1490 -- binder, so we don't want to add that dependency.
1491 -- ??? Revisit now that ASIS is no longer using this unit.
1493 -- Consequently we have no choice but to hold our noses and do the
1494 -- change manually. At least we are Atree, so this is at least all
1497 -- Clear the Chars field which is not present in a selected
1498 -- component node, so we don't want a junk value around. Note that
1499 -- we can't just call Set_Chars, because Empty is of the wrong
1500 -- type, and is outside the range of Name_Id.
1502 Reinit_Field_To_Zero
(New_Id
, F_Chars
);
1503 Reinit_Field_To_Zero
(New_Id
, F_Has_Private_View
);
1504 Reinit_Field_To_Zero
(New_Id
, F_Is_Elaboration_Checks_OK_Node
);
1505 Reinit_Field_To_Zero
(New_Id
, F_Is_Elaboration_Warnings_OK_Node
);
1506 Reinit_Field_To_Zero
(New_Id
, F_Is_SPARK_Mode_On_Node
);
1508 -- Change the node type
1510 Mutate_Nkind
(New_Id
, N_Selected_Component
);
1513 -- All done, return copied node
1517 end Copy_Separate_Tree
;
1519 -----------------------
1520 -- Exchange_Entities --
1521 -----------------------
1523 procedure Exchange_Entities
(E1
: Entity_Id
; E2
: Entity_Id
) is
1524 pragma Debug
(Validate_Node_Write
(E1
));
1525 pragma Debug
(Validate_Node_Write
(E2
));
1527 (Is_Entity
(E1
) and then Is_Entity
(E2
)
1528 and then not In_List
(E1
) and then not In_List
(E2
));
1530 Old_E1
: constant Node_Header
:= Node_Offsets
.Table
(E1
);
1533 Node_Offsets
.Table
(E1
) := Node_Offsets
.Table
(E2
);
1534 Node_Offsets
.Table
(E2
) := Old_E1
;
1536 -- That exchange exchanged the parent pointers as well, which is what
1537 -- we want, but we need to patch up the defining identifier pointers
1538 -- in the parent nodes (the child pointers) to match this switch
1539 -- unless for Implicit types entities which have no parent, in which
1540 -- case we don't do anything otherwise we won't be able to revert back
1541 -- to the original situation.
1543 -- Shouldn't this use Is_Itype instead of the Parent test???
1545 if Present
(Parent
(E1
)) and then Present
(Parent
(E2
)) then
1546 Set_Defining_Identifier
(Parent
(E1
), E1
);
1547 Set_Defining_Identifier
(Parent
(E2
), E2
);
1550 New_Node_Debugging_Output
(E1
);
1551 New_Node_Debugging_Output
(E2
);
1552 end Exchange_Entities
;
1558 procedure Extend_Node
(Source
: Node_Id
) is
1559 pragma Assert
(Present
(Source
));
1560 pragma Assert
(not Is_Entity
(Source
));
1562 Old_Kind
: constant Node_Kind
:= Nkind
(Source
);
1563 pragma Assert
(Old_Kind
in N_Direct_Name
);
1564 New_Kind
: constant Node_Kind
:=
1566 when N_Character_Literal
=> N_Defining_Character_Literal
,
1567 when N_Identifier
=> N_Defining_Identifier
,
1568 when N_Operator_Symbol
=> N_Defining_Operator_Symbol
,
1569 when others => N_Unused_At_Start
); -- can't happen
1570 -- The new NKind, which is the appropriate value of N_Entity based on
1571 -- the old Nkind. N_xxx is mapped to N_Defining_xxx.
1572 pragma Assert
(New_Kind
in N_Entity
);
1574 -- Start of processing for Extend_Node
1577 Set_Check_Actuals
(Source
, False);
1578 Mutate_Nkind
(Source
, New_Kind
);
1579 Report
(Target
=> Source
, Source
=> Source
);
1586 procedure Fix_Parents
(Ref_Node
, Fix_Node
: Node_Id
) is
1587 pragma Assert
(Nkind
(Ref_Node
) = Nkind
(Fix_Node
));
1589 procedure Fix_Parent
(Field
: Union_Id
);
1590 -- Fix up one parent pointer. Field is checked to see if it points to
1591 -- a node, list, or element list that has a parent that points to
1592 -- Ref_Node. If so, the parent is reset to point to Fix_Node.
1598 procedure Fix_Parent
(Field
: Union_Id
) is
1600 -- Fix parent of node that is referenced by Field. Note that we must
1601 -- exclude the case where the node is a member of a list, because in
1602 -- this case the parent is the parent of the list.
1604 if Field
in Node_Range
1605 and then Present
(Node_Id
(Field
))
1606 and then not In_List
(Node_Id
(Field
))
1607 and then Parent
(Node_Id
(Field
)) = Ref_Node
1609 Set_Parent
(Node_Id
(Field
), Fix_Node
);
1611 -- Fix parent of list that is referenced by Field
1613 elsif Field
in List_Range
1614 and then Present
(List_Id
(Field
))
1615 and then Parent
(List_Id
(Field
)) = Ref_Node
1617 Set_Parent
(List_Id
(Field
), Fix_Node
);
1621 Fields
: Node_Field_Array
renames
1622 Node_Field_Table
(Nkind
(Fix_Node
)).all;
1624 -- Start of processing for Fix_Parents
1627 for J
in Fields
'Range loop
1629 Desc
: Field_Descriptor
renames Field_Descriptors
(Fields
(J
));
1631 if Desc
.Kind
in Node_Id_Field | List_Id_Field
then
1632 Fix_Parent
(Get_Node_Field_Union
(Fix_Node
, Desc
.Offset
));
1638 -----------------------------------
1639 -- Get_Comes_From_Source_Default --
1640 -----------------------------------
1642 function Get_Comes_From_Source_Default
return Boolean is
1644 return Comes_From_Source_Default
;
1645 end Get_Comes_From_Source_Default
;
1651 function Is_Entity
(N
: Node_Or_Entity_Id
) return Boolean is
1653 return Nkind
(N
) in N_Entity
;
1656 -----------------------
1657 -- Is_Syntactic_Node --
1658 -----------------------
1660 function Is_Syntactic_Node
1665 function Has_More_Ids
(N
: Node_Id
) return Boolean;
1666 -- Return True when N has attribute More_Ids set to True
1672 function Has_More_Ids
(N
: Node_Id
) return Boolean is
1674 if Nkind
(N
) in N_Component_Declaration
1675 | N_Discriminant_Specification
1676 | N_Exception_Declaration
1677 | N_Formal_Object_Declaration
1678 | N_Number_Declaration
1679 | N_Object_Declaration
1680 | N_Parameter_Specification
1681 | N_Use_Package_Clause
1684 return More_Ids
(N
);
1690 -- Start of processing for Is_Syntactic_Node
1693 if Parent
(Field
) = Source
then
1696 -- Perform the check using the last id in the syntactic chain
1698 elsif Has_More_Ids
(Source
) then
1700 N
: Node_Id
:= Source
;
1703 while Present
(N
) and then More_Ids
(N
) loop
1707 pragma Assert
(Prev_Ids
(N
));
1708 return Parent
(Field
) = N
;
1714 end Is_Syntactic_Node
;
1720 procedure Initialize
is
1722 pragma Warnings
(Off
, Dummy
);
1725 -- Allocate Empty node
1727 Dummy
:= New_Node
(N_Empty
, No_Location
);
1728 Set_Chars
(Empty
, No_Name
);
1729 pragma Assert
(Dummy
= Empty
);
1731 -- Allocate Error node, and set Error_Posted, since we certainly
1732 -- only generate an Error node if we do post some kind of error.
1734 Dummy
:= New_Node
(N_Error
, No_Location
);
1735 Set_Chars
(Error
, Error_Name
);
1736 Set_Error_Posted
(Error
, True);
1737 pragma Assert
(Dummy
= Error
);
1740 --------------------------
1741 -- Is_Rewrite_Insertion --
1742 --------------------------
1744 function Is_Rewrite_Insertion
(Node
: Node_Id
) return Boolean is
1746 return Rewrite_Ins
(Node
);
1747 end Is_Rewrite_Insertion
;
1749 -----------------------------
1750 -- Is_Rewrite_Substitution --
1751 -----------------------------
1753 function Is_Rewrite_Substitution
(Node
: Node_Id
) return Boolean is
1755 return Orig_Nodes
.Table
(Node
) /= Node
;
1756 end Is_Rewrite_Substitution
;
1762 function Last_Node_Id
return Node_Id
is
1764 return Node_Offsets
.Last
;
1773 Orig_Nodes
.Locked
:= True;
1780 procedure Lock_Nodes
is
1782 pragma Assert
(not Locked
);
1786 -------------------------
1787 -- Mark_New_Ghost_Node --
1788 -------------------------
1790 procedure Mark_New_Ghost_Node
(N
: Node_Or_Entity_Id
) is
1792 pragma Debug
(Validate_Node_Write
(N
));
1794 -- The Ghost node is created within a Ghost region
1796 if Ghost_Mode
= Check
then
1797 if Nkind
(N
) in N_Entity
then
1798 Set_Is_Checked_Ghost_Entity
(N
);
1801 elsif Ghost_Mode
= Ignore
then
1802 if Nkind
(N
) in N_Entity
then
1803 Set_Is_Ignored_Ghost_Entity
(N
);
1806 Set_Is_Ignored_Ghost_Node
(N
);
1808 -- Record the ignored Ghost node or entity in order to eliminate it
1809 -- from the tree later.
1811 if Ignored_Ghost_Recording_Proc
/= null then
1812 Ignored_Ghost_Recording_Proc
.all (N
);
1815 end Mark_New_Ghost_Node
;
1817 ----------------------------
1818 -- Mark_Rewrite_Insertion --
1819 ----------------------------
1821 procedure Mark_Rewrite_Insertion
(New_Node
: Node_Id
) is
1823 Set_Rewrite_Ins
(New_Node
);
1824 end Mark_Rewrite_Insertion
;
1830 function New_Copy
(Source
: Node_Id
) return Node_Id
is
1831 pragma Debug
(Validate_Node
(Source
));
1832 S_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Source
);
1834 if Source
<= Empty_Or_Error
then
1838 return New_Id
: constant Node_Id
:= Alloc_Node_Id
do
1839 Node_Offsets
.Table
(New_Id
).Offset
:=
1840 Alloc_Slots
(S_Size
) - N_Head
;
1841 Orig_Nodes
.Append
(New_Id
);
1842 Copy_Slots
(Source
, New_Id
);
1844 Set_Check_Actuals
(New_Id
, False);
1845 Set_Paren_Count_Of_Copy
(Target
=> New_Id
, Source
=> Source
);
1847 Allocate_List_Tables
(New_Id
);
1848 Report
(Target
=> New_Id
, Source
=> Source
);
1850 Set_In_List
(New_Id
, False);
1851 Set_Link
(New_Id
, Empty_List_Or_Node
);
1853 -- If the original is marked as a rewrite insertion, then unmark the
1854 -- copy, since we inserted the original, not the copy.
1856 Set_Rewrite_Ins
(New_Id
, False);
1858 -- Clear Is_Overloaded since we cannot have semantic interpretations
1859 -- of this new node.
1861 if Nkind
(Source
) in N_Subexpr
then
1862 Set_Is_Overloaded
(New_Id
, False);
1865 -- Mark the copy as Ghost depending on the current Ghost region
1867 if Nkind
(New_Id
) in N_Entity
then
1868 Set_Is_Checked_Ghost_Entity
(New_Id
, False);
1869 Set_Is_Ignored_Ghost_Entity
(New_Id
, False);
1872 Mark_New_Ghost_Node
(New_Id
);
1874 New_Node_Debugging_Output
(New_Id
);
1876 pragma Assert
(New_Id
/= Source
);
1885 (New_Node_Kind
: Node_Kind
;
1886 New_Sloc
: Source_Ptr
) return Entity_Id
1888 pragma Assert
(New_Node_Kind
in N_Entity
);
1889 New_Id
: constant Entity_Id
:= Allocate_New_Node
(New_Node_Kind
);
1890 pragma Assert
(Original_Node
(Node_Offsets
.Last
) = Node_Offsets
.Last
);
1892 -- If this is a node with a real location and we are generating
1893 -- source nodes, then reset Current_Error_Node. This is useful
1894 -- if we bomb during parsing to get a error location for the bomb.
1896 if New_Sloc
> No_Location
and then Comes_From_Source_Default
then
1897 Current_Error_Node
:= New_Id
;
1900 Set_Sloc
(New_Id
, New_Sloc
);
1902 -- Mark the new entity as Ghost depending on the current Ghost region
1904 Mark_New_Ghost_Node
(New_Id
);
1906 New_Node_Debugging_Output
(New_Id
);
1916 (New_Node_Kind
: Node_Kind
;
1917 New_Sloc
: Source_Ptr
) return Node_Id
1919 pragma Assert
(New_Node_Kind
not in N_Entity
);
1920 New_Id
: constant Node_Id
:= Allocate_New_Node
(New_Node_Kind
);
1921 pragma Assert
(Original_Node
(Node_Offsets
.Last
) = Node_Offsets
.Last
);
1923 Set_Sloc
(New_Id
, New_Sloc
);
1925 -- If this is a node with a real location and we are generating source
1926 -- nodes, then reset Current_Error_Node. This is useful if we bomb
1927 -- during parsing to get an error location for the bomb.
1929 if Comes_From_Source_Default
and then New_Sloc
> No_Location
then
1930 Current_Error_Node
:= New_Id
;
1933 -- Mark the new node as Ghost depending on the current Ghost region
1935 Mark_New_Ghost_Node
(New_Id
);
1937 New_Node_Debugging_Output
(New_Id
);
1946 function No
(N
: Node_Id
) return Boolean is
1955 function Node_Offsets_Address
return System
.Address
is
1957 return Node_Offsets
.Table
(First_Node_Id
)'Address;
1958 end Node_Offsets_Address
;
1960 function Slots_Address
return System
.Address
is
1961 Slot_Byte_Size
: constant := 4;
1962 pragma Assert
(Slot_Byte_Size
* 8 = Slot
'Size);
1963 Extra
: constant := Slots_Low_Bound
* Slot_Byte_Size
;
1964 -- Slots does not start at 0, so we need to subtract off the extra
1965 -- amount. We are returning Slots.Table (0)'Address, except that
1966 -- that component does not exist.
1967 use System
.Storage_Elements
;
1969 return Slots
.Table
(Slots_Low_Bound
)'Address - Extra
;
1972 -----------------------------------
1973 -- Approx_Num_Nodes_And_Entities --
1974 -----------------------------------
1976 function Approx_Num_Nodes_And_Entities
return Nat
is
1978 return Nat
(Node_Offsets
.Last
- First_Node_Id
);
1979 end Approx_Num_Nodes_And_Entities
;
1985 function Off_0
(N
: Node_Id
) return Node_Offset
'Base is
1986 pragma Debug
(Validate_Node
(N
));
1988 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
1989 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
1991 return All_Node_Offsets
(N
).Offset
;
1998 function Off_F
(N
: Node_Id
) return Node_Offset
is
2000 return Off_0
(N
) + N_Head
;
2007 function Off_L
(N
: Node_Id
) return Node_Offset
is
2008 pragma Debug
(Validate_Node
(N
));
2010 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
2011 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
2013 return All_Node_Offsets
(N
).Offset
+ Size_In_Slots
(N
) - 1;
2020 function Original_Node
(Node
: Node_Id
) return Node_Id
is
2022 pragma Debug
(Validate_Node
(Node
));
2023 if Atree_Statistics_Enabled
then
2024 Get_Original_Node_Count
:= Get_Original_Node_Count
+ 1;
2027 return Orig_Nodes
.Table
(Node
);
2034 function Paren_Count
(N
: Node_Id
) return Nat
is
2035 pragma Debug
(Validate_Node
(N
));
2037 C
: constant Small_Paren_Count_Type
:= Small_Paren_Count
(N
);
2040 -- Value of 0,1,2 returned as is
2045 -- Value of 3 means we search the table, and we must find an entry
2048 for J
in Paren_Counts
.First
.. Paren_Counts
.Last
loop
2049 if N
= Paren_Counts
.Table
(J
).Nod
then
2050 return Paren_Counts
.Table
(J
).Count
;
2054 raise Program_Error
;
2058 function Node_Parent
(N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
is
2060 pragma Assert
(Present
(N
));
2062 if Is_List_Member
(N
) then
2063 return Parent
(List_Containing
(N
));
2065 return Node_Or_Entity_Id
(Link
(N
));
2073 function Present
(N
: Node_Id
) return Boolean is
2078 --------------------------------
2079 -- Preserve_Comes_From_Source --
2080 --------------------------------
2082 procedure Preserve_Comes_From_Source
(NewN
, OldN
: Node_Id
) is
2084 Set_Comes_From_Source
(NewN
, Comes_From_Source
(OldN
));
2085 end Preserve_Comes_From_Source
;
2091 function Relocate_Node
(Source
: Node_Id
) return Node_Id
is
2099 New_Node
:= New_Copy
(Source
);
2100 Fix_Parents
(Ref_Node
=> Source
, Fix_Node
=> New_Node
);
2102 -- We now set the parent of the new node to be the same as the parent of
2103 -- the source. Almost always this parent will be replaced by a new value
2104 -- when the relocated node is reattached to the tree, but by doing it
2105 -- now, we ensure that this node is not even temporarily disconnected
2106 -- from the tree. Note that this does not happen free, because in the
2107 -- list case, the parent does not get set.
2109 Set_Parent
(New_Node
, Parent
(Source
));
2111 -- If the node being relocated was a rewriting of some original node,
2112 -- then the relocated node has the same original node.
2114 if Is_Rewrite_Substitution
(Source
) then
2115 Set_Original_Node
(New_Node
, Original_Node
(Source
));
2118 -- If we're relocating a subprogram call and we're doing
2119 -- unnesting, be sure we make a new copy of any parameter associations
2120 -- so that we don't share them.
2122 if Nkind
(Source
) in N_Subprogram_Call
2123 and then Opt
.Unnest_Subprogram_Mode
2124 and then Present
(Parameter_Associations
(Source
))
2127 New_Assoc
: constant List_Id
:= Parameter_Associations
(Source
);
2129 Set_Parent
(New_Assoc
, New_Node
);
2130 Set_Parameter_Associations
(New_Node
, New_Assoc
);
2141 procedure Replace
(Old_Node
, New_Node
: Node_Id
) is
2142 Old_Post
: constant Boolean := Error_Posted
(Old_Node
);
2143 Old_CFS
: constant Boolean := Comes_From_Source
(Old_Node
);
2145 procedure Destroy_New_Node
;
2146 -- Overwrite New_Node data with junk, for debugging purposes
2148 procedure Destroy_New_Node
is
2150 Zero_Slots
(New_Node
);
2151 Node_Offsets
.Table
(New_Node
).Offset
:= Field_Offset
'Base'Last;
2152 end Destroy_New_Node;
2155 New_Node_Debugging_Output (Old_Node);
2156 New_Node_Debugging_Output (New_Node);
2159 (not Is_Entity (Old_Node)
2160 and not Is_Entity (New_Node)
2161 and not In_List (New_Node)
2162 and Old_Node /= New_Node);
2164 -- Do copy, preserving link and in list status and required flags
2166 Copy_Node (Source => New_Node, Destination => Old_Node);
2167 Set_Comes_From_Source (Old_Node, Old_CFS);
2168 Set_Error_Posted (Old_Node, Old_Post);
2170 -- Fix parents of substituted node, since it has changed identity
2172 Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);
2174 pragma Debug (Destroy_New_Node);
2176 -- Since we are doing a replace, we assume that the original node
2177 -- is intended to become the new replaced node. The call would be
2178 -- to Rewrite if there were an intention to save the original node.
2180 Set_Original_Node (Old_Node, Old_Node);
2182 -- Invoke the reporting procedure (if available)
2184 if Reporting_Proc /= null then
2185 Reporting_Proc.all (Target => Old_Node, Source => New_Node);
2193 procedure Report (Target, Source : Node_Id) is
2195 if Reporting_Proc /= null then
2196 Reporting_Proc.all (Target, Source);
2204 procedure Rewrite (Old_Node, New_Node : Node_Id) is
2205 Old_CA : constant Boolean := Check_Actuals (Old_Node);
2206 Old_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Old_Node);
2207 Old_Error_Posted : constant Boolean :=
2208 Error_Posted (Old_Node);
2210 Old_Must_Not_Freeze : constant Boolean :=
2211 (if Nkind (Old_Node) in N_Subexpr then Must_Not_Freeze (Old_Node)
2213 Old_Paren_Count : constant Nat :=
2214 (if Nkind (Old_Node) in N_Subexpr then Paren_Count (Old_Node) else 0);
2215 -- These fields are preserved in the new node only if the new node and
2216 -- the old node are both subexpression nodes. We might be changing Nkind
2217 -- (Old_Node) from not N_Subexpr to N_Subexpr, so we need a value
2218 -- (False/0) even if Old_Noed is not a N_Subexpr.
2220 -- Note: it is a violation of abstraction levels for Must_Not_Freeze
2221 -- to be referenced like this. ???
2226 New_Node_Debugging_Output (Old_Node);
2227 New_Node_Debugging_Output (New_Node);
2230 (not Is_Entity (Old_Node)
2231 and not Is_Entity (New_Node)
2232 and not In_List (New_Node));
2234 -- Allocate a new node, to be used to preserve the original contents
2235 -- of the Old_Node, for possible later retrival by Original_Node and
2236 -- make an entry in the Orig_Nodes table. This is only done if we have
2237 -- not already rewritten the node, as indicated by an Orig_Nodes entry
2238 -- that does not reference the Old_Node.
2240 if not Is_Rewrite_Substitution (Old_Node) then
2241 Sav_Node := New_Copy (Old_Node);
2242 Set_Original_Node (Sav_Node, Sav_Node);
2243 Set_Original_Node (Old_Node, Sav_Node);
2246 -- Copy substitute node into place, preserving old fields as required
2248 Copy_Node (Source => New_Node, Destination => Old_Node);
2249 Set_Error_Posted (Old_Node, Old_Error_Posted);
2251 Set_Check_Actuals (Old_Node, Old_CA);
2252 Set_Is_Ignored_Ghost_Node (Old_Node, Old_Is_IGN);
2254 if Nkind (New_Node) in N_Subexpr then
2255 Set_Paren_Count (Old_Node, Old_Paren_Count);
2256 Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze);
2259 Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);
2261 -- Invoke the reporting procedure (if available)
2263 if Reporting_Proc /= null then
2264 Reporting_Proc.all (Target => Old_Node, Source => New_Node);
2267 -- Invoke the rewriting procedure (if available)
2269 if Rewriting_Proc /= null then
2270 Rewriting_Proc.all (Target => Old_Node, Source => New_Node);
2274 -----------------------------------
2275 -- Set_Comes_From_Source_Default --
2276 -----------------------------------
2278 procedure Set_Comes_From_Source_Default (Default : Boolean) is
2280 Comes_From_Source_Default := Default;
2281 end Set_Comes_From_Source_Default;
2283 --------------------------------------
2284 -- Set_Ignored_Ghost_Recording_Proc --
2285 --------------------------------------
2287 procedure Set_Ignored_Ghost_Recording_Proc
2288 (Proc : Ignored_Ghost_Record_Proc)
2291 pragma Assert (Ignored_Ghost_Recording_Proc = null);
2292 Ignored_Ghost_Recording_Proc := Proc;
2293 end Set_Ignored_Ghost_Recording_Proc;
2295 -----------------------
2296 -- Set_Original_Node --
2297 -----------------------
2299 procedure Set_Original_Node (N : Node_Id; Val : Node_Id) is
2301 pragma Debug (Validate_Node_Write (N));
2302 if Atree_Statistics_Enabled then
2303 Set_Original_Node_Count := Set_Original_Node_Count + 1;
2306 Orig_Nodes.Table (N) := Val;
2307 end Set_Original_Node;
2309 ---------------------
2310 -- Set_Paren_Count --
2311 ---------------------
2313 procedure Set_Paren_Count (N : Node_Id; Val : Nat) is
2315 pragma Debug (Validate_Node_Write (N));
2316 pragma Assert (Nkind (N) in N_Subexpr);
2318 -- Value of 0,1,2 stored as is
2321 Set_Small_Paren_Count (N, Val);
2323 -- Value of 3 or greater stores 3 in node and makes table entry
2326 Set_Small_Paren_Count (N, 3);
2328 -- Search for existing table entry
2330 for J in Paren_Counts.First .. Paren_Counts.Last loop
2331 if N = Paren_Counts.Table (J).Nod then
2332 Paren_Counts.Table (J).Count := Val;
2337 -- No existing table entry; make a new one
2339 Paren_Counts.Append ((Nod => N, Count => Val));
2341 end Set_Paren_Count;
2343 -----------------------------
2344 -- Set_Paren_Count_Of_Copy --
2345 -----------------------------
2347 procedure Set_Paren_Count_Of_Copy (Target, Source : Node_Id) is
2349 -- We already copied the Small_Paren_Count. We need to update the
2350 -- Paren_Counts table only if greater than 2.
2352 if Nkind (Source) in N_Subexpr
2353 and then Small_Paren_Count (Source) = 3
2355 Set_Paren_Count (Target, Paren_Count (Source));
2358 pragma Assert (Paren_Count (Target) = Paren_Count (Source));
2359 end Set_Paren_Count_Of_Copy;
2365 procedure Set_Node_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is
2367 pragma Assert (Present (N));
2368 pragma Assert (not In_List (N));
2369 Set_Link (N, Union_Id (Val));
2370 end Set_Node_Parent;
2372 ------------------------
2373 -- Set_Reporting_Proc --
2374 ------------------------
2376 procedure Set_Reporting_Proc (Proc : Report_Proc) is
2378 pragma Assert (Reporting_Proc = null);
2379 Reporting_Proc := Proc;
2380 end Set_Reporting_Proc;
2382 ------------------------
2383 -- Set_Rewriting_Proc --
2384 ------------------------
2386 procedure Set_Rewriting_Proc (Proc : Rewrite_Proc) is
2388 pragma Assert (Rewriting_Proc = null);
2389 Rewriting_Proc := Proc;
2390 end Set_Rewriting_Proc;
2392 ----------------------------
2393 -- Size_In_Slots_To_Alloc --
2394 ----------------------------
2396 function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count is
2399 (if Kind in N_Entity then Einfo.Entities.Max_Entity_Size
2400 else Sinfo.Nodes.Size (Kind)) - N_Head;
2401 -- Unfortunately, we don't know the Entity_Kind, so we have to use the
2403 end Size_In_Slots_To_Alloc;
2405 function Size_In_Slots_To_Alloc
2406 (N : Node_Or_Entity_Id) return Slot_Count is
2408 return Size_In_Slots_To_Alloc (Nkind (N));
2409 end Size_In_Slots_To_Alloc;
2415 function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count is
2417 pragma Assert (Nkind (N) /= N_Unused_At_Start);
2419 (if Nkind (N) in N_Entity then Einfo.Entities.Max_Entity_Size
2420 else Sinfo.Nodes.Size (Nkind (N)));
2423 ---------------------------
2424 -- Size_In_Slots_Dynamic --
2425 ---------------------------
2427 function Size_In_Slots_Dynamic (N : Node_Or_Entity_Id) return Slot_Count is
2429 return Size_In_Slots (N) - N_Head;
2430 end Size_In_Slots_Dynamic;
2432 -----------------------------------
2433 -- Internal_Traverse_With_Parent --
2434 -----------------------------------
2436 function Internal_Traverse_With_Parent
2437 (Node : Node_Id) return Traverse_Final_Result
2439 Tail_Recursion_Counter : Natural := 0;
2441 procedure Pop_Parents;
2442 -- Pop enclosing nodes of tail recursion plus the current parent.
2444 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result;
2445 -- Fld is one of the Traversed fields of Nod, which is necessarily a
2446 -- Node_Id or List_Id. It is traversed, and the result is the result of
2453 procedure Pop_Parents is
2455 -- Pop the enclosing nodes of the tail recursion
2457 for J in 1 .. Tail_Recursion_Counter loop
2458 Parents_Stack.Decrement_Last;
2461 -- Pop the current node
2463 pragma Assert (Parents_Stack.Table (Parents_Stack.Last) = Node);
2464 Parents_Stack.Decrement_Last;
2467 --------------------
2468 -- Traverse_Field --
2469 --------------------
2471 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result is
2473 if Fld /= Union_Id (Empty) then
2475 -- Descendant is a node
2477 if Fld in Node_Range then
2478 return Internal_Traverse_With_Parent (Node_Id (Fld));
2480 -- Descendant is a list
2482 elsif Fld in List_Range then
2484 Elmt : Node_Id := First (List_Id (Fld));
2486 while Present (Elmt) loop
2487 if Internal_Traverse_With_Parent (Elmt) = Abandon then
2496 raise Program_Error;
2505 Parent_Node : Node_Id := Parents_Stack.Table (Parents_Stack.Last);
2506 Cur_Node : Node_Id := Node;
2508 -- Start of processing for Internal_Traverse_With_Parent
2511 -- If the last field is a node, we eliminate the tail recursion by
2512 -- jumping back to this label. This is because concatenations are
2513 -- sometimes deeply nested, as in X1&X2&...&Xn. Gen_IL ensures that the
2514 -- Left_Opnd field of N_Op_Concat comes last in Traversed_Fields, so the
2515 -- tail recursion is eliminated in that case. This trick prevents us
2516 -- from running out of stack memory in that case. We don't bother
2517 -- eliminating the tail recursion if the last field is a list.
2521 Parents_Stack.Append (Cur_Node);
2523 case Process (Parent_Node, Cur_Node) is
2536 Cur_Node := Original_Node (Cur_Node);
2539 -- Check for empty Traversed_Fields before entering loop below, so the
2540 -- tail recursive step won't go past the end.
2543 Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First;
2544 Offsets : Traversed_Offset_Array renames
2545 Traversed_Fields (Nkind (Cur_Node));
2548 if Offsets (Traversed_Offset_Array'First) /= No_Field_Offset then
2549 while Offsets (Cur_Field + 1) /= No_Field_Offset loop
2551 F : constant Union_Id :=
2552 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
2555 if Traverse_Field (F) = Abandon then
2561 Cur_Field := Cur_Field + 1;
2565 F : constant Union_Id :=
2566 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
2569 if F not in Node_Range then
2570 if Traverse_Field (F) = Abandon then
2575 elsif F /= Empty_List_Or_Node then
2576 -- Here is the tail recursion step, we reset Cur_Node and
2577 -- jump back to the start of the procedure, which has the
2578 -- same semantic effect as a call.
2580 Tail_Recursion_Counter := Tail_Recursion_Counter + 1;
2581 Parent_Node := Cur_Node;
2582 Cur_Node := Node_Id (F);
2591 end Internal_Traverse_With_Parent;
2597 function Traverse_Func (Node : Node_Id) return Traverse_Final_Result is
2598 pragma Debug (Validate_Node (Node));
2600 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result;
2601 -- Fld is one of the Traversed fields of Nod, which is necessarily a
2602 -- Node_Id or List_Id. It is traversed, and the result is the result of
2605 --------------------
2606 -- Traverse_Field --
2607 --------------------
2609 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result is
2611 if Fld /= Union_Id (Empty) then
2613 -- Descendant is a node
2615 if Fld in Node_Range then
2616 return Traverse_Func (Node_Id (Fld));
2618 -- Descendant is a list
2620 elsif Fld in List_Range then
2622 Elmt : Node_Id := First (List_Id (Fld));
2624 while Present (Elmt) loop
2625 if Traverse_Func (Elmt) = Abandon then
2634 raise Program_Error;
2641 Cur_Node : Node_Id := Node;
2643 -- Start of processing for Traverse_Func
2646 -- If the last field is a node, we eliminate the tail recursion by
2647 -- jumping back to this label. This is because concatenations are
2648 -- sometimes deeply nested, as in X1&X2&...&Xn. Gen_IL ensures that the
2649 -- Left_Opnd field of N_Op_Concat comes last in Traversed_Fields, so the
2650 -- tail recursion is eliminated in that case. This trick prevents us
2651 -- from running out of stack memory in that case. We don't bother
2652 -- eliminating the tail recursion if the last field is a list.
2654 -- (To check, look in the body of Sinfo.Nodes, search for the Left_Opnd
2655 -- getter, and note the offset of Left_Opnd. Then look in the spec of
2656 -- Sinfo.Nodes, look at the Traversed_Fields table, search for the
2657 -- N_Op_Concat component. The offset of Left_Opnd should be the last
2658 -- component before the No_Field_Offset sentinels.)
2662 case Process (Cur_Node) is
2673 Cur_Node := Original_Node (Cur_Node);
2676 -- Check for empty Traversed_Fields before entering loop below, so the
2677 -- tail recursive step won't go past the end.
2680 Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First;
2681 Offsets : Traversed_Offset_Array renames
2682 Traversed_Fields (Nkind (Cur_Node));
2685 if Offsets (Traversed_Offset_Array'First) /= No_Field_Offset then
2686 while Offsets (Cur_Field + 1) /= No_Field_Offset loop
2688 F : constant Union_Id :=
2689 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
2692 if Traverse_Field (F) = Abandon then
2697 Cur_Field := Cur_Field + 1;
2701 F : constant Union_Id :=
2702 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
2705 if F not in Node_Range then
2706 if Traverse_Field (F) = Abandon then
2710 elsif F /= Empty_List_Or_Node then
2711 -- Here is the tail recursion step, we reset Cur_Node and
2712 -- jump back to the start of the procedure, which has the
2713 -- same semantic effect as a call.
2715 Cur_Node := Node_Id (F);
2725 -------------------------------
2726 -- Traverse_Func_With_Parent --
2727 -------------------------------
2729 function Traverse_Func_With_Parent
2730 (Node : Node_Id) return Traverse_Final_Result
2732 function Traverse is new Internal_Traverse_With_Parent (Process);
2733 Result : Traverse_Final_Result;
2735 -- Ensure that the Parents stack is not currently in use; required since
2736 -- it is global and hence a tree traversal with parents must be finished
2737 -- before the next tree traversal with parents starts.
2739 pragma Assert (Parents_Stack.Last = 0);
2740 Parents_Stack.Set_Last (0);
2742 Parents_Stack.Append (Parent (Node));
2743 Result := Traverse (Node);
2744 Parents_Stack.Decrement_Last;
2746 pragma Assert (Parents_Stack.Last = 0);
2749 end Traverse_Func_With_Parent;
2755 procedure Traverse_Proc (Node : Node_Id) is
2756 function Traverse is new Traverse_Func (Process);
2757 Discard : Traverse_Final_Result;
2758 pragma Warnings (Off, Discard);
2760 Discard := Traverse (Node);
2763 -------------------------------
2764 -- Traverse_Proc_With_Parent --
2765 -------------------------------
2767 procedure Traverse_Proc_With_Parent (Node : Node_Id) is
2768 function Traverse is new Traverse_Func_With_Parent (Process);
2769 Discard : Traverse_Final_Result;
2770 pragma Warnings (Off, Discard);
2772 Discard := Traverse (Node);
2773 end Traverse_Proc_With_Parent;
2781 Orig_Nodes.Locked := False;
2788 procedure Unlock_Nodes is
2790 pragma Assert (Locked);
2798 procedure Zero_Dynamic_Slots (First, Last : Node_Offset'Base) is
2800 Slots.Table (First .. Last) := (others => 0);
2801 end Zero_Dynamic_Slots;
2803 procedure Zero_Header_Slots (N : Node_Or_Entity_Id) is
2804 All_Node_Offsets : Node_Offsets.Table_Type renames
2805 Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
2807 All_Node_Offsets (N).Slots := (others => 0);
2808 end Zero_Header_Slots;
2810 procedure Zero_Slots (N : Node_Or_Entity_Id) is
2812 Zero_Dynamic_Slots (Off_F (N), Off_L (N));
2813 Zero_Header_Slots (N);
2816 ----------------------
2817 -- Print_Statistics --
2818 ----------------------
2820 procedure Print_Node_Statistics;
2821 procedure Print_Field_Statistics;
2822 -- Helpers for Print_Statistics
2824 procedure Write_Ratio (X : Nat_64; Y : Pos_64);
2825 -- Write the value of (X/Y) without using 'Image
(approximately
)
2827 procedure Write_Ratio
(X
: Nat_64
; Y
: Pos_64
) is
2828 pragma Assert
(X
<= Y
);
2829 Ratio
: constant Nat
:= Nat
((Long_Float (X
) / Long_Float (Y
)) * 1000.0);
2834 Write_Str
("0.000");
2835 elsif Ratio
in 1 .. 9 then
2838 elsif Ratio
in 10 .. 99 then
2841 elsif Ratio
in 100 .. 999 then
2845 Write_Int
(Ratio
/ 1000);
2851 procedure Print_Node_Statistics
is
2852 subtype Count
is Nat_64
;
2853 Node_Counts
: array (Node_Kind
) of Count
:= (others => 0);
2854 Entity_Counts
: array (Entity_Kind
) of Count
:= (others => 0);
2856 -- We put the Node_Kinds and Entity_Kinds into a table just because
2857 -- GNAT.Table has a handy sort procedure. We're sorting in decreasing
2858 -- order of Node_Counts, for printing.
2860 package Node_Kind_Table
is new GNAT
.Table
2861 (Table_Component_Type
=> Node_Kind
,
2862 Table_Index_Type
=> Pos
,
2863 Table_Low_Bound
=> Pos
'First,
2865 Table_Increment
=> 100
2867 function Higher_Count
(X
, Y
: Node_Kind
) return Boolean is
2868 (Node_Counts
(X
) > Node_Counts
(Y
));
2869 procedure Sort_Node_Kind_Table
is new
2870 Node_Kind_Table
.Sort_Table
(Lt
=> Higher_Count
);
2872 package Entity_Kind_Table
is new GNAT
.Table
2873 (Table_Component_Type
=> Entity_Kind
,
2874 Table_Index_Type
=> Pos
,
2875 Table_Low_Bound
=> Pos
'First,
2877 Table_Increment
=> 100
2879 function Higher_Count
(X
, Y
: Entity_Kind
) return Boolean is
2880 (Entity_Counts
(X
) > Entity_Counts
(Y
));
2881 procedure Sort_Entity_Kind_Table
is new
2882 Entity_Kind_Table
.Sort_Table
(Lt
=> Higher_Count
);
2884 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
2885 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
2887 Write_Int
(Int
(Node_Offsets
.Last
));
2888 Write_Line
(" nodes (including entities)");
2889 Write_Int
(Int
(Slots
.Last
));
2890 Write_Line
(" non-header slots");
2892 -- Count up the number of each kind of node and entity
2894 for N
in All_Node_Offsets
'Range loop
2896 K
: constant Node_Kind
:= Nkind
(N
);
2899 Node_Counts
(K
) := Node_Counts
(K
) + 1;
2901 if K
in N_Entity
then
2902 Entity_Counts
(Ekind
(N
)) := Entity_Counts
(Ekind
(N
)) + 1;
2907 -- Copy kinds to tables, and sort:
2909 for K
in Node_Kind
loop
2910 Node_Kind_Table
.Append
(K
);
2912 Sort_Node_Kind_Table
;
2914 for K
in Entity_Kind
loop
2915 Entity_Kind_Table
.Append
(K
);
2917 Sort_Entity_Kind_Table
;
2919 -- Print out the counts for each kind in decreasing order. Exit the loop
2920 -- if we see a zero count, because all the rest must be zero, and the
2921 -- zero ones are boring.
2924 use Node_Kind_Table
;
2925 -- Note: the full qualification of First below is needed for
2926 -- bootstrap builds.
2927 Table
: Table_Type
renames Node_Kind_Table
.Table
2928 (Node_Kind_Table
.First
.. Last
);
2930 for J
in Table
'Range loop
2932 K
: constant Node_Kind
:= Table
(J
);
2933 Count
: constant Nat_64
:= Node_Counts
(K
);
2935 exit when Count
= 0; -- skip the rest
2937 Write_Int_64
(Count
);
2938 Write_Ratio
(Count
, Int_64
(Node_Offsets
.Last
));
2940 Write_Str
(Node_Kind
'Image (K
));
2942 Write_Int
(Int
(Sinfo
.Nodes
.Size
(K
)));
2943 Write_Str
(" slots");
2950 use Entity_Kind_Table
;
2951 -- Note: the full qualification of First below is needed for
2952 -- bootstrap builds.
2953 Table
: Table_Type
renames Entity_Kind_Table
.Table
2954 (Entity_Kind_Table
.First
.. Last
);
2956 for J
in Table
'Range loop
2958 K
: constant Entity_Kind
:= Table
(J
);
2959 Count
: constant Nat_64
:= Entity_Counts
(K
);
2961 exit when Count
= 0; -- skip the rest
2963 Write_Int_64
(Count
);
2964 Write_Ratio
(Count
, Int_64
(Node_Offsets
.Last
));
2966 Write_Str
(Entity_Kind
'Image (K
));
2968 Write_Int
(Int
(Einfo
.Entities
.Size
(K
)));
2969 Write_Str
(" slots");
2974 end Print_Node_Statistics
;
2976 procedure Print_Field_Statistics
is
2977 Total
, G_Total
, S_Total
: Call_Count
:= 0;
2979 -- Use a table for sorting, as done in Print_Node_Statistics.
2981 package Field_Table
is new GNAT
.Table
2982 (Table_Component_Type
=> Node_Or_Entity_Field
,
2983 Table_Index_Type
=> Pos
,
2984 Table_Low_Bound
=> Pos
'First,
2986 Table_Increment
=> 100
2988 function Higher_Count
(X
, Y
: Node_Or_Entity_Field
) return Boolean is
2989 (Get_Count
(X
) + Set_Count
(X
) > Get_Count
(Y
) + Set_Count
(Y
));
2990 procedure Sort_Field_Table
is new
2991 Field_Table
.Sort_Table
(Lt
=> Higher_Count
);
2993 Write_Int_64
(Get_Original_Node_Count
);
2995 Write_Int_64
(Set_Original_Node_Count
);
2996 Write_Line
(" Original_Node_Count getter and setter calls");
2999 Write_Line
("Frequency of field getter and setter calls:");
3001 for Field
in Node_Or_Entity_Field
loop
3002 G_Total
:= G_Total
+ Get_Count
(Field
);
3003 S_Total
:= S_Total
+ Set_Count
(Field
);
3004 Total
:= G_Total
+ S_Total
;
3007 -- This assertion helps CodePeer understand that Total cannot be 0 (this
3008 -- is true because GNAT does not attempt to compile empty files).
3009 pragma Assert
(Total
> 0);
3011 Write_Int_64
(Total
);
3012 Write_Str
(" (100%) = ");
3013 Write_Int_64
(G_Total
);
3015 Write_Int_64
(S_Total
);
3016 Write_Line
(" total getter and setter calls");
3018 -- Copy fields to the table, and sort:
3020 for F
in Node_Or_Entity_Field
loop
3021 Field_Table
.Append
(F
);
3025 -- Print out the counts for each field in decreasing order of
3026 -- getter+setter sum. As in Print_Node_Statistics, exit the loop
3027 -- if we see a zero sum.
3031 -- Note: the full qualification of First below is needed for
3032 -- bootstrap builds.
3033 Table
: Table_Type
renames
3034 Field_Table
.Table
(Field_Table
.First
.. Last
);
3036 for J
in Table
'Range loop
3038 Field
: constant Node_Or_Entity_Field
:= Table
(J
);
3040 G
: constant Call_Count
:= Get_Count
(Field
);
3041 S
: constant Call_Count
:= Set_Count
(Field
);
3042 GS
: constant Call_Count
:= G
+ S
;
3044 Desc
: Field_Descriptor
renames Field_Descriptors
(Field
);
3045 Slot
: constant Field_Offset
:=
3046 (Field_Size
(Desc
.Kind
) * Desc
.Offset
) / Slot_Size
;
3049 exit when GS
= 0; -- skip the rest
3052 Write_Ratio
(GS
, Total
);
3058 Write_Str
(Node_Or_Entity_Field
'Image (Field
));
3059 Write_Str
(" in slot ");
3060 Write_Int
(Int
(Slot
));
3061 Write_Str
(" size ");
3062 Write_Int
(Int
(Field_Size
(Desc
.Kind
)));
3067 end Print_Field_Statistics
;
3069 procedure Print_Statistics
is
3073 Print_Node_Statistics
;
3075 Print_Field_Statistics
;
3076 end Print_Statistics
;