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 Aspects
; use Aspects
;
28 with Debug
; use Debug
;
29 with Namet
; use Namet
;
30 with Nlists
; use Nlists
;
32 with Output
; use Output
;
33 with Sinfo
.Utils
; use Sinfo
.Utils
;
34 with System
.Storage_Elements
;
42 -- Suppose you find that node 12345 is messed up. You might want to find
43 -- the code that created that node. See sinfo-utils.adb for how to do that.
45 Ignored_Ghost_Recording_Proc
: Ignored_Ghost_Record_Proc
:= null;
46 -- This soft link captures the procedure invoked during the creation of an
47 -- ignored Ghost node or entity.
49 Locked
: Boolean := False;
50 -- Compiling with assertions enabled, node contents modifications are
51 -- permitted only when this switch is set to False; compiling without
52 -- assertions this lock has no effect.
54 Reporting_Proc
: Report_Proc
:= null;
55 -- Set_Reporting_Proc sets this. Set_Reporting_Proc must be called only
58 Rewriting_Proc
: Rewrite_Proc
:= null;
59 -- This soft link captures the procedure invoked during a node rewrite
61 -----------------------------
62 -- Local Objects and Types --
63 -----------------------------
65 Comes_From_Source_Default
: Boolean := False;
67 use Atree_Private_Part
;
68 -- We are also allowed to see our private data structures
70 --------------------------------------------------
71 -- Implementation of Tree Substitution Routines --
72 --------------------------------------------------
74 -- A separate table keeps track of the mapping between rewritten nodes and
75 -- their corresponding original tree nodes. Rewrite makes an entry in this
76 -- table for use by Original_Node. By default the entry in this table
77 -- points to the original unwritten node. Note that if a node is rewritten
78 -- more than once, there is no easy way to get to the intermediate
79 -- rewrites; the node itself is the latest version, and the entry in this
80 -- table is the original.
82 -- Note: This could be a node field.
84 package Orig_Nodes
is new Table
.Table
(
85 Table_Component_Type
=> Node_Id
,
86 Table_Index_Type
=> Node_Id
'Base,
87 Table_Low_Bound
=> First_Node_Id
,
88 Table_Initial
=> Alloc
.Node_Offsets_Initial
,
89 Table_Increment
=> Alloc
.Node_Offsets_Increment
,
90 Table_Name
=> "Orig_Nodes");
96 -- A separate table is used to traverse trees. It passes the parent field
97 -- of each node to the called process subprogram. It is defined global to
98 -- avoid adding performance overhead if allocated each time the traversal
99 -- functions are invoked.
101 package Parents_Stack
is new Table
.Table
102 (Table_Component_Type
=> Node_Id
,
103 Table_Index_Type
=> Nat
,
104 Table_Low_Bound
=> 1,
105 Table_Initial
=> 256,
106 Table_Increment
=> 100,
107 Table_Name
=> "Parents_Stack");
109 --------------------------
110 -- Paren_Count Handling --
111 --------------------------
113 -- The Small_Paren_Count field has range 0 .. 3. If the Paren_Count is
114 -- in the range 0 .. 2, then it is stored as Small_Paren_Count. Otherwise,
115 -- Small_Paren_Count = 3, and the actual Paren_Count is stored in the
116 -- Paren_Counts table.
118 -- We use linear search on the Paren_Counts table, which is plenty
119 -- efficient because only pathological programs will use it. Nobody
120 -- writes (((X + Y))).
122 type Paren_Count_Entry
is record
124 -- The node to which this count applies
126 Count
: Nat
range 3 .. Nat
'Last;
127 -- The count of parentheses, which will be in the indicated range
130 package Paren_Counts
is new Table
.Table
(
131 Table_Component_Type
=> Paren_Count_Entry
,
132 Table_Index_Type
=> Int
,
133 Table_Low_Bound
=> 0,
135 Table_Increment
=> 200,
136 Table_Name
=> "Paren_Counts");
138 procedure Set_Paren_Count_Of_Copy
(Target
, Source
: Node_Id
);
139 pragma Inline
(Set_Paren_Count_Of_Copy
);
140 -- Called when copying a node. Makes sure the Paren_Count of the copy is
143 -----------------------
144 -- Local Subprograms --
145 -----------------------
147 function Allocate_New_Node
(Kind
: Node_Kind
) return Node_Id
;
148 pragma Inline
(Allocate_New_Node
);
149 -- Allocate a new node or first part of a node extension. Initialize the
150 -- Nodes.Table entry, Flags, Orig_Nodes, and List tables.
152 procedure Fix_Parents
(Ref_Node
, Fix_Node
: Node_Id
);
153 -- Fix up parent pointers for the children of Fix_Node after a copy,
154 -- setting them to Fix_Node when they pointed to Ref_Node.
157 with function Process
158 (Parent_Node
: Node_Id
;
159 Node
: Node_Id
) return Traverse_Result
is <>;
160 function Internal_Traverse_With_Parent
161 (Node
: Node_Id
) return Traverse_Final_Result
;
162 pragma Inline
(Internal_Traverse_With_Parent
);
163 -- Internal function that provides a functionality similar to Traverse_Func
164 -- but extended to pass the Parent node to the called Process subprogram;
165 -- delegates to Traverse_Func_With_Parent the initialization of the stack
166 -- data structure which stores the parent nodes (cf. Parents_Stack).
167 -- ??? Could we factorize the common code of Internal_Traverse_Func and
170 procedure Mark_New_Ghost_Node
(N
: Node_Or_Entity_Id
);
171 -- Mark arbitrary node or entity N as Ghost when it is created within a
174 procedure Report
(Target
, Source
: Node_Id
);
175 pragma Inline
(Report
);
176 -- Invoke the reporting procedure if available
178 function Size_In_Slots
(N
: Node_Or_Entity_Id
) return Slot_Count
;
179 -- Number of slots belonging to N. This can be less than
180 -- Size_In_Slots_To_Alloc for entities. Includes both header
181 -- and dynamic slots.
183 function Size_In_Slots_Dynamic
(N
: Node_Or_Entity_Id
) return Slot_Count
;
184 -- Just counts the number of dynamic slots
186 function Size_In_Slots_To_Alloc
(N
: Node_Or_Entity_Id
) return Slot_Count
;
187 function Size_In_Slots_To_Alloc
(Kind
: Node_Kind
) return Slot_Count
;
188 -- Number of slots to allocate for a node or entity. For entities, we have
189 -- to allocate the max, because we don't know the Ekind when this is
192 function Off_F
(N
: Node_Id
) return Node_Offset
with Inline
;
193 -- Offset of the first dynamic slot of N in Slots.Table.
194 -- The actual offset of this slot from the start of the node
195 -- is not 0; this is logically the first slot after the header
198 function Off_0
(N
: Node_Id
) return Node_Offset
'Base with Inline
;
199 -- This is for zero-origin addressing of the dynamic slots.
200 -- It points to slot 0 of N in Slots.Table, which does not exist,
201 -- because the first few slots are stored in the header.
203 function Off_L
(N
: Node_Id
) return Node_Offset
with Inline
;
204 -- Offset of the last slot of N in Slots.Table
206 procedure Zero_Dynamic_Slots
(First
, Last
: Node_Offset
'Base) with Inline
;
207 -- Set dynamic slots in the range First..Last to zero
209 procedure Zero_Header_Slots
(N
: Node_Or_Entity_Id
) with Inline
;
210 -- Zero the header slots belonging to N
212 procedure Zero_Slots
(N
: Node_Or_Entity_Id
) with Inline
;
213 -- Zero the slots belonging to N (both header and dynamic)
215 procedure Copy_Dynamic_Slots
216 (From
, To
: Node_Offset
; Num_Slots
: Slot_Count
)
218 -- Copy Num_Slots slots from From to To. Caller is responsible for ensuring
219 -- that the Num_Slots at To are a reasonable place to copy to.
221 procedure Copy_Slots
(Source
, Destination
: Node_Id
) with Inline
;
222 -- Copies the slots (both header and dynamic) of Source to Destination;
223 -- uses the node kind to determine the Num_Slots.
225 function Get_Field_Value
226 (N
: Node_Id
; Field
: Node_Or_Entity_Field
) return Field_Size_32_Bit
;
227 -- Get any field value as a Field_Size_32_Bit. If the field is smaller than
228 -- 32 bits, convert it to Field_Size_32_Bit. The Field must be present in
231 procedure Set_Field_Value
232 (N
: Node_Id
; Field
: Node_Or_Entity_Field
; Val
: Field_Size_32_Bit
);
233 -- Set any field value as a Field_Size_32_Bit. If the field is smaller than
234 -- 32 bits, convert it from Field_Size_32_Bit, and Val had better be small
235 -- enough. The Field must be present in the Nkind of N.
237 procedure Check_Vanishing_Fields
238 (Old_N
: Node_Id
; New_Kind
: Node_Kind
);
239 -- Called whenever Nkind is modified. Raises an exception if not all
240 -- vanishing fields are in their initial zero state.
242 procedure Check_Vanishing_Fields
243 (Old_N
: Entity_Id
; New_Kind
: Entity_Kind
);
244 -- Above are the same as the ones for nodes, but for entities
246 procedure Init_Nkind
(N
: Node_Id
; Val
: Node_Kind
);
247 -- Initialize the Nkind field, which must not have been set already. This
248 -- cannot be used to modify an already-initialized Nkind field. See also
251 procedure Mutate_Nkind
252 (N
: Node_Id
; Val
: Node_Kind
; Old_Size
: Slot_Count
);
253 -- Called by the other Mutate_Nkind to do all the work. This is needed
254 -- because the call in Change_Node, which calls this one directly, happens
255 -- after zeroing N's slots, which destroys its Nkind, which prevents us
256 -- from properly computing Old_Size.
258 package Field_Checking
is
259 -- Functions for checking field access, used only in assertions
261 function Field_Present
262 (Kind
: Node_Kind
; Field
: Node_Field
) return Boolean;
263 function Field_Present
264 (Kind
: Entity_Kind
; Field
: Entity_Field
) return Boolean;
265 -- True if a node/entity of the given Kind has the given Field.
266 -- Always True if assertions are disabled.
270 package body Field_Checking
is
272 -- Tables used by Field_Present
274 type Node_Field_Sets
is array (Node_Kind
) of Node_Field_Set
;
275 type Node_Field_Sets_Ptr
is access all Node_Field_Sets
;
276 Node_Fields_Present
: Node_Field_Sets_Ptr
;
278 type Entity_Field_Sets
is array (Entity_Kind
) of Entity_Field_Set
;
279 type Entity_Field_Sets_Ptr
is access all Entity_Field_Sets
;
280 Entity_Fields_Present
: Entity_Field_Sets_Ptr
;
282 procedure Init_Tables
;
284 function Create_Node_Fields_Present
285 (Kind
: Node_Kind
) return Node_Field_Set
;
286 function Create_Entity_Fields_Present
287 (Kind
: Entity_Kind
) return Entity_Field_Set
;
288 -- Computes the set of fields present in each Node/Entity Kind. Used to
289 -- initialize the above tables.
291 --------------------------------
292 -- Create_Node_Fields_Present --
293 --------------------------------
295 function Create_Node_Fields_Present
296 (Kind
: Node_Kind
) return Node_Field_Set
298 Result
: Node_Field_Set
:= (others => False);
300 for J
in Node_Field_Table
(Kind
)'Range loop
301 Result
(Node_Field_Table
(Kind
) (J
)) := True;
305 end Create_Node_Fields_Present
;
307 --------------------------------
308 -- Create_Entity_Fields_Present --
309 --------------------------------
311 function Create_Entity_Fields_Present
312 (Kind
: Entity_Kind
) return Entity_Field_Set
314 Result
: Entity_Field_Set
:= (others => False);
316 for J
in Entity_Field_Table
(Kind
)'Range loop
317 Result
(Entity_Field_Table
(Kind
) (J
)) := True;
321 end Create_Entity_Fields_Present
;
327 procedure Init_Tables
is
329 Node_Fields_Present
:= new Node_Field_Sets
;
331 for Kind
in Node_Kind
loop
332 Node_Fields_Present
(Kind
) := Create_Node_Fields_Present
(Kind
);
335 Entity_Fields_Present
:= new Entity_Field_Sets
;
337 for Kind
in Entity_Kind
loop
338 Entity_Fields_Present
(Kind
) :=
339 Create_Entity_Fields_Present
(Kind
);
343 -- In production mode, we leave Node_Fields_Present and
344 -- Entity_Fields_Present null. Field_Present is only for
345 -- use in assertions.
347 pragma Debug
(Init_Tables
);
349 function Field_Present
350 (Kind
: Node_Kind
; Field
: Node_Field
) return Boolean is
352 if Node_Fields_Present
= null then
356 return Node_Fields_Present
(Kind
) (Field
);
359 function Field_Present
360 (Kind
: Entity_Kind
; Field
: Entity_Field
) return Boolean is
362 if Entity_Fields_Present
= null then
366 return Entity_Fields_Present
(Kind
) (Field
);
371 ------------------------
372 -- Atree_Private_Part --
373 ------------------------
375 package body Atree_Private_Part
is
377 -- The following validators are disabled in production builds, by being
378 -- called in pragma Debug. They are also disabled by default in debug
379 -- builds, by setting the flags below, because they make the compiler
380 -- very slow (10 to 20 times slower). Validate can be set True to debug
381 -- the low-level accessors.
383 -- Even if Validate is True, validation is disabled during
384 -- Validate_... calls to prevent infinite recursion
385 -- (Validate_... procedures call field getters, which call
386 -- Validate_... procedures). That's what the Enable_Validate_...
387 -- flags are for; they are toggled so that when we're inside one
388 -- of them, and enter it again, the inner call doesn't do anything.
389 -- These flags are irrelevant when Validate is False.
391 Validate
: constant Boolean := False;
393 Enable_Validate_Node
,
394 Enable_Validate_Node_Write
,
395 Enable_Validate_Node_And_Offset
,
396 Enable_Validate_Node_And_Offset_Write
:
399 procedure Validate_Node_And_Offset
400 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
);
401 procedure Validate_Node_And_Offset_Write
402 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
);
403 -- Asserts N is OK, and the Offset in slots is within N. Note that this
404 -- does not guarantee that the offset is valid, just that it's not past
405 -- the last slot. It could be pointing at unused bits within the node,
406 -- or unused padding at the end. The "_Write" version is used when we're
407 -- about to modify the node.
409 procedure Validate_Node_And_Offset
410 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) is
412 if Enable_Validate_Node_And_Offset
then
413 Enable_Validate_Node_And_Offset
:= False;
415 pragma Debug
(Validate_Node
(N
));
416 pragma Assert
(Offset
'Valid);
417 pragma Assert
(Offset
< Size_In_Slots
(N
));
419 Enable_Validate_Node_And_Offset
:= True;
421 end Validate_Node_And_Offset
;
423 procedure Validate_Node_And_Offset_Write
424 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) is
426 if Enable_Validate_Node_And_Offset_Write
then
427 Enable_Validate_Node_And_Offset_Write
:= False;
429 pragma Debug
(Validate_Node_Write
(N
));
430 pragma Assert
(Offset
'Valid);
431 pragma Assert
(Offset
< Size_In_Slots
(N
));
433 Enable_Validate_Node_And_Offset_Write
:= True;
435 end Validate_Node_And_Offset_Write
;
437 procedure Validate_Node
(N
: Node_Or_Entity_Id
) is
439 if Enable_Validate_Node
then
440 Enable_Validate_Node
:= False;
442 pragma Assert
(N
'Valid);
443 pragma Assert
(N
<= Node_Offsets
.Last
);
444 pragma Assert
(Off_L
(N
) >= Off_0
(N
));
445 pragma Assert
(Off_L
(N
) >= Off_F
(N
) - 1);
446 pragma Assert
(Off_L
(N
) <= Slots
.Last
);
447 pragma Assert
(Nkind
(N
)'Valid);
448 pragma Assert
(Nkind
(N
) /= N_Unused_At_End
);
450 if Nkind
(N
) in N_Entity
then
451 pragma Assert
(Ekind
(N
)'Valid);
456 | N_Attribute_Definition_Clause
457 | N_Aspect_Specification
458 | N_Extension_Aggregate
460 | N_Freeze_Generic_Entity
462 | N_Selected_Component
463 | N_Use_Package_Clause
465 pragma Assert
(Entity_Or_Associated_Node
(N
)'Valid);
468 Enable_Validate_Node
:= True;
472 procedure Validate_Node_Write
(N
: Node_Or_Entity_Id
) is
474 if Enable_Validate_Node_Write
then
475 Enable_Validate_Node_Write
:= False;
477 pragma Debug
(Validate_Node
(N
));
478 pragma Assert
(not Locked
);
480 Enable_Validate_Node_Write
:= True;
482 end Validate_Node_Write
;
484 function Is_Valid_Node
(U
: Union_Id
) return Boolean is
486 return Node_Id
'Base (U
) <= Node_Offsets
.Last
;
489 function Alloc_Node_Id
return Node_Id
is
491 Node_Offsets
.Increment_Last
;
492 return Node_Offsets
.Last
;
495 function Alloc_Slots
(Num_Slots
: Slot_Count
) return Node_Offset
is
497 return Result
: constant Node_Offset
:= Slots
.Last
+ 1 do
498 Slots
.Set_Last
(Slots
.Last
+ Num_Slots
);
502 function Get_1_Bit_Field
503 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
505 pragma Assert
(Field_Type
'Size = 1);
508 Ada
.Unchecked_Conversion
(Field_Size_1_Bit
, Field_Type
);
509 Val
: constant Field_Size_1_Bit
:= Get_1_Bit_Val
(N
, Offset
);
514 function Get_2_Bit_Field
515 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
517 pragma Assert
(Field_Type
'Size = 2);
520 Ada
.Unchecked_Conversion
(Field_Size_2_Bit
, Field_Type
);
521 Val
: constant Field_Size_2_Bit
:= Get_2_Bit_Val
(N
, Offset
);
526 function Get_4_Bit_Field
527 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
529 pragma Assert
(Field_Type
'Size = 4);
532 Ada
.Unchecked_Conversion
(Field_Size_4_Bit
, Field_Type
);
533 Val
: constant Field_Size_4_Bit
:= Get_4_Bit_Val
(N
, Offset
);
538 function Get_8_Bit_Field
539 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
541 pragma Assert
(Field_Type
'Size = 8);
544 Ada
.Unchecked_Conversion
(Field_Size_8_Bit
, Field_Type
);
545 Val
: constant Field_Size_8_Bit
:= Get_8_Bit_Val
(N
, Offset
);
550 function Get_32_Bit_Field
551 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
553 pragma Assert
(Field_Type
'Size = 32);
556 Ada
.Unchecked_Conversion
(Field_Size_32_Bit
, Field_Type
);
558 Val
: constant Field_Size_32_Bit
:= Get_32_Bit_Val
(N
, Offset
);
559 Result
: constant Field_Type
:= Cast
(Val
);
560 -- Note: declaring Result here instead of directly returning
561 -- Cast (...) helps CodePeer understand that there are no issues
562 -- around uninitialized variables.
565 end Get_32_Bit_Field
;
567 function Get_32_Bit_Field_With_Default
568 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
570 function Get_Field
is new Get_32_Bit_Field
(Field_Type
) with Inline
;
573 -- If the field has not yet been set, it will be equal to zero.
574 -- That is of the "wrong" type, so we fetch it as a
575 -- Field_Size_32_Bit.
577 if Get_32_Bit_Val
(N
, Offset
) = 0 then
578 Result
:= Default_Val
;
581 Result
:= Get_Field
(N
, Offset
);
585 end Get_32_Bit_Field_With_Default
;
587 function Get_Valid_32_Bit_Field
588 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Type
590 pragma Assert
(Get_32_Bit_Val
(N
, Offset
) /= 0);
591 -- If the field has not yet been set, it will be equal to zero.
592 -- This asserts that we don't call Get_ before Set_. Note that
593 -- the predicate on the Val parameter of Set_ checks for the No_...
594 -- value, so it can't possibly be (for example) No_Uint here.
596 function Get_Field
is new Get_32_Bit_Field
(Field_Type
) with Inline
;
597 Result
: constant Field_Type
:= Get_Field
(N
, Offset
);
600 end Get_Valid_32_Bit_Field
;
602 procedure Set_1_Bit_Field
603 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Type
)
605 pragma Assert
(Field_Type
'Size = 1);
608 Ada
.Unchecked_Conversion
(Field_Type
, Field_Size_1_Bit
);
610 Set_1_Bit_Val
(N
, Offset
, Cast
(Val
));
613 procedure Set_2_Bit_Field
614 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Type
)
616 pragma Assert
(Field_Type
'Size = 2);
619 Ada
.Unchecked_Conversion
(Field_Type
, Field_Size_2_Bit
);
621 Set_2_Bit_Val
(N
, Offset
, Cast
(Val
));
624 procedure Set_4_Bit_Field
625 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Type
)
627 pragma Assert
(Field_Type
'Size = 4);
630 Ada
.Unchecked_Conversion
(Field_Type
, Field_Size_4_Bit
);
632 Set_4_Bit_Val
(N
, Offset
, Cast
(Val
));
635 procedure Set_8_Bit_Field
636 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Type
)
638 pragma Assert
(Field_Type
'Size = 8);
641 Ada
.Unchecked_Conversion
(Field_Type
, Field_Size_8_Bit
);
643 Set_8_Bit_Val
(N
, Offset
, Cast
(Val
));
646 procedure Set_32_Bit_Field
647 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Type
)
649 pragma Assert
(Field_Type
'Size = 32);
652 Ada
.Unchecked_Conversion
(Field_Type
, Field_Size_32_Bit
);
654 Set_32_Bit_Val
(N
, Offset
, Cast
(Val
));
655 end Set_32_Bit_Field
;
657 pragma Style_Checks
("M90");
659 -----------------------------------
660 -- Low-level getters and setters --
661 -----------------------------------
663 -- In the getters and setters below, we use shifting and masking to
664 -- simulate packed arrays. F_Size is the field size in bits. Mask is
665 -- that number of 1 bits in the low-order bits. F_Per_Slot is the number
666 -- of fields per slot. Slot_Off is the offset of the slot of interest.
667 -- S is the slot at that offset. V is the amount to shift by.
669 function In_NH
(Slot_Off
: Field_Offset
) return Boolean is
671 -- In_NH stands for "in Node_Header", not "in New Hampshire"
674 (N
: Node_Or_Entity_Id
; Slot_Off
: Field_Offset
)
676 (if In_NH
(Slot_Off
) then
677 Node_Offsets
.Table
(N
).Slots
(Slot_Off
)
678 else Slots
.Table
(Node_Offsets
.Table
(N
).Offset
+ Slot_Off
));
679 -- Get the slot value, either directly from the node header, or
680 -- indirectly from the Slots table.
683 (N
: Node_Or_Entity_Id
; Slot_Off
: Field_Offset
; S
: Slot
);
684 -- Set the slot value, either directly from the node header, or
685 -- indirectly from the Slots table, to S.
687 function Get_1_Bit_Val
688 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Size_1_Bit
690 F_Size
: constant := 1;
691 Mask
: constant := 2**F_Size
- 1;
692 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
693 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
694 S
: constant Slot
:= Get_Slot
(N
, Slot_Off
);
695 V
: constant Natural := Natural ((Offset
mod F_Per_Slot
) * F_Size
);
696 pragma Debug
(Validate_Node_And_Offset
(N
, Slot_Off
));
697 Raw
: constant Field_Size_1_Bit
:=
698 Field_Size_1_Bit
(Shift_Right
(S
, V
) and Mask
);
703 function Get_2_Bit_Val
704 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Size_2_Bit
706 F_Size
: constant := 2;
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_2_Bit
:=
714 Field_Size_2_Bit
(Shift_Right
(S
, V
) and Mask
);
719 function Get_4_Bit_Val
720 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Size_4_Bit
722 F_Size
: constant := 4;
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_4_Bit
:=
730 Field_Size_4_Bit
(Shift_Right
(S
, V
) and Mask
);
735 function Get_8_Bit_Val
736 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Size_8_Bit
738 F_Size
: constant := 8;
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_8_Bit
:=
746 Field_Size_8_Bit
(Shift_Right
(S
, V
) and Mask
);
751 function Get_32_Bit_Val
752 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
) return Field_Size_32_Bit
754 F_Size
: constant := 32;
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 pragma Debug
(Validate_Node_And_Offset
(N
, Slot_Off
));
760 Raw
: constant Field_Size_32_Bit
:=
761 Field_Size_32_Bit
(S
);
767 (N
: Node_Or_Entity_Id
; Slot_Off
: Field_Offset
; S
: Slot
) is
769 if In_NH
(Slot_Off
) then
770 Node_Offsets
.Table
(N
).Slots
(Slot_Off
) := S
;
772 Slots
.Table
(Node_Offsets
.Table
(N
).Offset
+ Slot_Off
) := S
;
776 procedure Set_1_Bit_Val
777 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Size_1_Bit
)
779 F_Size
: constant := 1;
780 Mask
: constant := 2**F_Size
- 1;
781 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
782 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
783 S
: constant Slot
:= Get_Slot
(N
, Slot_Off
);
784 V
: constant Natural := Natural ((Offset
mod F_Per_Slot
) * F_Size
);
785 pragma Debug
(Validate_Node_And_Offset_Write
(N
, Slot_Off
));
789 (S
and not Shift_Left
(Mask
, V
)) or Shift_Left
(Slot
(Val
), V
));
792 procedure Set_2_Bit_Val
793 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Size_2_Bit
)
795 F_Size
: constant := 2;
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_4_Bit_Val
809 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Size_4_Bit
)
811 F_Size
: constant := 4;
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_8_Bit_Val
825 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Size_8_Bit
)
827 F_Size
: constant := 8;
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_32_Bit_Val
841 (N
: Node_Or_Entity_Id
; Offset
: Field_Offset
; Val
: Field_Size_32_Bit
)
843 F_Size
: constant := 32;
844 -- No Mask needed; this one doesn't do read-modify-write
845 F_Per_Slot
: constant Field_Offset
:= Slot_Size
/ F_Size
;
846 Slot_Off
: constant Field_Offset
:= Offset
/ F_Per_Slot
;
847 pragma Debug
(Validate_Node_And_Offset_Write
(N
, Slot_Off
));
849 Set_Slot
(N
, Slot_Off
, Slot
(Val
));
852 ----------------------
853 -- Print_Atree_Info --
854 ----------------------
856 procedure Print_Atree_Info
(N
: Node_Or_Entity_Id
) is
857 function Cast
is new Ada
.Unchecked_Conversion
(Slot
, Int
);
859 Write_Int
(Int
(Size_In_Slots
(N
)));
860 Write_Str
(" slots (");
861 Write_Int
(Int
(Off_0
(N
)));
863 Write_Int
(Int
(Off_L
(N
)));
866 for Off
in Off_0
(N
) .. Off_L
(N
) loop
868 Write_Int
(Cast
(Get_Slot
(N
, Off
)));
872 end Print_Atree_Info
;
874 end Atree_Private_Part
;
876 ---------------------
877 -- Get_Field_Value --
878 ---------------------
880 function Get_Node_Field_Union
is new Get_32_Bit_Field
(Union_Id
)
882 -- Called when we don't know whether a field is a Node_Id or a List_Id,
885 function Get_Field_Value
886 (N
: Node_Id
; Field
: Node_Or_Entity_Field
) return Field_Size_32_Bit
888 Desc
: Field_Descriptor
renames Field_Descriptors
(Field
);
889 NN
: constant Node_Or_Entity_Id
:= Node_To_Fetch_From
(N
, Field
);
892 case Field_Size
(Desc
.Kind
) is
893 when 1 => return Field_Size_32_Bit
(Get_1_Bit_Val
(NN
, Desc
.Offset
));
894 when 2 => return Field_Size_32_Bit
(Get_2_Bit_Val
(NN
, Desc
.Offset
));
895 when 4 => return Field_Size_32_Bit
(Get_4_Bit_Val
(NN
, Desc
.Offset
));
896 when 8 => return Field_Size_32_Bit
(Get_8_Bit_Val
(NN
, Desc
.Offset
));
897 when others => return Get_32_Bit_Val
(NN
, Desc
.Offset
); -- 32
901 ---------------------
902 -- Set_Field_Value --
903 ---------------------
905 procedure Set_Field_Value
906 (N
: Node_Id
; Field
: Node_Or_Entity_Field
; Val
: Field_Size_32_Bit
)
908 Desc
: Field_Descriptor
renames Field_Descriptors
(Field
);
911 case Field_Size
(Desc
.Kind
) is
912 when 1 => Set_1_Bit_Val
(N
, Desc
.Offset
, Field_Size_1_Bit
(Val
));
913 when 2 => Set_2_Bit_Val
(N
, Desc
.Offset
, Field_Size_2_Bit
(Val
));
914 when 4 => Set_4_Bit_Val
(N
, Desc
.Offset
, Field_Size_4_Bit
(Val
));
915 when 8 => Set_8_Bit_Val
(N
, Desc
.Offset
, Field_Size_8_Bit
(Val
));
916 when others => Set_32_Bit_Val
(N
, Desc
.Offset
, Val
); -- 32
920 procedure Reinit_Field_To_Zero
921 (N
: Node_Id
; Field
: Node_Or_Entity_Field
)
924 Set_Field_Value
(N
, Field
, 0);
925 end Reinit_Field_To_Zero
;
927 function Field_Is_Initial_Zero
928 (N
: Node_Id
; Field
: Node_Or_Entity_Field
) return Boolean is
930 return Get_Field_Value
(N
, Field
) = 0;
931 end Field_Is_Initial_Zero
;
933 procedure Reinit_Field_To_Zero
934 (N
: Node_Id
; Field
: Entity_Field
; Old_Ekind
: Entity_Kind_Set
) is
936 pragma Assert
(Old_Ekind
(Ekind
(N
)), "Reinit: " & Ekind
(N
)'Img);
937 Reinit_Field_To_Zero
(N
, Field
);
938 end Reinit_Field_To_Zero
;
940 procedure Reinit_Field_To_Zero
941 (N
: Node_Id
; Field
: Entity_Field
; Old_Ekind
: Entity_Kind
) is
942 Old_Ekind_Set
: Entity_Kind_Set
:= (others => False);
944 Old_Ekind_Set
(Old_Ekind
) := True;
945 Reinit_Field_To_Zero
(N
, Field
, Old_Ekind
=> Old_Ekind_Set
);
946 end Reinit_Field_To_Zero
;
948 procedure Check_Vanishing_Fields
949 (Old_N
: Node_Id
; New_Kind
: Node_Kind
)
951 Old_Kind
: constant Node_Kind
:= Nkind
(Old_N
);
953 -- If this fails, it means you need to call Reinit_Field_To_Zero before
954 -- calling Mutate_Nkind.
957 for J
in Node_Field_Table
(Old_Kind
)'Range loop
959 F
: constant Node_Field
:= Node_Field_Table
(Old_Kind
) (J
);
961 if not Field_Checking
.Field_Present
(New_Kind
, F
) then
962 if not Field_Is_Initial_Zero
(Old_N
, F
) then
963 Write_Str
(Old_Kind
'Img);
965 Write_Str
(New_Kind
'Img);
966 Write_Str
(" Nonzero field ");
968 Write_Str
(" is vanishing for node ");
969 Write_Int
(Nat
(Old_N
));
977 end Check_Vanishing_Fields
;
979 procedure Check_Vanishing_Fields
980 (Old_N
: Entity_Id
; New_Kind
: Entity_Kind
)
982 Old_Kind
: constant Entity_Kind
:= Ekind
(Old_N
);
984 -- If this fails, it means you need to call Reinit_Field_To_Zero before
985 -- calling Mutate_Ekind. But we have many cases where vanishing fields
986 -- are expected to reappear after converting to/from E_Void. Other cases
987 -- are more problematic; set a breakpoint on "(non-E_Void case)" below.
990 for J
in Entity_Field_Table
(Old_Kind
)'Range loop
992 F
: constant Entity_Field
:= Entity_Field_Table
(Old_Kind
) (J
);
994 if not Field_Checking
.Field_Present
(New_Kind
, F
) then
995 if not Field_Is_Initial_Zero
(Old_N
, F
) then
996 Write_Str
(Old_Kind
'Img);
998 Write_Str
(New_Kind
'Img);
999 Write_Str
(" Nonzero field ");
1001 Write_Str
(" is vanishing for node ");
1002 Write_Int
(Nat
(Old_N
));
1005 if New_Kind
= E_Void
or else Old_Kind
= E_Void
then
1006 Write_Line
(" (E_Void case)");
1008 Write_Line
(" (non-E_Void case)");
1014 end Check_Vanishing_Fields
;
1016 Nkind_Offset
: constant Field_Offset
:=
1017 Field_Descriptors
(F_Nkind
).Offset
;
1019 procedure Set_Node_Kind_Type
is new Set_8_Bit_Field
(Node_Kind
) with Inline
;
1021 procedure Init_Nkind
(N
: Node_Id
; Val
: Node_Kind
) is
1022 pragma Assert
(Field_Is_Initial_Zero
(N
, F_Nkind
));
1024 if Atree_Statistics_Enabled
then
1025 Set_Count
(F_Nkind
) := Set_Count
(F_Nkind
) + 1;
1028 Set_Node_Kind_Type
(N
, Nkind_Offset
, Val
);
1031 procedure Mutate_Nkind
1032 (N
: Node_Id
; Val
: Node_Kind
; Old_Size
: Slot_Count
)
1034 New_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Val
);
1036 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
1037 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
1039 pragma Debug
(Check_Vanishing_Fields
(N
, Val
));
1041 -- Grow the slots if necessary
1043 if Old_Size
< New_Size
then
1045 Old_Last_Slot
: constant Node_Offset
:= Slots
.Last
;
1046 Old_Off_F
: constant Node_Offset
:= Off_F
(N
);
1048 if Old_Last_Slot
= Old_Off_F
+ Old_Size
- 1 then
1049 -- In this case, the slots are at the end of Slots.Table, so we
1050 -- don't need to move them.
1051 Slots
.Set_Last
(Old_Last_Slot
+ New_Size
- Old_Size
);
1057 New_Off_F
: constant Node_Offset
:= Alloc_Slots
(New_Size
);
1059 All_Node_Offsets
(N
).Offset
:= New_Off_F
- N_Head
;
1060 Copy_Dynamic_Slots
(Old_Off_F
, New_Off_F
, Old_Size
);
1062 (Zero_Dynamic_Slots
(Old_Off_F
, Old_Off_F
+ Old_Size
- 1));
1067 Zero_Dynamic_Slots
(Off_F
(N
) + Old_Size
, Slots
.Last
);
1070 if Atree_Statistics_Enabled
then
1071 Set_Count
(F_Nkind
) := Set_Count
(F_Nkind
) + 1;
1074 Set_Node_Kind_Type
(N
, Nkind_Offset
, Val
);
1075 pragma Debug
(Validate_Node_Write
(N
));
1077 New_Node_Debugging_Output
(N
);
1080 procedure Mutate_Nkind
(N
: Node_Id
; Val
: Node_Kind
) is
1082 Mutate_Nkind
(N
, Val
, Old_Size
=> Size_In_Slots_Dynamic
(N
));
1085 Ekind_Offset
: constant Field_Offset
:=
1086 Field_Descriptors
(F_Ekind
).Offset
;
1088 procedure Set_Entity_Kind_Type
is new Set_8_Bit_Field
(Entity_Kind
)
1091 procedure Mutate_Ekind
1092 (N
: Entity_Id
; Val
: Entity_Kind
)
1095 if Ekind
(N
) = Val
then
1099 if Debug_Flag_Underscore_V
then
1100 pragma Debug
(Check_Vanishing_Fields
(N
, Val
));
1103 -- For now, we are allocating all entities with the same size, so we
1104 -- don't need to reallocate slots here.
1106 if Atree_Statistics_Enabled
then
1107 Set_Count
(F_Nkind
) := Set_Count
(F_Ekind
) + 1;
1110 Set_Entity_Kind_Type
(N
, Ekind_Offset
, Val
);
1111 pragma Debug
(Validate_Node_Write
(N
));
1113 New_Node_Debugging_Output
(N
);
1116 -----------------------
1117 -- Allocate_New_Node --
1118 -----------------------
1120 function Allocate_New_Node
(Kind
: Node_Kind
) return Node_Id
is
1122 return Result
: constant Node_Id
:= Alloc_Node_Id
do
1124 Sz
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Kind
);
1125 Sl
: constant Node_Offset
:= Alloc_Slots
(Sz
);
1127 Node_Offsets
.Table
(Result
).Offset
:= Sl
- N_Head
;
1128 Zero_Dynamic_Slots
(Sl
, Sl
+ Sz
- 1);
1129 Zero_Header_Slots
(Result
);
1132 Init_Nkind
(Result
, Kind
);
1134 Orig_Nodes
.Append
(Result
);
1135 Set_Comes_From_Source
(Result
, Comes_From_Source_Default
);
1136 Allocate_List_Tables
(Result
);
1137 Report
(Target
=> Result
, Source
=> Empty
);
1139 end Allocate_New_Node
;
1141 --------------------------
1142 -- Check_Error_Detected --
1143 --------------------------
1145 procedure Check_Error_Detected
is
1147 -- An anomaly has been detected which is assumed to be a consequence of
1148 -- a previous serious error or configurable run time violation. Raise
1149 -- an exception if no such error has been detected.
1151 if Serious_Errors_Detected
= 0
1152 and then Configurable_Run_Time_Violations
= 0
1154 raise Program_Error
;
1156 end Check_Error_Detected
;
1162 procedure Change_Node
(N
: Node_Id
; New_Kind
: Node_Kind
) is
1163 pragma Debug
(Validate_Node_Write
(N
));
1164 pragma Assert
(Nkind
(N
) not in N_Entity
);
1165 pragma Assert
(New_Kind
not in N_Entity
);
1167 Old_Size
: constant Slot_Count
:= Size_In_Slots_Dynamic
(N
);
1168 New_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(New_Kind
);
1170 Save_Sloc
: constant Source_Ptr
:= Sloc
(N
);
1171 Save_In_List
: constant Boolean := In_List
(N
);
1172 Save_CFS
: constant Boolean := Comes_From_Source
(N
);
1173 Save_Posted
: constant Boolean := Error_Posted
(N
);
1174 Save_CA
: constant Boolean := Check_Actuals
(N
);
1175 Save_Is_IGN
: constant Boolean := Is_Ignored_Ghost_Node
(N
);
1176 Save_Link
: constant Union_Id
:= Link
(N
);
1178 Par_Count
: Nat
:= 0;
1181 if Nkind
(N
) in N_Subexpr
then
1182 Par_Count
:= Paren_Count
(N
);
1185 if New_Size
> Old_Size
then
1187 New_Offset
: constant Field_Offset
:= Alloc_Slots
(New_Size
);
1189 pragma Debug
(Zero_Slots
(N
));
1190 Node_Offsets
.Table
(N
).Offset
:= New_Offset
- N_Head
;
1191 Zero_Dynamic_Slots
(New_Offset
, New_Offset
+ New_Size
- 1);
1192 Zero_Header_Slots
(N
);
1199 Init_Nkind
(N
, New_Kind
); -- Not Mutate, because of Zero_Slots above
1201 Set_Sloc
(N
, Save_Sloc
);
1202 Set_In_List
(N
, Save_In_List
);
1203 Set_Comes_From_Source
(N
, Save_CFS
);
1204 Set_Error_Posted
(N
, Save_Posted
);
1205 Set_Check_Actuals
(N
, Save_CA
);
1206 Set_Is_Ignored_Ghost_Node
(N
, Save_Is_IGN
);
1207 Set_Link
(N
, Save_Link
);
1209 if New_Kind
in N_Subexpr
then
1210 Set_Paren_Count
(N
, Par_Count
);
1218 procedure Copy_Dynamic_Slots
1219 (From
, To
: Node_Offset
; Num_Slots
: Slot_Count
)
1221 pragma Assert
(if Num_Slots
/= 0 then From
/= To
);
1223 All_Slots
: Slots
.Table_Type
renames
1224 Slots
.Table
(Slots
.First
.. Slots
.Last
);
1226 Source_Slots
: Slots
.Table_Type
renames
1227 All_Slots
(From
.. From
+ Num_Slots
- 1);
1229 Destination_Slots
: Slots
.Table_Type
renames
1230 All_Slots
(To
.. To
+ Num_Slots
- 1);
1233 Destination_Slots
:= Source_Slots
;
1234 end Copy_Dynamic_Slots
;
1236 procedure Copy_Slots
(Source
, Destination
: Node_Id
) is
1237 pragma Debug
(Validate_Node
(Source
));
1238 pragma Assert
(Source
/= Destination
);
1240 S_Size
: constant Slot_Count
:= Size_In_Slots_Dynamic
(Source
);
1242 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
1243 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
1247 (Off_F
(Source
), Off_F
(Destination
), S_Size
);
1248 All_Node_Offsets
(Destination
).Slots
:= All_Node_Offsets
(Source
).Slots
;
1255 procedure Copy_Node
(Source
, Destination
: Node_Or_Entity_Id
) is
1256 pragma Assert
(Source
/= Destination
);
1258 Save_In_List
: constant Boolean := In_List
(Destination
);
1259 Save_Link
: constant Union_Id
:= Link
(Destination
);
1261 S_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Source
);
1262 D_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Destination
);
1265 New_Node_Debugging_Output
(Source
);
1266 New_Node_Debugging_Output
(Destination
);
1268 -- Currently all entities are allocated the same number of slots.
1269 -- Hopefully that won't always be the case, but if it is, the following
1270 -- is suboptimal if D_Size < S_Size, because in fact the Destination was
1271 -- allocated the max.
1273 -- If Source doesn't fit in Destination, we need to allocate
1275 if D_Size
< S_Size
then
1276 pragma Debug
(Zero_Slots
(Destination
)); -- destroy old slots
1277 Node_Offsets
.Table
(Destination
).Offset
:=
1278 Alloc_Slots
(S_Size
) - N_Head
;
1281 Copy_Slots
(Source
, Destination
);
1283 Set_In_List
(Destination
, Save_In_List
);
1284 Set_Link
(Destination
, Save_Link
);
1285 Set_Paren_Count_Of_Copy
(Target
=> Destination
, Source
=> Source
);
1288 ------------------------
1289 -- Copy_Separate_List --
1290 ------------------------
1292 function Copy_Separate_List
(Source
: List_Id
) return List_Id
is
1293 Result
: constant List_Id
:= New_List
;
1294 Nod
: Node_Id
:= First
(Source
);
1297 while Present
(Nod
) loop
1298 Append
(Copy_Separate_Tree
(Nod
), Result
);
1303 end Copy_Separate_List
;
1305 ------------------------
1306 -- Copy_Separate_Tree --
1307 ------------------------
1309 function Copy_Separate_Tree
(Source
: Node_Id
) return Node_Id
is
1311 pragma Debug
(Validate_Node
(Source
));
1315 function Copy_Entity
(E
: Entity_Id
) return Entity_Id
;
1316 -- Copy Entity, copying only Chars field
1318 function Copy_List
(List
: List_Id
) return List_Id
;
1321 function Possible_Copy
(Field
: Union_Id
) return Union_Id
;
1322 -- Given a field, returns a copy of the node or list if its parent is
1323 -- the current source node, and otherwise returns the input.
1329 function Copy_Entity
(E
: Entity_Id
) return Entity_Id
is
1331 pragma Assert
(Nkind
(E
) in N_Entity
);
1333 return Result
: constant Entity_Id
:= New_Entity
(Nkind
(E
), Sloc
(E
))
1335 Set_Chars
(Result
, Chars
(E
));
1343 function Copy_List
(List
: List_Id
) return List_Id
is
1348 if List
= No_List
then
1355 while Present
(E
) loop
1356 if Is_Entity
(E
) then
1357 Append
(Copy_Entity
(E
), NL
);
1359 Append
(Copy_Separate_Tree
(E
), NL
);
1373 function Possible_Copy
(Field
: Union_Id
) return Union_Id
is
1377 if Field
in Node_Range
then
1378 New_N
:= Union_Id
(Copy_Separate_Tree
(Node_Id
(Field
)));
1380 if Present
(Node_Id
(Field
))
1381 and then Parent
(Node_Id
(Field
)) = Source
1383 Set_Parent
(Node_Id
(New_N
), New_Id
);
1388 elsif Field
in List_Range
then
1389 New_N
:= Union_Id
(Copy_List
(List_Id
(Field
)));
1391 if Parent
(List_Id
(Field
)) = Source
then
1392 Set_Parent
(List_Id
(New_N
), New_Id
);
1402 procedure Walk
is new Walk_Sinfo_Fields_Pairwise
(Possible_Copy
);
1404 -- Start of processing for Copy_Separate_Tree
1407 if Source
<= Empty_Or_Error
then
1410 elsif Is_Entity
(Source
) then
1411 return Copy_Entity
(Source
);
1414 New_Id
:= New_Copy
(Source
);
1416 Walk
(New_Id
, Source
);
1418 -- Explicitly copy the aspect specifications as those do not reside
1421 if Permits_Aspect_Specifications
(Source
)
1422 and then Has_Aspects
(Source
)
1424 Set_Aspect_Specifications
1425 (New_Id
, Copy_List
(Aspect_Specifications
(Source
)));
1428 -- Set Entity field to Empty to ensure that no entity references
1429 -- are shared between the two, if the source is already analyzed.
1431 if Nkind
(New_Id
) in N_Has_Entity
1432 or else Nkind
(New_Id
) = N_Freeze_Entity
1434 Set_Entity
(New_Id
, Empty
);
1437 -- Reset all Etype fields and Analyzed flags, because input tree may
1438 -- have been fully or partially analyzed.
1440 if Nkind
(New_Id
) in N_Has_Etype
then
1441 Set_Etype
(New_Id
, Empty
);
1444 Set_Analyzed
(New_Id
, False);
1446 -- Rather special case, if we have an expanded name, then change
1447 -- it back into a selected component, so that the tree looks the
1448 -- way it did coming out of the parser. This will change back
1449 -- when we analyze the selected component node.
1451 if Nkind
(New_Id
) = N_Expanded_Name
then
1453 -- The following code is a bit kludgy. It would be cleaner to
1454 -- Add an entry Change_Expanded_Name_To_Selected_Component to
1455 -- Sinfo.CN, but that's delicate because Atree is used in the
1456 -- binder, so we don't want to add that dependency.
1457 -- ??? Revisit now that ASIS is no longer using this unit.
1459 -- Consequently we have no choice but to hold our noses and do the
1460 -- change manually. At least we are Atree, so this is at least all
1463 -- Clear the Chars field which is not present in a selected
1464 -- component node, so we don't want a junk value around. Note that
1465 -- we can't just call Set_Chars, because Empty is of the wrong
1466 -- type, and is outside the range of Name_Id.
1468 Reinit_Field_To_Zero
(New_Id
, F_Chars
);
1469 Reinit_Field_To_Zero
(New_Id
, F_Has_Private_View
);
1470 Reinit_Field_To_Zero
(New_Id
, F_Is_Elaboration_Checks_OK_Node
);
1471 Reinit_Field_To_Zero
(New_Id
, F_Is_Elaboration_Warnings_OK_Node
);
1472 Reinit_Field_To_Zero
(New_Id
, F_Is_SPARK_Mode_On_Node
);
1474 -- Change the node type
1476 Mutate_Nkind
(New_Id
, N_Selected_Component
);
1479 -- All done, return copied node
1483 end Copy_Separate_Tree
;
1485 -----------------------
1486 -- Exchange_Entities --
1487 -----------------------
1489 procedure Exchange_Entities
(E1
: Entity_Id
; E2
: Entity_Id
) is
1490 pragma Debug
(Validate_Node_Write
(E1
));
1491 pragma Debug
(Validate_Node_Write
(E2
));
1493 (Is_Entity
(E1
) and then Is_Entity
(E2
)
1494 and then not In_List
(E1
) and then not In_List
(E2
));
1496 Old_E1
: constant Node_Header
:= Node_Offsets
.Table
(E1
);
1499 Node_Offsets
.Table
(E1
) := Node_Offsets
.Table
(E2
);
1500 Node_Offsets
.Table
(E2
) := Old_E1
;
1502 -- That exchange exchanged the parent pointers as well, which is what
1503 -- we want, but we need to patch up the defining identifier pointers
1504 -- in the parent nodes (the child pointers) to match this switch
1505 -- unless for Implicit types entities which have no parent, in which
1506 -- case we don't do anything otherwise we won't be able to revert back
1507 -- to the original situation.
1509 -- Shouldn't this use Is_Itype instead of the Parent test???
1511 if Present
(Parent
(E1
)) and then Present
(Parent
(E2
)) then
1512 Set_Defining_Identifier
(Parent
(E1
), E1
);
1513 Set_Defining_Identifier
(Parent
(E2
), E2
);
1516 New_Node_Debugging_Output
(E1
);
1517 New_Node_Debugging_Output
(E2
);
1518 end Exchange_Entities
;
1524 procedure Extend_Node
(Source
: Node_Id
) is
1525 pragma Assert
(Present
(Source
));
1526 pragma Assert
(not Is_Entity
(Source
));
1528 Old_Kind
: constant Node_Kind
:= Nkind
(Source
);
1529 pragma Assert
(Old_Kind
in N_Direct_Name
);
1530 New_Kind
: constant Node_Kind
:=
1532 when N_Character_Literal
=> N_Defining_Character_Literal
,
1533 when N_Identifier
=> N_Defining_Identifier
,
1534 when N_Operator_Symbol
=> N_Defining_Operator_Symbol
,
1535 when others => N_Unused_At_Start
); -- can't happen
1536 -- The new NKind, which is the appropriate value of N_Entity based on
1537 -- the old Nkind. N_xxx is mapped to N_Defining_xxx.
1538 pragma Assert
(New_Kind
in N_Entity
);
1540 -- Start of processing for Extend_Node
1543 Set_Check_Actuals
(Source
, False);
1544 Mutate_Nkind
(Source
, New_Kind
);
1545 Report
(Target
=> Source
, Source
=> Source
);
1552 procedure Fix_Parents
(Ref_Node
, Fix_Node
: Node_Id
) is
1553 pragma Assert
(Nkind
(Ref_Node
) = Nkind
(Fix_Node
));
1555 procedure Fix_Parent
(Field
: Union_Id
);
1556 -- Fix up one parent pointer. Field is checked to see if it points to
1557 -- a node, list, or element list that has a parent that points to
1558 -- Ref_Node. If so, the parent is reset to point to Fix_Node.
1564 procedure Fix_Parent
(Field
: Union_Id
) is
1566 -- Fix parent of node that is referenced by Field. Note that we must
1567 -- exclude the case where the node is a member of a list, because in
1568 -- this case the parent is the parent of the list.
1570 if Field
in Node_Range
1571 and then Present
(Node_Id
(Field
))
1572 and then not In_List
(Node_Id
(Field
))
1573 and then Parent
(Node_Id
(Field
)) = Ref_Node
1575 Set_Parent
(Node_Id
(Field
), Fix_Node
);
1577 -- Fix parent of list that is referenced by Field
1579 elsif Field
in List_Range
1580 and then Present
(List_Id
(Field
))
1581 and then Parent
(List_Id
(Field
)) = Ref_Node
1583 Set_Parent
(List_Id
(Field
), Fix_Node
);
1587 Fields
: Node_Field_Array
renames
1588 Node_Field_Table
(Nkind
(Fix_Node
)).all;
1590 -- Start of processing for Fix_Parents
1593 for J
in Fields
'Range loop
1595 Desc
: Field_Descriptor
renames Field_Descriptors
(Fields
(J
));
1597 if Desc
.Kind
in Node_Id_Field | List_Id_Field
then
1598 Fix_Parent
(Get_Node_Field_Union
(Fix_Node
, Desc
.Offset
));
1604 -----------------------------------
1605 -- Get_Comes_From_Source_Default --
1606 -----------------------------------
1608 function Get_Comes_From_Source_Default
return Boolean is
1610 return Comes_From_Source_Default
;
1611 end Get_Comes_From_Source_Default
;
1617 function Is_Entity
(N
: Node_Or_Entity_Id
) return Boolean is
1619 return Nkind
(N
) in N_Entity
;
1626 procedure Initialize
is
1628 pragma Warnings
(Off
, Dummy
);
1631 -- Allocate Empty node
1633 Dummy
:= New_Node
(N_Empty
, No_Location
);
1634 Set_Chars
(Empty
, No_Name
);
1635 pragma Assert
(Dummy
= Empty
);
1637 -- Allocate Error node, and set Error_Posted, since we certainly
1638 -- only generate an Error node if we do post some kind of error.
1640 Dummy
:= New_Node
(N_Error
, No_Location
);
1641 Set_Chars
(Error
, Error_Name
);
1642 Set_Error_Posted
(Error
, True);
1643 pragma Assert
(Dummy
= Error
);
1646 --------------------------
1647 -- Is_Rewrite_Insertion --
1648 --------------------------
1650 function Is_Rewrite_Insertion
(Node
: Node_Id
) return Boolean is
1652 return Rewrite_Ins
(Node
);
1653 end Is_Rewrite_Insertion
;
1655 -----------------------------
1656 -- Is_Rewrite_Substitution --
1657 -----------------------------
1659 function Is_Rewrite_Substitution
(Node
: Node_Id
) return Boolean is
1661 return Orig_Nodes
.Table
(Node
) /= Node
;
1662 end Is_Rewrite_Substitution
;
1668 function Last_Node_Id
return Node_Id
is
1670 return Node_Offsets
.Last
;
1679 Orig_Nodes
.Locked
:= True;
1686 procedure Lock_Nodes
is
1688 pragma Assert
(not Locked
);
1692 -------------------------
1693 -- Mark_New_Ghost_Node --
1694 -------------------------
1696 procedure Mark_New_Ghost_Node
(N
: Node_Or_Entity_Id
) is
1698 pragma Debug
(Validate_Node_Write
(N
));
1700 -- The Ghost node is created within a Ghost region
1702 if Ghost_Mode
= Check
then
1703 if Nkind
(N
) in N_Entity
then
1704 Set_Is_Checked_Ghost_Entity
(N
);
1707 elsif Ghost_Mode
= Ignore
then
1708 if Nkind
(N
) in N_Entity
then
1709 Set_Is_Ignored_Ghost_Entity
(N
);
1712 Set_Is_Ignored_Ghost_Node
(N
);
1714 -- Record the ignored Ghost node or entity in order to eliminate it
1715 -- from the tree later.
1717 if Ignored_Ghost_Recording_Proc
/= null then
1718 Ignored_Ghost_Recording_Proc
.all (N
);
1721 end Mark_New_Ghost_Node
;
1723 ----------------------------
1724 -- Mark_Rewrite_Insertion --
1725 ----------------------------
1727 procedure Mark_Rewrite_Insertion
(New_Node
: Node_Id
) is
1729 Set_Rewrite_Ins
(New_Node
);
1730 end Mark_Rewrite_Insertion
;
1736 function New_Copy
(Source
: Node_Id
) return Node_Id
is
1737 pragma Debug
(Validate_Node
(Source
));
1738 S_Size
: constant Slot_Count
:= Size_In_Slots_To_Alloc
(Source
);
1740 if Source
<= Empty_Or_Error
then
1744 return New_Id
: constant Node_Id
:= Alloc_Node_Id
do
1745 Node_Offsets
.Table
(New_Id
).Offset
:=
1746 Alloc_Slots
(S_Size
) - N_Head
;
1747 Orig_Nodes
.Append
(New_Id
);
1748 Copy_Slots
(Source
, New_Id
);
1750 Set_Check_Actuals
(New_Id
, False);
1751 Set_Paren_Count_Of_Copy
(Target
=> New_Id
, Source
=> Source
);
1753 Allocate_List_Tables
(New_Id
);
1754 Report
(Target
=> New_Id
, Source
=> Source
);
1756 Set_In_List
(New_Id
, False);
1757 Set_Link
(New_Id
, Empty_List_Or_Node
);
1759 -- If the original is marked as a rewrite insertion, then unmark the
1760 -- copy, since we inserted the original, not the copy.
1762 Set_Rewrite_Ins
(New_Id
, False);
1764 -- Clear Is_Overloaded since we cannot have semantic interpretations
1765 -- of this new node.
1767 if Nkind
(Source
) in N_Subexpr
then
1768 Set_Is_Overloaded
(New_Id
, False);
1771 -- Always clear Has_Aspects, the caller must take care of copying
1772 -- aspects if this is required for the particular situation.
1774 Set_Has_Aspects
(New_Id
, False);
1776 -- Mark the copy as Ghost depending on the current Ghost region
1778 if Nkind
(New_Id
) in N_Entity
then
1779 Set_Is_Checked_Ghost_Entity
(New_Id
, False);
1780 Set_Is_Ignored_Ghost_Entity
(New_Id
, False);
1783 Mark_New_Ghost_Node
(New_Id
);
1785 New_Node_Debugging_Output
(New_Id
);
1787 pragma Assert
(New_Id
/= Source
);
1796 (New_Node_Kind
: Node_Kind
;
1797 New_Sloc
: Source_Ptr
) return Entity_Id
1799 pragma Assert
(New_Node_Kind
in N_Entity
);
1800 New_Id
: constant Entity_Id
:= Allocate_New_Node
(New_Node_Kind
);
1801 pragma Assert
(Original_Node
(Node_Offsets
.Last
) = Node_Offsets
.Last
);
1803 -- If this is a node with a real location and we are generating
1804 -- source nodes, then reset Current_Error_Node. This is useful
1805 -- if we bomb during parsing to get a error location for the bomb.
1807 if New_Sloc
> No_Location
and then Comes_From_Source_Default
then
1808 Current_Error_Node
:= New_Id
;
1811 Set_Sloc
(New_Id
, New_Sloc
);
1813 -- Mark the new entity as Ghost depending on the current Ghost region
1815 Mark_New_Ghost_Node
(New_Id
);
1817 New_Node_Debugging_Output
(New_Id
);
1827 (New_Node_Kind
: Node_Kind
;
1828 New_Sloc
: Source_Ptr
) return Node_Id
1830 pragma Assert
(New_Node_Kind
not in N_Entity
);
1831 New_Id
: constant Node_Id
:= Allocate_New_Node
(New_Node_Kind
);
1832 pragma Assert
(Original_Node
(Node_Offsets
.Last
) = Node_Offsets
.Last
);
1834 Set_Sloc
(New_Id
, New_Sloc
);
1836 -- If this is a node with a real location and we are generating source
1837 -- nodes, then reset Current_Error_Node. This is useful if we bomb
1838 -- during parsing to get an error location for the bomb.
1840 if Comes_From_Source_Default
and then New_Sloc
> No_Location
then
1841 Current_Error_Node
:= New_Id
;
1844 -- Mark the new node as Ghost depending on the current Ghost region
1846 Mark_New_Ghost_Node
(New_Id
);
1848 New_Node_Debugging_Output
(New_Id
);
1857 function No
(N
: Node_Id
) return Boolean is
1866 function Node_Offsets_Address
return System
.Address
is
1868 return Node_Offsets
.Table
(First_Node_Id
)'Address;
1869 end Node_Offsets_Address
;
1871 function Slots_Address
return System
.Address
is
1872 Slot_Byte_Size
: constant := 4;
1873 pragma Assert
(Slot_Byte_Size
* 8 = Slot
'Size);
1874 Extra
: constant := Slots_Low_Bound
* Slot_Byte_Size
;
1875 -- Slots does not start at 0, so we need to subtract off the extra
1876 -- amount. We are returning Slots.Table (0)'Address, except that
1877 -- that component does not exist.
1878 use System
.Storage_Elements
;
1880 return Slots
.Table
(Slots_Low_Bound
)'Address - Extra
;
1883 -----------------------------------
1884 -- Approx_Num_Nodes_And_Entities --
1885 -----------------------------------
1887 function Approx_Num_Nodes_And_Entities
return Nat
is
1889 return Nat
(Node_Offsets
.Last
- First_Node_Id
);
1890 end Approx_Num_Nodes_And_Entities
;
1896 function Off_0
(N
: Node_Id
) return Node_Offset
'Base is
1897 pragma Debug
(Validate_Node
(N
));
1899 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
1900 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
1902 return All_Node_Offsets
(N
).Offset
;
1909 function Off_F
(N
: Node_Id
) return Node_Offset
is
1911 return Off_0
(N
) + N_Head
;
1918 function Off_L
(N
: Node_Id
) return Node_Offset
is
1919 pragma Debug
(Validate_Node
(N
));
1921 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
1922 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
1924 return All_Node_Offsets
(N
).Offset
+ Size_In_Slots
(N
) - 1;
1931 function Original_Node
(Node
: Node_Id
) return Node_Id
is
1933 pragma Debug
(Validate_Node
(Node
));
1934 if Atree_Statistics_Enabled
then
1935 Get_Original_Node_Count
:= Get_Original_Node_Count
+ 1;
1938 return Orig_Nodes
.Table
(Node
);
1945 function Paren_Count
(N
: Node_Id
) return Nat
is
1946 pragma Debug
(Validate_Node
(N
));
1948 C
: constant Small_Paren_Count_Type
:= Small_Paren_Count
(N
);
1951 -- Value of 0,1,2 returned as is
1956 -- Value of 3 means we search the table, and we must find an entry
1959 for J
in Paren_Counts
.First
.. Paren_Counts
.Last
loop
1960 if N
= Paren_Counts
.Table
(J
).Nod
then
1961 return Paren_Counts
.Table
(J
).Count
;
1965 raise Program_Error
;
1969 function Node_Parent
(N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
is
1971 pragma Assert
(Present
(N
));
1973 if Is_List_Member
(N
) then
1974 return Parent
(List_Containing
(N
));
1976 return Node_Or_Entity_Id
(Link
(N
));
1984 function Present
(N
: Node_Id
) return Boolean is
1989 --------------------------------
1990 -- Preserve_Comes_From_Source --
1991 --------------------------------
1993 procedure Preserve_Comes_From_Source
(NewN
, OldN
: Node_Id
) is
1995 Set_Comes_From_Source
(NewN
, Comes_From_Source
(OldN
));
1996 end Preserve_Comes_From_Source
;
2002 function Relocate_Node
(Source
: Node_Id
) return Node_Id
is
2010 New_Node
:= New_Copy
(Source
);
2011 Fix_Parents
(Ref_Node
=> Source
, Fix_Node
=> New_Node
);
2013 -- We now set the parent of the new node to be the same as the parent of
2014 -- the source. Almost always this parent will be replaced by a new value
2015 -- when the relocated node is reattached to the tree, but by doing it
2016 -- now, we ensure that this node is not even temporarily disconnected
2017 -- from the tree. Note that this does not happen free, because in the
2018 -- list case, the parent does not get set.
2020 Set_Parent
(New_Node
, Parent
(Source
));
2022 -- If the node being relocated was a rewriting of some original node,
2023 -- then the relocated node has the same original node.
2025 if Is_Rewrite_Substitution
(Source
) then
2026 Set_Original_Node
(New_Node
, Original_Node
(Source
));
2029 -- If we're relocating a subprogram call and we're doing
2030 -- unnesting, be sure we make a new copy of any parameter associations
2031 -- so that we don't share them.
2033 if Nkind
(Source
) in N_Subprogram_Call
2034 and then Opt
.Unnest_Subprogram_Mode
2035 and then Present
(Parameter_Associations
(Source
))
2038 New_Assoc
: constant List_Id
:= Parameter_Associations
(Source
);
2040 Set_Parent
(New_Assoc
, New_Node
);
2041 Set_Parameter_Associations
(New_Node
, New_Assoc
);
2052 procedure Replace
(Old_Node
, New_Node
: Node_Id
) is
2053 Old_Post
: constant Boolean := Error_Posted
(Old_Node
);
2054 Old_HasA
: constant Boolean := Has_Aspects
(Old_Node
);
2055 Old_CFS
: constant Boolean := Comes_From_Source
(Old_Node
);
2057 procedure Destroy_New_Node
;
2058 -- Overwrite New_Node data with junk, for debugging purposes
2060 procedure Destroy_New_Node
is
2062 Zero_Slots
(New_Node
);
2063 Node_Offsets
.Table
(New_Node
).Offset
:= Field_Offset
'Base'Last;
2064 end Destroy_New_Node;
2067 New_Node_Debugging_Output (Old_Node);
2068 New_Node_Debugging_Output (New_Node);
2071 (not Is_Entity (Old_Node)
2072 and not Is_Entity (New_Node)
2073 and not In_List (New_Node)
2074 and Old_Node /= New_Node);
2076 -- Do copy, preserving link and in list status and required flags
2078 Copy_Node (Source => New_Node, Destination => Old_Node);
2079 Set_Comes_From_Source (Old_Node, Old_CFS);
2080 Set_Error_Posted (Old_Node, Old_Post);
2081 Set_Has_Aspects (Old_Node, Old_HasA);
2083 -- Fix parents of substituted node, since it has changed identity
2085 Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);
2087 pragma Debug (Destroy_New_Node);
2089 -- Since we are doing a replace, we assume that the original node
2090 -- is intended to become the new replaced node. The call would be
2091 -- to Rewrite if there were an intention to save the original node.
2093 Set_Original_Node (Old_Node, Old_Node);
2095 -- Invoke the reporting procedure (if available)
2097 if Reporting_Proc /= null then
2098 Reporting_Proc.all (Target => Old_Node, Source => New_Node);
2106 procedure Report (Target, Source : Node_Id) is
2108 if Reporting_Proc /= null then
2109 Reporting_Proc.all (Target, Source);
2117 procedure Rewrite (Old_Node, New_Node : Node_Id) is
2118 Old_CA : constant Boolean := Check_Actuals (Old_Node);
2119 Old_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Old_Node);
2120 Old_Error_Posted : constant Boolean :=
2121 Error_Posted (Old_Node);
2122 Old_Has_Aspects : constant Boolean :=
2123 Has_Aspects (Old_Node);
2125 Old_Must_Not_Freeze : constant Boolean :=
2126 (if Nkind (Old_Node) in N_Subexpr then Must_Not_Freeze (Old_Node)
2128 Old_Paren_Count : constant Nat :=
2129 (if Nkind (Old_Node) in N_Subexpr then Paren_Count (Old_Node) else 0);
2130 -- These fields are preserved in the new node only if the new node and
2131 -- the old node are both subexpression nodes. We might be changing Nkind
2132 -- (Old_Node) from not N_Subexpr to N_Subexpr, so we need a value
2133 -- (False/0) even if Old_Noed is not a N_Subexpr.
2135 -- Note: it is a violation of abstraction levels for Must_Not_Freeze
2136 -- to be referenced like this. ???
2141 New_Node_Debugging_Output (Old_Node);
2142 New_Node_Debugging_Output (New_Node);
2145 (not Is_Entity (Old_Node)
2146 and not Is_Entity (New_Node)
2147 and not In_List (New_Node));
2149 -- Allocate a new node, to be used to preserve the original contents
2150 -- of the Old_Node, for possible later retrival by Original_Node and
2151 -- make an entry in the Orig_Nodes table. This is only done if we have
2152 -- not already rewritten the node, as indicated by an Orig_Nodes entry
2153 -- that does not reference the Old_Node.
2155 if not Is_Rewrite_Substitution (Old_Node) then
2156 Sav_Node := New_Copy (Old_Node);
2157 Set_Original_Node (Sav_Node, Sav_Node);
2158 Set_Original_Node (Old_Node, Sav_Node);
2160 -- Both the old and new copies of the node will share the same list
2161 -- of aspect specifications if aspect specifications are present.
2162 -- Restore the parent link of the aspect list to the old node, which
2163 -- is the one linked in the tree.
2165 if Old_Has_Aspects then
2167 Aspects : constant List_Id := Aspect_Specifications (Old_Node);
2169 Set_Aspect_Specifications (Sav_Node, Aspects);
2170 Set_Parent (Aspects, Old_Node);
2175 -- Copy substitute node into place, preserving old fields as required
2177 Copy_Node (Source => New_Node, Destination => Old_Node);
2178 Set_Error_Posted (Old_Node, Old_Error_Posted);
2179 Set_Has_Aspects (Old_Node, Old_Has_Aspects);
2181 Set_Check_Actuals (Old_Node, Old_CA);
2182 Set_Is_Ignored_Ghost_Node (Old_Node, Old_Is_IGN);
2184 if Nkind (New_Node) in N_Subexpr then
2185 Set_Paren_Count (Old_Node, Old_Paren_Count);
2186 Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze);
2189 Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);
2191 -- Invoke the reporting procedure (if available)
2193 if Reporting_Proc /= null then
2194 Reporting_Proc.all (Target => Old_Node, Source => New_Node);
2197 -- Invoke the rewriting procedure (if available)
2199 if Rewriting_Proc /= null then
2200 Rewriting_Proc.all (Target => Old_Node, Source => New_Node);
2204 -----------------------------------
2205 -- Set_Comes_From_Source_Default --
2206 -----------------------------------
2208 procedure Set_Comes_From_Source_Default (Default : Boolean) is
2210 Comes_From_Source_Default := Default;
2211 end Set_Comes_From_Source_Default;
2213 --------------------------------------
2214 -- Set_Ignored_Ghost_Recording_Proc --
2215 --------------------------------------
2217 procedure Set_Ignored_Ghost_Recording_Proc
2218 (Proc : Ignored_Ghost_Record_Proc)
2221 pragma Assert (Ignored_Ghost_Recording_Proc = null);
2222 Ignored_Ghost_Recording_Proc := Proc;
2223 end Set_Ignored_Ghost_Recording_Proc;
2225 -----------------------
2226 -- Set_Original_Node --
2227 -----------------------
2229 procedure Set_Original_Node (N : Node_Id; Val : Node_Id) is
2231 pragma Debug (Validate_Node_Write (N));
2232 if Atree_Statistics_Enabled then
2233 Set_Original_Node_Count := Set_Original_Node_Count + 1;
2236 Orig_Nodes.Table (N) := Val;
2237 end Set_Original_Node;
2239 ---------------------
2240 -- Set_Paren_Count --
2241 ---------------------
2243 procedure Set_Paren_Count (N : Node_Id; Val : Nat) is
2245 pragma Debug (Validate_Node_Write (N));
2246 pragma Assert (Nkind (N) in N_Subexpr);
2248 -- Value of 0,1,2 stored as is
2251 Set_Small_Paren_Count (N, Val);
2253 -- Value of 3 or greater stores 3 in node and makes table entry
2256 Set_Small_Paren_Count (N, 3);
2258 -- Search for existing table entry
2260 for J in Paren_Counts.First .. Paren_Counts.Last loop
2261 if N = Paren_Counts.Table (J).Nod then
2262 Paren_Counts.Table (J).Count := Val;
2267 -- No existing table entry; make a new one
2269 Paren_Counts.Append ((Nod => N, Count => Val));
2271 end Set_Paren_Count;
2273 -----------------------------
2274 -- Set_Paren_Count_Of_Copy --
2275 -----------------------------
2277 procedure Set_Paren_Count_Of_Copy (Target, Source : Node_Id) is
2279 -- We already copied the Small_Paren_Count. We need to update the
2280 -- Paren_Counts table only if greater than 2.
2282 if Nkind (Source) in N_Subexpr
2283 and then Small_Paren_Count (Source) = 3
2285 Set_Paren_Count (Target, Paren_Count (Source));
2288 pragma Assert (Paren_Count (Target) = Paren_Count (Source));
2289 end Set_Paren_Count_Of_Copy;
2295 procedure Set_Node_Parent (N : Node_Or_Entity_Id; Val : Node_Or_Entity_Id) is
2297 pragma Assert (Present (N));
2298 pragma Assert (not In_List (N));
2299 Set_Link (N, Union_Id (Val));
2300 end Set_Node_Parent;
2302 ------------------------
2303 -- Set_Reporting_Proc --
2304 ------------------------
2306 procedure Set_Reporting_Proc (Proc : Report_Proc) is
2308 pragma Assert (Reporting_Proc = null);
2309 Reporting_Proc := Proc;
2310 end Set_Reporting_Proc;
2312 ------------------------
2313 -- Set_Rewriting_Proc --
2314 ------------------------
2316 procedure Set_Rewriting_Proc (Proc : Rewrite_Proc) is
2318 pragma Assert (Rewriting_Proc = null);
2319 Rewriting_Proc := Proc;
2320 end Set_Rewriting_Proc;
2322 ----------------------------
2323 -- Size_In_Slots_To_Alloc --
2324 ----------------------------
2326 function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count is
2329 (if Kind in N_Entity then Einfo.Entities.Max_Entity_Size
2330 else Sinfo.Nodes.Size (Kind)) - N_Head;
2331 -- Unfortunately, we don't know the Entity_Kind, so we have to use the
2333 end Size_In_Slots_To_Alloc;
2335 function Size_In_Slots_To_Alloc
2336 (N : Node_Or_Entity_Id) return Slot_Count is
2338 return Size_In_Slots_To_Alloc (Nkind (N));
2339 end Size_In_Slots_To_Alloc;
2345 function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count is
2347 pragma Assert (Nkind (N) /= N_Unused_At_Start);
2349 (if Nkind (N) in N_Entity then Einfo.Entities.Max_Entity_Size
2350 else Sinfo.Nodes.Size (Nkind (N)));
2353 ---------------------------
2354 -- Size_In_Slots_Dynamic --
2355 ---------------------------
2357 function Size_In_Slots_Dynamic (N : Node_Or_Entity_Id) return Slot_Count is
2359 return Size_In_Slots (N) - N_Head;
2360 end Size_In_Slots_Dynamic;
2362 -----------------------------------
2363 -- Internal_Traverse_With_Parent --
2364 -----------------------------------
2366 function Internal_Traverse_With_Parent
2367 (Node : Node_Id) return Traverse_Final_Result
2369 Tail_Recursion_Counter : Natural := 0;
2371 procedure Pop_Parents;
2372 -- Pop enclosing nodes of tail recursion plus the current parent.
2374 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result;
2375 -- Fld is one of the Traversed fields of Nod, which is necessarily a
2376 -- Node_Id or List_Id. It is traversed, and the result is the result of
2383 procedure Pop_Parents is
2385 -- Pop the enclosing nodes of the tail recursion
2387 for J in 1 .. Tail_Recursion_Counter loop
2388 Parents_Stack.Decrement_Last;
2391 -- Pop the current node
2393 pragma Assert (Parents_Stack.Table (Parents_Stack.Last) = Node);
2394 Parents_Stack.Decrement_Last;
2397 --------------------
2398 -- Traverse_Field --
2399 --------------------
2401 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result is
2403 if Fld /= Union_Id (Empty) then
2405 -- Descendant is a node
2407 if Fld in Node_Range then
2408 return Internal_Traverse_With_Parent (Node_Id (Fld));
2410 -- Descendant is a list
2412 elsif Fld in List_Range then
2414 Elmt : Node_Id := First (List_Id (Fld));
2416 while Present (Elmt) loop
2417 if Internal_Traverse_With_Parent (Elmt) = Abandon then
2426 raise Program_Error;
2435 Parent_Node : Node_Id := Parents_Stack.Table (Parents_Stack.Last);
2436 Cur_Node : Node_Id := Node;
2438 -- Start of processing for Internal_Traverse_With_Parent
2441 -- If the last field is a node, we eliminate the tail recursion by
2442 -- jumping back to this label. This is because concatenations are
2443 -- sometimes deeply nested, as in X1&X2&...&Xn. Gen_IL ensures that the
2444 -- Left_Opnd field of N_Op_Concat comes last in Traversed_Fields, so the
2445 -- tail recursion is eliminated in that case. This trick prevents us
2446 -- from running out of stack memory in that case. We don't bother
2447 -- eliminating the tail recursion if the last field is a list.
2451 Parents_Stack.Append (Cur_Node);
2453 case Process (Parent_Node, Cur_Node) is
2466 Cur_Node := Original_Node (Cur_Node);
2469 -- Check for empty Traversed_Fields before entering loop below, so the
2470 -- tail recursive step won't go past the end.
2473 Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First;
2474 Offsets : Traversed_Offset_Array renames
2475 Traversed_Fields (Nkind (Cur_Node));
2478 if Offsets (Traversed_Offset_Array'First) /= No_Field_Offset then
2479 while Offsets (Cur_Field + 1) /= No_Field_Offset loop
2481 F : constant Union_Id :=
2482 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
2485 if Traverse_Field (F) = Abandon then
2491 Cur_Field := Cur_Field + 1;
2495 F : constant Union_Id :=
2496 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
2499 if F not in Node_Range then
2500 if Traverse_Field (F) = Abandon then
2505 elsif F /= Empty_List_Or_Node then
2506 -- Here is the tail recursion step, we reset Cur_Node and
2507 -- jump back to the start of the procedure, which has the
2508 -- same semantic effect as a call.
2510 Tail_Recursion_Counter := Tail_Recursion_Counter + 1;
2511 Parent_Node := Cur_Node;
2512 Cur_Node := Node_Id (F);
2521 end Internal_Traverse_With_Parent;
2527 function Traverse_Func (Node : Node_Id) return Traverse_Final_Result is
2528 pragma Debug (Validate_Node (Node));
2530 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result;
2531 -- Fld is one of the Traversed fields of Nod, which is necessarily a
2532 -- Node_Id or List_Id. It is traversed, and the result is the result of
2535 --------------------
2536 -- Traverse_Field --
2537 --------------------
2539 function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result is
2541 if Fld /= Union_Id (Empty) then
2543 -- Descendant is a node
2545 if Fld in Node_Range then
2546 return Traverse_Func (Node_Id (Fld));
2548 -- Descendant is a list
2550 elsif Fld in List_Range then
2552 Elmt : Node_Id := First (List_Id (Fld));
2554 while Present (Elmt) loop
2555 if Traverse_Func (Elmt) = Abandon then
2564 raise Program_Error;
2571 Cur_Node : Node_Id := Node;
2573 -- Start of processing for Traverse_Func
2576 -- If the last field is a node, we eliminate the tail recursion by
2577 -- jumping back to this label. This is because concatenations are
2578 -- sometimes deeply nested, as in X1&X2&...&Xn. Gen_IL ensures that the
2579 -- Left_Opnd field of N_Op_Concat comes last in Traversed_Fields, so the
2580 -- tail recursion is eliminated in that case. This trick prevents us
2581 -- from running out of stack memory in that case. We don't bother
2582 -- eliminating the tail recursion if the last field is a list.
2584 -- (To check, look in the body of Sinfo.Nodes, search for the Left_Opnd
2585 -- getter, and note the offset of Left_Opnd. Then look in the spec of
2586 -- Sinfo.Nodes, look at the Traversed_Fields table, search for the
2587 -- N_Op_Concat component. The offset of Left_Opnd should be the last
2588 -- component before the No_Field_Offset sentinels.)
2592 case Process (Cur_Node) is
2603 Cur_Node := Original_Node (Cur_Node);
2606 -- Check for empty Traversed_Fields before entering loop below, so the
2607 -- tail recursive step won't go past the end.
2610 Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First;
2611 Offsets : Traversed_Offset_Array renames
2612 Traversed_Fields (Nkind (Cur_Node));
2615 if Offsets (Traversed_Offset_Array'First) /= No_Field_Offset then
2616 while Offsets (Cur_Field + 1) /= No_Field_Offset loop
2618 F : constant Union_Id :=
2619 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
2622 if Traverse_Field (F) = Abandon then
2627 Cur_Field := Cur_Field + 1;
2631 F : constant Union_Id :=
2632 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));
2635 if F not in Node_Range then
2636 if Traverse_Field (F) = Abandon then
2640 elsif F /= Empty_List_Or_Node then
2641 -- Here is the tail recursion step, we reset Cur_Node and
2642 -- jump back to the start of the procedure, which has the
2643 -- same semantic effect as a call.
2645 Cur_Node := Node_Id (F);
2655 -------------------------------
2656 -- Traverse_Func_With_Parent --
2657 -------------------------------
2659 function Traverse_Func_With_Parent
2660 (Node : Node_Id) return Traverse_Final_Result
2662 function Traverse is new Internal_Traverse_With_Parent (Process);
2663 Result : Traverse_Final_Result;
2665 -- Ensure that the Parents stack is not currently in use; required since
2666 -- it is global and hence a tree traversal with parents must be finished
2667 -- before the next tree traversal with parents starts.
2669 pragma Assert (Parents_Stack.Last = 0);
2670 Parents_Stack.Set_Last (0);
2672 Parents_Stack.Append (Parent (Node));
2673 Result := Traverse (Node);
2674 Parents_Stack.Decrement_Last;
2676 pragma Assert (Parents_Stack.Last = 0);
2679 end Traverse_Func_With_Parent;
2685 procedure Traverse_Proc (Node : Node_Id) is
2686 function Traverse is new Traverse_Func (Process);
2687 Discard : Traverse_Final_Result;
2688 pragma Warnings (Off, Discard);
2690 Discard := Traverse (Node);
2693 -------------------------------
2694 -- Traverse_Proc_With_Parent --
2695 -------------------------------
2697 procedure Traverse_Proc_With_Parent (Node : Node_Id) is
2698 function Traverse is new Traverse_Func_With_Parent (Process);
2699 Discard : Traverse_Final_Result;
2700 pragma Warnings (Off, Discard);
2702 Discard := Traverse (Node);
2703 end Traverse_Proc_With_Parent;
2711 Orig_Nodes.Locked := False;
2718 procedure Unlock_Nodes is
2720 pragma Assert (Locked);
2728 procedure Zero_Dynamic_Slots (First, Last : Node_Offset'Base) is
2730 Slots.Table (First .. Last) := (others => 0);
2731 end Zero_Dynamic_Slots;
2733 procedure Zero_Header_Slots (N : Node_Or_Entity_Id) is
2734 All_Node_Offsets : Node_Offsets.Table_Type renames
2735 Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
2737 All_Node_Offsets (N).Slots := (others => 0);
2738 end Zero_Header_Slots;
2740 procedure Zero_Slots (N : Node_Or_Entity_Id) is
2742 Zero_Dynamic_Slots (Off_F (N), Off_L (N));
2743 Zero_Header_Slots (N);
2746 ----------------------
2747 -- Print_Statistics --
2748 ----------------------
2750 procedure Print_Node_Statistics;
2751 procedure Print_Field_Statistics;
2752 -- Helpers for Print_Statistics
2754 procedure Write_Ratio (X : Nat_64; Y : Pos_64);
2755 -- Write the value of (X/Y) without using 'Image
(approximately
)
2757 procedure Write_Ratio
(X
: Nat_64
; Y
: Pos_64
) is
2758 pragma Assert
(X
<= Y
);
2759 Ratio
: constant Nat
:= Nat
((Long_Float (X
) / Long_Float (Y
)) * 1000.0);
2764 Write_Str
("0.000");
2765 elsif Ratio
in 1 .. 9 then
2768 elsif Ratio
in 10 .. 99 then
2771 elsif Ratio
in 100 .. 999 then
2775 Write_Int
(Ratio
/ 1000);
2781 procedure Print_Node_Statistics
is
2782 subtype Count
is Nat_64
;
2783 Node_Counts
: array (Node_Kind
) of Count
:= (others => 0);
2784 Entity_Counts
: array (Entity_Kind
) of Count
:= (others => 0);
2786 All_Node_Offsets
: Node_Offsets
.Table_Type
renames
2787 Node_Offsets
.Table
(Node_Offsets
.First
.. Node_Offsets
.Last
);
2789 Write_Int
(Int
(Node_Offsets
.Last
));
2790 Write_Line
(" nodes (including entities)");
2791 Write_Int
(Int
(Slots
.Last
));
2792 Write_Line
(" non-header slots");
2794 for N
in All_Node_Offsets
'Range loop
2796 K
: constant Node_Kind
:= Nkind
(N
);
2799 Node_Counts
(K
) := Node_Counts
(K
) + 1;
2801 if K
in N_Entity
then
2802 Entity_Counts
(Ekind
(N
)) := Entity_Counts
(Ekind
(N
)) + 1;
2807 for K
in Node_Kind
loop
2809 Count
: constant Nat_64
:= Node_Counts
(K
);
2811 Write_Int_64
(Count
);
2812 Write_Ratio
(Count
, Int_64
(Node_Offsets
.Last
));
2814 Write_Str
(Node_Kind
'Image (K
));
2816 Write_Int
(Int
(Sinfo
.Nodes
.Size
(K
)));
2817 Write_Str
(" slots");
2822 for K
in Entity_Kind
loop
2824 Count
: constant Nat_64
:= Entity_Counts
(K
);
2826 Write_Int_64
(Count
);
2827 Write_Ratio
(Count
, Int_64
(Node_Offsets
.Last
));
2829 Write_Str
(Entity_Kind
'Image (K
));
2831 Write_Int
(Int
(Einfo
.Entities
.Size
(K
)));
2832 Write_Str
(" slots");
2836 end Print_Node_Statistics
;
2838 procedure Print_Field_Statistics
is
2839 Total
, G_Total
, S_Total
: Call_Count
:= 0;
2841 Write_Int_64
(Get_Original_Node_Count
);
2843 Write_Int_64
(Set_Original_Node_Count
);
2845 Write_Line
(" Original_Node_Count getter and setter calls");
2848 Write_Line
("Frequency of field getter and setter calls:");
2850 for Field
in Node_Or_Entity_Field
loop
2851 G_Total
:= G_Total
+ Get_Count
(Field
);
2852 S_Total
:= S_Total
+ Set_Count
(Field
);
2853 Total
:= G_Total
+ S_Total
;
2856 -- This assertion helps CodePeer understand that Total cannot be 0 (this
2857 -- is true because GNAT does not attempt to compile empty files).
2858 pragma Assert
(Total
> 0);
2860 Write_Int_64
(Total
);
2861 Write_Str
(" (100%) = ");
2862 Write_Int_64
(G_Total
);
2864 Write_Int_64
(S_Total
);
2865 Write_Line
(" total getter and setter calls");
2867 for Field
in Node_Or_Entity_Field
loop
2869 G
: constant Call_Count
:= Get_Count
(Field
);
2870 S
: constant Call_Count
:= Set_Count
(Field
);
2871 GS
: constant Call_Count
:= G
+ S
;
2873 Desc
: Field_Descriptor
renames Field_Descriptors
(Field
);
2874 Slot
: constant Field_Offset
:=
2875 (Field_Size
(Desc
.Kind
) * Desc
.Offset
) / Slot_Size
;
2879 Write_Ratio
(GS
, Total
);
2885 Write_Str
(Node_Or_Entity_Field
'Image (Field
));
2886 Write_Str
(" in slot ");
2887 Write_Int
(Int
(Slot
));
2888 Write_Str
(" size ");
2889 Write_Int
(Int
(Field_Size
(Desc
.Kind
)));
2893 end Print_Field_Statistics
;
2895 procedure Print_Statistics
is
2899 Print_Node_Statistics
;
2900 Print_Field_Statistics
;
2901 end Print_Statistics
;