]>
Commit | Line | Data |
---|---|---|
d23b8f57 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- A T R E E -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
8d0d46f4 | 9 | -- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- |
d23b8f57 RK |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
d23b8f57 RK |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
b740cf28 AC |
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. -- | |
d23b8f57 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
d23b8f57 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
d23b8f57 | 26 | -- WARNING: There is a C version of this package. Any changes to this source |
4cd52f5e ES |
27 | -- file must be properly reflected in the file atree.h which is a C header |
28 | -- file containing equivalent definitions for use by gigi. | |
d23b8f57 | 29 | |
76f9c7f4 BD |
30 | -- Checks and assertions in this package are too slow, and are mostly needed |
31 | -- when working on this package itself, or on gen_il, so we disable them. | |
32 | ||
33 | pragma Suppress (All_Checks); | |
34 | pragma Assertion_Policy (Ignore); | |
d23b8f57 | 35 | |
76f9c7f4 BD |
36 | with Aspects; use Aspects; |
37 | with Debug; use Debug; | |
38 | with Namet; use Namet; | |
39 | with Nlists; use Nlists; | |
40 | with Opt; use Opt; | |
41 | with Output; use Output; | |
42 | with Seinfo; use Seinfo; | |
43 | with Sinfo.Utils; use Sinfo.Utils; | |
44 | with Sinput; use Sinput; | |
45 | with System.Storage_Elements; | |
7b47778e | 46 | |
d23b8f57 RK |
47 | package body Atree is |
48 | ||
980f94b7 HK |
49 | Ignored_Ghost_Recording_Proc : Ignored_Ghost_Record_Proc := null; |
50 | -- This soft link captures the procedure invoked during the creation of an | |
51 | -- ignored Ghost node or entity. | |
52 | ||
f68fc405 AC |
53 | Locked : Boolean := False; |
54 | -- Compiling with assertions enabled, node contents modifications are | |
55 | -- permitted only when this switch is set to False; compiling without | |
56 | -- assertions this lock has no effect. | |
57 | ||
e771c085 | 58 | Reporting_Proc : Report_Proc := null; |
83dcc2bd BD |
59 | -- Set_Reporting_Proc sets this. Set_Reporting_Proc must be called only |
60 | -- once. | |
e771c085 | 61 | |
90e491a7 PMR |
62 | Rewriting_Proc : Rewrite_Proc := null; |
63 | -- This soft link captures the procedure invoked during a node rewrite | |
64 | ||
4cd52f5e ES |
65 | --------------- |
66 | -- Debugging -- | |
67 | --------------- | |
68 | ||
69 | -- Suppose you find that node 12345 is messed up. You might want to find | |
70 | -- the code that created that node. There are two ways to do this: | |
71 | ||
72 | -- One way is to set a conditional breakpoint on New_Node_Debugging_Output | |
73 | -- (nickname "nnd"): | |
74 | -- break nnd if n = 12345 | |
75 | -- and run gnat1 again from the beginning. | |
76 | ||
77 | -- The other way is to set a breakpoint near the beginning (e.g. on | |
78 | -- gnat1drv), and run. Then set Watch_Node (nickname "ww") to 12345 in gdb: | |
79 | -- ww := 12345 | |
80 | -- and set a breakpoint on New_Node_Breakpoint (nickname "nn"). Continue. | |
81 | ||
15529d0a PMR |
82 | -- Either way, gnat1 will stop when node 12345 is created, or certain other |
83 | -- interesting operations are performed, such as Rewrite. To see exactly | |
84 | -- which operations, search for "pragma Debug" below. | |
4cd52f5e | 85 | |
15529d0a PMR |
86 | -- The second method is much faster if the amount of Ada code being |
87 | -- compiled is large. | |
06f2efd7 | 88 | |
4cd52f5e | 89 | ww : Node_Id'Base := Node_Id'First - 1; |
76f9c7f4 | 90 | pragma Export (Ada, ww); |
4cd52f5e | 91 | Watch_Node : Node_Id'Base renames ww; |
47edeeab AC |
92 | -- Node to "watch"; that is, whenever a node is created, we check if it |
93 | -- is equal to Watch_Node, and if so, call New_Node_Breakpoint. You have | |
4cd52f5e ES |
94 | -- presumably set a breakpoint on New_Node_Breakpoint. Note that the |
95 | -- initial value of Node_Id'First - 1 ensures that by default, no node | |
96 | -- will be equal to Watch_Node. | |
97 | ||
98 | procedure nn; | |
99 | pragma Export (Ada, nn); | |
100 | procedure New_Node_Breakpoint renames nn; | |
101 | -- This doesn't do anything interesting; it's just for setting breakpoint | |
102 | -- on as explained above. | |
103 | ||
104 | procedure nnd (N : Node_Id); | |
105 | pragma Export (Ada, nnd); | |
106 | procedure New_Node_Debugging_Output (N : Node_Id) renames nnd; | |
107 | -- For debugging. If debugging is turned on, New_Node and New_Entity call | |
108 | -- this. If debug flag N is turned on, this prints out the new node. | |
109 | -- | |
110 | -- If Node = Watch_Node, this prints out the new node and calls | |
111 | -- New_Node_Breakpoint. Otherwise, does nothing. | |
112 | ||
06f2efd7 | 113 | procedure Node_Debug_Output (Op : String; N : Node_Id); |
15529d0a | 114 | -- Called by nnd; writes Op followed by information about N |
06f2efd7 | 115 | |
4cd52f5e ES |
116 | ----------------------------- |
117 | -- Local Objects and Types -- | |
118 | ----------------------------- | |
119 | ||
83dcc2bd | 120 | Comes_From_Source_Default : Boolean := False; |
d23b8f57 | 121 | |
d23b8f57 | 122 | use Atree_Private_Part; |
a90bd866 | 123 | -- We are also allowed to see our private data structures |
d23b8f57 | 124 | |
d23b8f57 RK |
125 | -------------------------------------------------- |
126 | -- Implementation of Tree Substitution Routines -- | |
127 | -------------------------------------------------- | |
128 | ||
129 | -- A separate table keeps track of the mapping between rewritten nodes | |
130 | -- and their corresponding original tree nodes. Rewrite makes an entry | |
131 | -- in this table for use by Original_Node. By default, if no call is | |
132 | -- Rewrite, the entry in this table points to the original unwritten node. | |
133 | ||
134 | -- Note: eventually, this should be a field in the Node directly, but | |
135 | -- for now we do not want to disturb the efficiency of a power of 2 | |
76f9c7f4 | 136 | -- for the node size. ????We are getting rid of power-of-2. |
d23b8f57 RK |
137 | |
138 | package Orig_Nodes is new Table.Table ( | |
139 | Table_Component_Type => Node_Id, | |
39f4e199 | 140 | Table_Index_Type => Node_Id'Base, |
d23b8f57 | 141 | Table_Low_Bound => First_Node_Id, |
76f9c7f4 BD |
142 | Table_Initial => Alloc.Node_Offsets_Initial, |
143 | Table_Increment => Alloc.Node_Offsets_Increment, | |
d23b8f57 RK |
144 | Table_Name => "Orig_Nodes"); |
145 | ||
8133b9d1 ES |
146 | -------------------------- |
147 | -- Paren_Count Handling -- | |
148 | -------------------------- | |
149 | ||
76f9c7f4 BD |
150 | -- The Small_Paren_Count field has range 0 .. 3. If the Paren_Count is |
151 | -- in the range 0 .. 2, then it is stoed as Small_Paren_Count. Otherwise, | |
152 | -- Small_Paren_Count = 3, and the actual Paren_Count is stored in the | |
153 | -- Paren_Counts table. | |
154 | -- | |
155 | -- We use linear search on the Paren_Counts table, which is plenty | |
156 | -- efficient because only pathological programs will use it. Nobody | |
157 | -- writes (((X + Y))). | |
8133b9d1 ES |
158 | |
159 | type Paren_Count_Entry is record | |
477cfc5b | 160 | Nod : Node_Id; |
8133b9d1 ES |
161 | -- The node to which this count applies |
162 | ||
163 | Count : Nat range 3 .. Nat'Last; | |
164 | -- The count of parentheses, which will be in the indicated range | |
165 | end record; | |
166 | ||
167 | package Paren_Counts is new Table.Table ( | |
168 | Table_Component_Type => Paren_Count_Entry, | |
169 | Table_Index_Type => Int, | |
170 | Table_Low_Bound => 0, | |
171 | Table_Initial => 10, | |
172 | Table_Increment => 200, | |
173 | Table_Name => "Paren_Counts"); | |
174 | ||
83dcc2bd BD |
175 | procedure Set_Paren_Count_Of_Copy (Target, Source : Node_Id); |
176 | pragma Inline (Set_Paren_Count_Of_Copy); | |
177 | -- Called when copying a node. Makes sure the Paren_Count of the copy is | |
178 | -- correct. | |
179 | ||
d23b8f57 RK |
180 | ----------------------- |
181 | -- Local Subprograms -- | |
182 | ----------------------- | |
183 | ||
76f9c7f4 BD |
184 | function Is_Entity (N : Node_Or_Entity_Id) return Boolean; |
185 | pragma Inline (Is_Entity); | |
186 | -- Returns True if N is an entity | |
187 | ||
188 | function Allocate_New_Node (Kind : Node_Kind) return Node_Id; | |
83dcc2bd BD |
189 | pragma Inline (Allocate_New_Node); |
190 | -- Allocate a new node or first part of a node extension. Initialize the | |
191 | -- Nodes.Table entry, Flags, Orig_Nodes, and List tables. | |
7324bf49 | 192 | |
d65a80fd | 193 | procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id); |
76f9c7f4 BD |
194 | -- Fix up parent pointers for the children of Fix_Node after a copy, |
195 | -- setting them to Fix_Node when they pointed to Ref_Node. | |
d65a80fd HK |
196 | |
197 | procedure Mark_New_Ghost_Node (N : Node_Or_Entity_Id); | |
198 | -- Mark arbitrary node or entity N as Ghost when it is created within a | |
199 | -- Ghost region. | |
200 | ||
83dcc2bd BD |
201 | procedure Report (Target, Source : Node_Id); |
202 | pragma Inline (Report); | |
203 | -- Invoke the reporting procedure if available | |
7324bf49 | 204 | |
76f9c7f4 BD |
205 | function Size_In_Slots (N : Node_Or_Entity_Id) return Field_Offset; |
206 | -- Number of slots belonging to N. This can be less than | |
207 | -- Size_In_Slots_To_Alloc for entities. | |
165eab5f | 208 | |
76f9c7f4 BD |
209 | function Size_In_Slots_To_Alloc (N : Node_Or_Entity_Id) return Field_Offset; |
210 | function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Field_Offset; | |
211 | -- Number of slots to allocate for a node or entity. For entities, we have | |
212 | -- to allocate the max, because we don't know the Ekind when this is | |
213 | -- called. | |
7665e4bd | 214 | |
76f9c7f4 BD |
215 | function Off_0 (N : Node_Id) return Node_Offset; |
216 | -- Offset of the first slot of N (offset 0) in Slots.Table | |
d23b8f57 | 217 | |
76f9c7f4 BD |
218 | function Off_L (N : Node_Id) return Node_Offset; |
219 | -- Offset of the last slot of N in Slots.Table | |
d23b8f57 | 220 | |
76f9c7f4 BD |
221 | procedure Zero_Slots (F, L : Node_Offset) with Inline; |
222 | -- Set slots in the range F..L to zero | |
d23b8f57 | 223 | |
76f9c7f4 BD |
224 | procedure Zero_Slots (N : Node_Or_Entity_Id) with Inline; |
225 | -- Zero the slots belonging to N | |
ac4d6407 | 226 | |
76f9c7f4 BD |
227 | procedure Copy_Slots (From, To, Num_Slots : Node_Offset) with Inline; |
228 | -- Copy Num_Slots slots from From to To | |
ac4d6407 | 229 | |
76f9c7f4 BD |
230 | procedure Copy_Slots (Source, Destination : Node_Id) with Inline; |
231 | -- Copies the slots of Source to Destination | |
b502ba3c | 232 | |
76f9c7f4 BD |
233 | function Get_Field_Value |
234 | (N : Node_Id; Field : Node_Field) return Field_32_Bit; | |
235 | -- Get any field value as a Field_32_Bit. If the field is smaller than 32 | |
236 | -- bits, convert it to Field_32_Bit. | |
b502ba3c | 237 | |
76f9c7f4 BD |
238 | procedure Set_Field_Value |
239 | (N : Node_Id; Field : Node_Field; Val : Field_32_Bit); | |
240 | -- Set any field value as a Field_32_Bit. If the field is smaller than 32 | |
241 | -- bits, convert it from Field_32_Bit, and Val had better be small enough. | |
ee2ba856 | 242 | |
76f9c7f4 BD |
243 | procedure Check_Vanishing_Fields |
244 | (Old_N : Node_Id; New_Kind : Node_Kind); | |
245 | -- Called whenever Nkind is modified. Raises an exception if not all | |
246 | -- vanishing fields are in their initial zero state. | |
ee2ba856 | 247 | |
76f9c7f4 BD |
248 | function Get_Field_Value |
249 | (N : Entity_Id; Field : Entity_Field) return Field_32_Bit; | |
250 | procedure Set_Field_Value | |
251 | (N : Entity_Id; Field : Entity_Field; Val : Field_32_Bit); | |
252 | procedure Check_Vanishing_Fields | |
253 | (Old_N : Entity_Id; New_Kind : Entity_Kind); | |
254 | -- Above are the same as the ones for nodes, but for entities | |
ee2ba856 | 255 | |
76f9c7f4 BD |
256 | procedure Init_Nkind (N : Node_Id; Val : Node_Kind); |
257 | -- Initialize the Nkind field, which must not have been set already. This | |
258 | -- cannot be used to modify an already-initialized Nkind field. See also | |
259 | -- Mutate_Nkind. | |
d23b8f57 | 260 | |
76f9c7f4 BD |
261 | package Field_Checking is |
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 | end Field_Checking; | |
980f94b7 | 267 | |
76f9c7f4 | 268 | package body Field_Checking is |
980f94b7 | 269 | |
76f9c7f4 | 270 | -- Tables used by Field_Present |
980f94b7 | 271 | |
76f9c7f4 BD |
272 | type Node_Field_Sets is array (Node_Kind) of Node_Field_Set; |
273 | type Node_Field_Sets_Ptr is access all Node_Field_Sets; | |
274 | Node_Fields_Present : Node_Field_Sets_Ptr; | |
980f94b7 | 275 | |
76f9c7f4 BD |
276 | type Entity_Field_Sets is array (Entity_Kind) of Entity_Field_Set; |
277 | type Entity_Field_Sets_Ptr is access all Entity_Field_Sets; | |
278 | Entity_Fields_Present : Entity_Field_Sets_Ptr; | |
980f94b7 | 279 | |
76f9c7f4 | 280 | procedure Init_Tables; |
d23b8f57 | 281 | |
76f9c7f4 BD |
282 | function Fields_Present (Kind : Node_Kind) return Node_Field_Set; |
283 | function Fields_Present (Kind : Entity_Kind) return Entity_Field_Set; | |
284 | -- Computes the set of fields present in each Node/Entity Kind. Used to | |
285 | -- initialize the above tables. | |
d23b8f57 | 286 | |
76f9c7f4 BD |
287 | -------------------- |
288 | -- Fields_Present -- | |
289 | -------------------- | |
d23b8f57 | 290 | |
76f9c7f4 BD |
291 | function Fields_Present (Kind : Node_Kind) return Node_Field_Set is |
292 | Result : Node_Field_Set := (others => False); | |
293 | begin | |
294 | for J in Node_Field_Table (Kind)'Range loop | |
295 | Result (Node_Field_Table (Kind) (J)) := True; | |
296 | end loop; | |
4bcf6815 | 297 | |
76f9c7f4 BD |
298 | return Result; |
299 | end Fields_Present; | |
d23b8f57 | 300 | |
76f9c7f4 BD |
301 | function Fields_Present (Kind : Entity_Kind) return Entity_Field_Set is |
302 | Result : Entity_Field_Set := (others => False); | |
303 | begin | |
304 | for J in Entity_Field_Table (Kind)'Range loop | |
305 | Result (Entity_Field_Table (Kind) (J)) := True; | |
306 | end loop; | |
d23b8f57 | 307 | |
76f9c7f4 BD |
308 | return Result; |
309 | end Fields_Present; | |
d23b8f57 | 310 | |
76f9c7f4 BD |
311 | procedure Init_Tables is |
312 | begin | |
313 | Node_Fields_Present := new Node_Field_Sets; | |
d23b8f57 | 314 | |
76f9c7f4 BD |
315 | for Kind in Node_Kind loop |
316 | Node_Fields_Present (Kind) := Fields_Present (Kind); | |
317 | end loop; | |
d23b8f57 | 318 | |
76f9c7f4 | 319 | Entity_Fields_Present := new Entity_Field_Sets; |
d23b8f57 | 320 | |
76f9c7f4 BD |
321 | for Kind in Entity_Kind loop |
322 | Entity_Fields_Present (Kind) := Fields_Present (Kind); | |
323 | end loop; | |
324 | end Init_Tables; | |
d23b8f57 | 325 | |
76f9c7f4 BD |
326 | -- In production mode, we leave Node_Fields_Present and |
327 | -- Entity_Fields_Present null. Field_Present is only for | |
328 | -- use in assertions. | |
7f5e671b | 329 | |
76f9c7f4 | 330 | pragma Debug (Init_Tables); |
d23b8f57 | 331 | |
76f9c7f4 BD |
332 | function Field_Present |
333 | (Kind : Node_Kind; Field : Node_Field) return Boolean is | |
334 | begin | |
335 | if Node_Fields_Present = null then | |
336 | return True; | |
337 | end if; | |
4bcf6815 | 338 | |
76f9c7f4 BD |
339 | return Node_Fields_Present (Kind) (Field); |
340 | end Field_Present; | |
8133b9d1 | 341 | |
76f9c7f4 BD |
342 | function Field_Present |
343 | (Kind : Entity_Kind; Field : Entity_Field) return Boolean is | |
344 | begin | |
345 | if Entity_Fields_Present = null then | |
346 | return True; | |
347 | end if; | |
8133b9d1 | 348 | |
76f9c7f4 BD |
349 | return Entity_Fields_Present (Kind) (Field); |
350 | end Field_Present; | |
77a2f3df | 351 | |
76f9c7f4 | 352 | end Field_Checking; |
d23b8f57 | 353 | |
864a4236 | 354 | ------------------------ |
76f9c7f4 | 355 | -- Atree_Private_Part -- |
864a4236 ES |
356 | ------------------------ |
357 | ||
76f9c7f4 BD |
358 | package body Atree_Private_Part is |
359 | ||
360 | -- The following validators are disabled in production builds, by being | |
361 | -- called in pragma Debug. They are also disabled by default in debug | |
362 | -- builds, by setting the flags below, because they make the compiler | |
363 | -- very slow (10 to 20 times slower). Validate can be set True to debug | |
364 | -- the low-level accessors. | |
365 | -- | |
366 | -- Even if Validate is True, validation is disabled during | |
367 | -- Validate_... calls to prevent infinite recursion | |
368 | -- (Validate_... procedures call field getters, which call | |
369 | -- Validate_... procedures). That's what the Enable_Validate_... | |
370 | -- flags are for; they are toggled so that when we're inside one | |
371 | -- of them, and enter it again, the inner call doesn't do anything. | |
372 | -- These flags are irrelevant when Validate is False. | |
373 | ||
374 | Validate : constant Boolean := False; | |
375 | ||
376 | Enable_Validate_Node, | |
377 | Enable_Validate_Node_Write, | |
378 | Enable_Validate_Node_And_Offset, | |
379 | Enable_Validate_Node_And_Offset_Write : | |
380 | Boolean := Validate; | |
381 | ||
382 | procedure Validate_Node_And_Offset | |
383 | (N : Node_Or_Entity_Id; Offset : Field_Offset); | |
384 | procedure Validate_Node_And_Offset_Write | |
385 | (N : Node_Or_Entity_Id; Offset : Field_Offset); | |
386 | -- Asserts N is OK, and the Offset in slots is within N. Note that this | |
387 | -- does not guarantee that the offset is valid, just that it's not past | |
388 | -- the last slot. It could be pointing at unused bits within the node, | |
389 | -- or unused padding at the end. | |
390 | ||
391 | procedure Validate_Node_And_Offset | |
392 | (N : Node_Or_Entity_Id; Offset : Field_Offset) is | |
393 | begin | |
394 | if Enable_Validate_Node_And_Offset then | |
395 | Enable_Validate_Node_And_Offset := False; | |
396 | ||
397 | pragma Debug (Validate_Node (N)); | |
398 | pragma Assert (Offset'Valid); | |
399 | pragma Assert (Offset < Size_In_Slots (N)); | |
400 | ||
401 | Enable_Validate_Node_And_Offset := True; | |
402 | end if; | |
403 | end Validate_Node_And_Offset; | |
864a4236 | 404 | |
76f9c7f4 BD |
405 | procedure Validate_Node_And_Offset_Write |
406 | (N : Node_Or_Entity_Id; Offset : Field_Offset) is | |
407 | begin | |
408 | if Enable_Validate_Node_And_Offset_Write then | |
409 | Enable_Validate_Node_And_Offset_Write := False; | |
864a4236 | 410 | |
76f9c7f4 BD |
411 | pragma Debug (Validate_Node_Write (N)); |
412 | pragma Assert (Offset'Valid); | |
413 | pragma Assert (Offset < Size_In_Slots (N)); | |
d23b8f57 | 414 | |
76f9c7f4 BD |
415 | Enable_Validate_Node_And_Offset_Write := True; |
416 | end if; | |
417 | end Validate_Node_And_Offset_Write; | |
d23b8f57 | 418 | |
76f9c7f4 BD |
419 | procedure Validate_Node (N : Node_Or_Entity_Id) is |
420 | begin | |
421 | if Enable_Validate_Node then | |
422 | Enable_Validate_Node := False; | |
d23b8f57 | 423 | |
76f9c7f4 BD |
424 | pragma Assert (N'Valid); |
425 | pragma Assert (N <= Node_Offsets.Last); | |
426 | pragma Assert (Off_0 (N) < Off_L (N)); | |
427 | pragma Assert (Off_L (N) <= Slots.Last); | |
428 | pragma Assert (Nkind (N)'Valid); | |
429 | pragma Assert (Nkind (N) /= N_Unused_At_End); | |
d23b8f57 | 430 | |
76f9c7f4 BD |
431 | if Nkind (N) in N_Entity then |
432 | pragma Assert (Ekind (N)'Valid); | |
433 | end if; | |
d23b8f57 | 434 | |
76f9c7f4 BD |
435 | if Nkind (N) in N_Attribute_Definition_Clause |
436 | | N_Has_Entity | |
437 | | N_Aggregate | |
438 | | N_Extension_Aggregate | |
439 | | N_Selected_Component | |
440 | | N_Use_Package_Clause | |
441 | | N_Aspect_Specification | |
442 | | N_Freeze_Entity | |
443 | | N_Freeze_Generic_Entity | |
444 | then | |
445 | pragma Assert (Entity_Or_Associated_Node (N)'Valid); | |
446 | end if; | |
d23b8f57 | 447 | |
76f9c7f4 BD |
448 | Enable_Validate_Node := True; |
449 | end if; | |
450 | end Validate_Node; | |
d23b8f57 | 451 | |
76f9c7f4 | 452 | procedure Validate_Node_Write (N : Node_Or_Entity_Id) is |
d23b8f57 | 453 | begin |
76f9c7f4 BD |
454 | if Enable_Validate_Node_Write then |
455 | Enable_Validate_Node_Write := False; | |
f1a3590e | 456 | |
76f9c7f4 BD |
457 | pragma Debug (Validate_Node (N)); |
458 | pragma Assert (not Locked); | |
d23b8f57 | 459 | |
76f9c7f4 BD |
460 | Enable_Validate_Node_Write := True; |
461 | end if; | |
462 | end Validate_Node_Write; | |
d23b8f57 | 463 | |
76f9c7f4 BD |
464 | function Is_Valid_Node (U : Union_Id) return Boolean is |
465 | begin | |
466 | return Node_Id'Base (U) <= Node_Offsets.Last; | |
467 | end Is_Valid_Node; | |
d23b8f57 | 468 | |
76f9c7f4 BD |
469 | function Alloc_Node_Id return Node_Id is |
470 | begin | |
471 | Node_Offsets.Increment_Last; | |
472 | return Node_Offsets.Last; | |
473 | end Alloc_Node_Id; | |
d23b8f57 | 474 | |
76f9c7f4 BD |
475 | function Alloc_Slots (Num_Slots : Field_Offset) return Node_Offset is |
476 | begin | |
477 | return Result : constant Node_Offset := Slots.Last + 1 do | |
478 | Slots.Set_Last (Slots.Last + Num_Slots); | |
479 | end return; | |
480 | end Alloc_Slots; | |
d23b8f57 | 481 | |
76f9c7f4 BD |
482 | function Get_1_Bit_Field |
483 | (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type | |
484 | is | |
485 | pragma Assert (Field_Type'Size = 1); | |
d23b8f57 | 486 | |
76f9c7f4 | 487 | function Cast is new Unchecked_Conversion (Field_1_Bit, Field_Type); |
d23b8f57 | 488 | begin |
76f9c7f4 BD |
489 | return Cast (Get_1_Bit_Val (N, Offset)); |
490 | end Get_1_Bit_Field; | |
d23b8f57 | 491 | |
76f9c7f4 BD |
492 | function Get_2_Bit_Field |
493 | (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type | |
494 | is | |
495 | pragma Assert (Field_Type'Size = 2); | |
d23b8f57 | 496 | |
76f9c7f4 BD |
497 | function Cast is new Unchecked_Conversion (Field_2_Bit, Field_Type); |
498 | begin | |
499 | return Cast (Get_2_Bit_Val (N, Offset)); | |
500 | end Get_2_Bit_Field; | |
d23b8f57 | 501 | |
76f9c7f4 BD |
502 | function Get_4_Bit_Field |
503 | (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type | |
504 | is | |
505 | pragma Assert (Field_Type'Size = 4); | |
d23b8f57 | 506 | |
76f9c7f4 BD |
507 | function Cast is new Unchecked_Conversion (Field_4_Bit, Field_Type); |
508 | begin | |
509 | return Cast (Get_4_Bit_Val (N, Offset)); | |
510 | end Get_4_Bit_Field; | |
d23b8f57 | 511 | |
76f9c7f4 BD |
512 | function Get_8_Bit_Field |
513 | (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type | |
514 | is | |
515 | pragma Assert (Field_Type'Size = 8); | |
d23b8f57 | 516 | |
76f9c7f4 | 517 | function Cast is new Unchecked_Conversion (Field_8_Bit, Field_Type); |
d23b8f57 | 518 | begin |
76f9c7f4 BD |
519 | return Cast (Get_8_Bit_Val (N, Offset)); |
520 | end Get_8_Bit_Field; | |
d23b8f57 | 521 | |
76f9c7f4 BD |
522 | function Get_32_Bit_Field |
523 | (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type | |
524 | is | |
525 | pragma Assert (Field_Type'Size = 32); | |
d23b8f57 | 526 | |
76f9c7f4 BD |
527 | function Cast is new Unchecked_Conversion (Field_32_Bit, Field_Type); |
528 | begin | |
529 | return Cast (Get_32_Bit_Val (N, Offset)); | |
530 | end Get_32_Bit_Field; | |
d23b8f57 | 531 | |
76f9c7f4 BD |
532 | function Get_32_Bit_Field_With_Default |
533 | (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type | |
534 | is | |
535 | function Get_Field is new Get_32_Bit_Field (Field_Type) with Inline; | |
536 | begin | |
537 | -- If the field has not yet been set, it will be equal to zero. | |
538 | -- That is of the "wrong" type, so we fetch it as a Field_32_Bit. | |
d23b8f57 | 539 | |
76f9c7f4 BD |
540 | if Get_32_Bit_Val (N, Offset) = 0 then |
541 | return Default_Val; | |
d23b8f57 RK |
542 | |
543 | else | |
76f9c7f4 | 544 | return Get_Field (N, Offset); |
d23b8f57 | 545 | end if; |
76f9c7f4 | 546 | end Get_32_Bit_Field_With_Default; |
d23b8f57 | 547 | |
76f9c7f4 BD |
548 | procedure Set_1_Bit_Field |
549 | (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type) | |
550 | is | |
551 | pragma Assert (Field_Type'Size = 1); | |
d23b8f57 | 552 | |
76f9c7f4 BD |
553 | function Cast is new Unchecked_Conversion (Field_Type, Field_1_Bit); |
554 | begin | |
555 | Set_1_Bit_Val (N, Offset, Cast (Val)); | |
556 | end Set_1_Bit_Field; | |
d23b8f57 | 557 | |
76f9c7f4 BD |
558 | procedure Set_2_Bit_Field |
559 | (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type) | |
560 | is | |
561 | pragma Assert (Field_Type'Size = 2); | |
d23b8f57 | 562 | |
76f9c7f4 BD |
563 | function Cast is new Unchecked_Conversion (Field_Type, Field_2_Bit); |
564 | begin | |
565 | Set_2_Bit_Val (N, Offset, Cast (Val)); | |
566 | end Set_2_Bit_Field; | |
d23b8f57 | 567 | |
76f9c7f4 BD |
568 | procedure Set_4_Bit_Field |
569 | (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type) | |
570 | is | |
571 | pragma Assert (Field_Type'Size = 4); | |
d23b8f57 | 572 | |
76f9c7f4 BD |
573 | function Cast is new Unchecked_Conversion (Field_Type, Field_4_Bit); |
574 | begin | |
575 | Set_4_Bit_Val (N, Offset, Cast (Val)); | |
576 | end Set_4_Bit_Field; | |
d23b8f57 | 577 | |
76f9c7f4 BD |
578 | procedure Set_8_Bit_Field |
579 | (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type) | |
580 | is | |
581 | pragma Assert (Field_Type'Size = 8); | |
a98480dd | 582 | |
76f9c7f4 BD |
583 | function Cast is new Unchecked_Conversion (Field_Type, Field_8_Bit); |
584 | begin | |
585 | Set_8_Bit_Val (N, Offset, Cast (Val)); | |
586 | end Set_8_Bit_Field; | |
a98480dd | 587 | |
76f9c7f4 BD |
588 | procedure Set_32_Bit_Field |
589 | (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type) | |
590 | is | |
591 | pragma Assert (Field_Type'Size = 32); | |
d23b8f57 | 592 | |
76f9c7f4 BD |
593 | function Cast is new Unchecked_Conversion (Field_Type, Field_32_Bit); |
594 | begin | |
595 | Set_32_Bit_Val (N, Offset, Cast (Val)); | |
596 | end Set_32_Bit_Field; | |
d23b8f57 | 597 | |
76f9c7f4 BD |
598 | function Get_1_Bit_Val |
599 | (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_1_Bit | |
600 | is | |
601 | -- We wish we were using packed arrays, but instead we're simulating | |
602 | -- packed arrays using packed records. L here (and elsewhere) is the | |
603 | -- 'Length of that array. | |
604 | L : constant Field_Offset := 32; | |
605 | ||
606 | pragma Debug (Validate_Node_And_Offset (N, Offset / L)); | |
607 | ||
608 | subtype Offset_In_Slot is Field_Offset range 0 .. L - 1; | |
609 | S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); | |
610 | begin | |
611 | case Offset_In_Slot'(Offset mod L) is | |
612 | when 0 => return S.Slot_1.F0; | |
613 | when 1 => return S.Slot_1.F1; | |
614 | when 2 => return S.Slot_1.F2; | |
615 | when 3 => return S.Slot_1.F3; | |
616 | when 4 => return S.Slot_1.F4; | |
617 | when 5 => return S.Slot_1.F5; | |
618 | when 6 => return S.Slot_1.F6; | |
619 | when 7 => return S.Slot_1.F7; | |
620 | when 8 => return S.Slot_1.F8; | |
621 | when 9 => return S.Slot_1.F9; | |
622 | when 10 => return S.Slot_1.F10; | |
623 | when 11 => return S.Slot_1.F11; | |
624 | when 12 => return S.Slot_1.F12; | |
625 | when 13 => return S.Slot_1.F13; | |
626 | when 14 => return S.Slot_1.F14; | |
627 | when 15 => return S.Slot_1.F15; | |
628 | when 16 => return S.Slot_1.F16; | |
629 | when 17 => return S.Slot_1.F17; | |
630 | when 18 => return S.Slot_1.F18; | |
631 | when 19 => return S.Slot_1.F19; | |
632 | when 20 => return S.Slot_1.F20; | |
633 | when 21 => return S.Slot_1.F21; | |
634 | when 22 => return S.Slot_1.F22; | |
635 | when 23 => return S.Slot_1.F23; | |
636 | when 24 => return S.Slot_1.F24; | |
637 | when 25 => return S.Slot_1.F25; | |
638 | when 26 => return S.Slot_1.F26; | |
639 | when 27 => return S.Slot_1.F27; | |
640 | when 28 => return S.Slot_1.F28; | |
641 | when 29 => return S.Slot_1.F29; | |
642 | when 30 => return S.Slot_1.F30; | |
643 | when 31 => return S.Slot_1.F31; | |
644 | end case; | |
645 | end Get_1_Bit_Val; | |
f1a3590e | 646 | |
76f9c7f4 BD |
647 | function Get_2_Bit_Val |
648 | (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_2_Bit | |
649 | is | |
650 | L : constant Field_Offset := 16; | |
651 | ||
652 | pragma Debug (Validate_Node_And_Offset (N, Offset / L)); | |
653 | ||
654 | subtype Offset_In_Slot is Field_Offset range 0 .. L - 1; | |
655 | S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); | |
656 | begin | |
657 | case Offset_In_Slot'(Offset mod L) is | |
658 | when 0 => return S.Slot_2.F0; | |
659 | when 1 => return S.Slot_2.F1; | |
660 | when 2 => return S.Slot_2.F2; | |
661 | when 3 => return S.Slot_2.F3; | |
662 | when 4 => return S.Slot_2.F4; | |
663 | when 5 => return S.Slot_2.F5; | |
664 | when 6 => return S.Slot_2.F6; | |
665 | when 7 => return S.Slot_2.F7; | |
666 | when 8 => return S.Slot_2.F8; | |
667 | when 9 => return S.Slot_2.F9; | |
668 | when 10 => return S.Slot_2.F10; | |
669 | when 11 => return S.Slot_2.F11; | |
670 | when 12 => return S.Slot_2.F12; | |
671 | when 13 => return S.Slot_2.F13; | |
672 | when 14 => return S.Slot_2.F14; | |
673 | when 15 => return S.Slot_2.F15; | |
674 | end case; | |
675 | end Get_2_Bit_Val; | |
f1a3590e | 676 | |
76f9c7f4 BD |
677 | function Get_4_Bit_Val |
678 | (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_4_Bit | |
679 | is | |
680 | L : constant Field_Offset := 8; | |
681 | ||
682 | pragma Debug (Validate_Node_And_Offset (N, Offset / L)); | |
683 | ||
684 | subtype Offset_In_Slot is Field_Offset range 0 .. L - 1; | |
685 | S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); | |
686 | begin | |
687 | case Offset_In_Slot'(Offset mod L) is | |
688 | when 0 => return S.Slot_4.F0; | |
689 | when 1 => return S.Slot_4.F1; | |
690 | when 2 => return S.Slot_4.F2; | |
691 | when 3 => return S.Slot_4.F3; | |
692 | when 4 => return S.Slot_4.F4; | |
693 | when 5 => return S.Slot_4.F5; | |
694 | when 6 => return S.Slot_4.F6; | |
695 | when 7 => return S.Slot_4.F7; | |
696 | end case; | |
697 | end Get_4_Bit_Val; | |
f1a3590e | 698 | |
76f9c7f4 BD |
699 | function Get_8_Bit_Val |
700 | (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_8_Bit | |
701 | is | |
702 | L : constant Field_Offset := 4; | |
f1a3590e | 703 | |
76f9c7f4 | 704 | pragma Debug (Validate_Node_And_Offset (N, Offset / L)); |
f1a3590e | 705 | |
76f9c7f4 BD |
706 | subtype Offset_In_Slot is Field_Offset range 0 .. L - 1; |
707 | S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); | |
708 | begin | |
709 | case Offset_In_Slot'(Offset mod L) is | |
710 | when 0 => return S.Slot_8.F0; | |
711 | when 1 => return S.Slot_8.F1; | |
712 | when 2 => return S.Slot_8.F2; | |
713 | when 3 => return S.Slot_8.F3; | |
714 | end case; | |
715 | end Get_8_Bit_Val; | |
f1a3590e | 716 | |
76f9c7f4 BD |
717 | function Get_32_Bit_Val |
718 | (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_32_Bit | |
719 | is | |
720 | pragma Debug (Validate_Node_And_Offset (N, Offset)); | |
f1a3590e | 721 | |
76f9c7f4 BD |
722 | S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset); |
723 | begin | |
724 | return S.Slot_32; | |
725 | end Get_32_Bit_Val; | |
f1a3590e | 726 | |
76f9c7f4 BD |
727 | procedure Set_1_Bit_Val |
728 | (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_1_Bit) | |
729 | is | |
730 | L : constant Field_Offset := 32; | |
731 | ||
732 | pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L)); | |
733 | ||
734 | subtype Offset_In_Slot is Field_Offset range 0 .. L - 1; | |
735 | S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); | |
736 | begin | |
737 | case Offset_In_Slot'(Offset mod L) is | |
738 | when 0 => S.Slot_1.F0 := Val; | |
739 | when 1 => S.Slot_1.F1 := Val; | |
740 | when 2 => S.Slot_1.F2 := Val; | |
741 | when 3 => S.Slot_1.F3 := Val; | |
742 | when 4 => S.Slot_1.F4 := Val; | |
743 | when 5 => S.Slot_1.F5 := Val; | |
744 | when 6 => S.Slot_1.F6 := Val; | |
745 | when 7 => S.Slot_1.F7 := Val; | |
746 | when 8 => S.Slot_1.F8 := Val; | |
747 | when 9 => S.Slot_1.F9 := Val; | |
748 | when 10 => S.Slot_1.F10 := Val; | |
749 | when 11 => S.Slot_1.F11 := Val; | |
750 | when 12 => S.Slot_1.F12 := Val; | |
751 | when 13 => S.Slot_1.F13 := Val; | |
752 | when 14 => S.Slot_1.F14 := Val; | |
753 | when 15 => S.Slot_1.F15 := Val; | |
754 | when 16 => S.Slot_1.F16 := Val; | |
755 | when 17 => S.Slot_1.F17 := Val; | |
756 | when 18 => S.Slot_1.F18 := Val; | |
757 | when 19 => S.Slot_1.F19 := Val; | |
758 | when 20 => S.Slot_1.F20 := Val; | |
759 | when 21 => S.Slot_1.F21 := Val; | |
760 | when 22 => S.Slot_1.F22 := Val; | |
761 | when 23 => S.Slot_1.F23 := Val; | |
762 | when 24 => S.Slot_1.F24 := Val; | |
763 | when 25 => S.Slot_1.F25 := Val; | |
764 | when 26 => S.Slot_1.F26 := Val; | |
765 | when 27 => S.Slot_1.F27 := Val; | |
766 | when 28 => S.Slot_1.F28 := Val; | |
767 | when 29 => S.Slot_1.F29 := Val; | |
768 | when 30 => S.Slot_1.F30 := Val; | |
769 | when 31 => S.Slot_1.F31 := Val; | |
770 | end case; | |
771 | end Set_1_Bit_Val; | |
f1a3590e | 772 | |
76f9c7f4 BD |
773 | procedure Set_2_Bit_Val |
774 | (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_2_Bit) | |
775 | is | |
776 | L : constant Field_Offset := 16; | |
777 | ||
778 | pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L)); | |
779 | ||
780 | subtype Offset_In_Slot is Field_Offset range 0 .. L - 1; | |
781 | S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); | |
782 | begin | |
783 | case Offset_In_Slot'(Offset mod L) is | |
784 | when 0 => S.Slot_2.F0 := Val; | |
785 | when 1 => S.Slot_2.F1 := Val; | |
786 | when 2 => S.Slot_2.F2 := Val; | |
787 | when 3 => S.Slot_2.F3 := Val; | |
788 | when 4 => S.Slot_2.F4 := Val; | |
789 | when 5 => S.Slot_2.F5 := Val; | |
790 | when 6 => S.Slot_2.F6 := Val; | |
791 | when 7 => S.Slot_2.F7 := Val; | |
792 | when 8 => S.Slot_2.F8 := Val; | |
793 | when 9 => S.Slot_2.F9 := Val; | |
794 | when 10 => S.Slot_2.F10 := Val; | |
795 | when 11 => S.Slot_2.F11 := Val; | |
796 | when 12 => S.Slot_2.F12 := Val; | |
797 | when 13 => S.Slot_2.F13 := Val; | |
798 | when 14 => S.Slot_2.F14 := Val; | |
799 | when 15 => S.Slot_2.F15 := Val; | |
800 | end case; | |
801 | end Set_2_Bit_Val; | |
f1a3590e | 802 | |
76f9c7f4 BD |
803 | procedure Set_4_Bit_Val |
804 | (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_4_Bit) | |
805 | is | |
806 | L : constant Field_Offset := 8; | |
807 | ||
808 | pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L)); | |
809 | ||
810 | subtype Offset_In_Slot is Field_Offset range 0 .. L - 1; | |
811 | S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); | |
812 | begin | |
813 | case Offset_In_Slot'(Offset mod L) is | |
814 | when 0 => S.Slot_4.F0 := Val; | |
815 | when 1 => S.Slot_4.F1 := Val; | |
816 | when 2 => S.Slot_4.F2 := Val; | |
817 | when 3 => S.Slot_4.F3 := Val; | |
818 | when 4 => S.Slot_4.F4 := Val; | |
819 | when 5 => S.Slot_4.F5 := Val; | |
820 | when 6 => S.Slot_4.F6 := Val; | |
821 | when 7 => S.Slot_4.F7 := Val; | |
822 | end case; | |
823 | end Set_4_Bit_Val; | |
f1a3590e | 824 | |
76f9c7f4 BD |
825 | procedure Set_8_Bit_Val |
826 | (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_8_Bit) | |
827 | is | |
828 | L : constant Field_Offset := 4; | |
d23b8f57 | 829 | |
76f9c7f4 | 830 | pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L)); |
d23b8f57 | 831 | |
76f9c7f4 BD |
832 | subtype Offset_In_Slot is Field_Offset range 0 .. L - 1; |
833 | S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); | |
834 | begin | |
835 | case Offset_In_Slot'(Offset mod L) is | |
836 | when 0 => S.Slot_8.F0 := Val; | |
837 | when 1 => S.Slot_8.F1 := Val; | |
838 | when 2 => S.Slot_8.F2 := Val; | |
839 | when 3 => S.Slot_8.F3 := Val; | |
840 | end case; | |
841 | end Set_8_Bit_Val; | |
842 | ||
843 | procedure Set_32_Bit_Val | |
844 | (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_32_Bit) | |
845 | is | |
846 | pragma Debug (Validate_Node_And_Offset_Write (N, Offset)); | |
847 | ||
848 | S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset); | |
849 | begin | |
850 | S.Slot_32 := Val; | |
851 | end Set_32_Bit_Val; | |
852 | ||
853 | end Atree_Private_Part; | |
854 | ||
855 | --------------- | |
856 | -- Set_Field -- | |
857 | --------------- | |
858 | ||
859 | function Get_Node_Field_Union is new Get_32_Bit_Field (Union_Id) | |
860 | with Inline; | |
861 | -- Called when we don't know whether a field is a Node_Id or a List_Id, | |
862 | -- etc. | |
863 | ||
864 | function Get_Field_Value | |
865 | (N : Node_Id; Field : Node_Field) return Field_32_Bit | |
866 | is | |
867 | pragma Assert (Field_Checking.Field_Present (Nkind (N), Field)); | |
868 | Desc : Field_Descriptor renames Node_Field_Descriptors (Field); | |
d23b8f57 | 869 | |
d23b8f57 | 870 | begin |
76f9c7f4 BD |
871 | case Field_Size (Desc.Kind) is |
872 | when 1 => return Field_32_Bit (Get_1_Bit_Val (N, Desc.Offset)); | |
873 | when 2 => return Field_32_Bit (Get_2_Bit_Val (N, Desc.Offset)); | |
874 | when 4 => return Field_32_Bit (Get_4_Bit_Val (N, Desc.Offset)); | |
875 | when 8 => return Field_32_Bit (Get_8_Bit_Val (N, Desc.Offset)); | |
876 | when others => return Get_32_Bit_Val (N, Desc.Offset); -- 32 | |
877 | end case; | |
878 | end Get_Field_Value; | |
d23b8f57 | 879 | |
76f9c7f4 BD |
880 | procedure Set_Field_Value |
881 | (N : Node_Id; Field : Node_Field; Val : Field_32_Bit) | |
882 | is | |
883 | pragma Assert (Field_Checking.Field_Present (Nkind (N), Field)); | |
884 | Desc : Field_Descriptor renames Node_Field_Descriptors (Field); | |
d23b8f57 | 885 | |
d23b8f57 | 886 | begin |
76f9c7f4 BD |
887 | case Field_Size (Desc.Kind) is |
888 | when 1 => Set_1_Bit_Val (N, Desc.Offset, Field_1_Bit (Val)); | |
889 | when 2 => Set_2_Bit_Val (N, Desc.Offset, Field_2_Bit (Val)); | |
890 | when 4 => Set_4_Bit_Val (N, Desc.Offset, Field_4_Bit (Val)); | |
891 | when 8 => Set_8_Bit_Val (N, Desc.Offset, Field_8_Bit (Val)); | |
892 | when others => Set_32_Bit_Val (N, Desc.Offset, Val); -- 32 | |
893 | end case; | |
894 | end Set_Field_Value; | |
d23b8f57 | 895 | |
76f9c7f4 BD |
896 | procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Field) is |
897 | begin | |
898 | Set_Field_Value (N, Field, 0); | |
899 | end Reinit_Field_To_Zero; | |
d23b8f57 | 900 | |
76f9c7f4 BD |
901 | function Field_Is_Initial_Zero |
902 | (N : Node_Id; Field : Node_Field) return Boolean is | |
903 | begin | |
904 | return Get_Field_Value (N, Field) = 0; | |
905 | end Field_Is_Initial_Zero; | |
d23b8f57 | 906 | |
76f9c7f4 BD |
907 | procedure Reinit_Field_To_Zero |
908 | (N : Node_Id; Field : Entity_Field; Old_Ekind : Entity_Kind_Set) is | |
d23b8f57 | 909 | begin |
76f9c7f4 BD |
910 | pragma Assert (Old_Ekind (Ekind (N)), "Reinit: " & Ekind (N)'Img); |
911 | Reinit_Field_To_Zero (N, Field); | |
912 | end Reinit_Field_To_Zero; | |
7f5e671b | 913 | |
76f9c7f4 BD |
914 | procedure Reinit_Field_To_Zero |
915 | (N : Node_Id; Field : Entity_Field; Old_Ekind : Entity_Kind) is | |
916 | Old_Ekind_Set : Entity_Kind_Set := (others => False); | |
917 | begin | |
918 | Old_Ekind_Set (Old_Ekind) := True; | |
919 | Reinit_Field_To_Zero (N, Field, Old_Ekind => Old_Ekind_Set); | |
920 | end Reinit_Field_To_Zero; | |
d23b8f57 | 921 | |
76f9c7f4 BD |
922 | procedure Check_Vanishing_Fields |
923 | (Old_N : Node_Id; New_Kind : Node_Kind) | |
924 | is | |
925 | Old_Kind : constant Node_Kind := Nkind (Old_N); | |
d23b8f57 | 926 | |
76f9c7f4 BD |
927 | -- If this fails, it means you need to call Reinit_Field_To_Zero before |
928 | -- calling Set_Nkind. | |
43417b90 | 929 | |
76f9c7f4 BD |
930 | begin |
931 | for J in Node_Field_Table (Old_Kind)'Range loop | |
932 | declare | |
933 | F : constant Node_Field := Node_Field_Table (Old_Kind) (J); | |
934 | begin | |
935 | if not Field_Checking.Field_Present (New_Kind, F) then | |
936 | if not Field_Is_Initial_Zero (Old_N, F) then | |
937 | Write_Str (Old_Kind'Img); | |
938 | Write_Str (" --> "); | |
939 | Write_Str (New_Kind'Img); | |
940 | Write_Str (" Nonzero field "); | |
941 | Write_Str (F'Img); | |
942 | Write_Str (" is vanishing"); | |
943 | Write_Eol; | |
4bcf6815 | 944 | |
76f9c7f4 BD |
945 | raise Program_Error; |
946 | end if; | |
947 | end if; | |
948 | end; | |
949 | end loop; | |
950 | end Check_Vanishing_Fields; | |
4bcf6815 | 951 | |
76f9c7f4 BD |
952 | function Get_Field_Value |
953 | (N : Entity_Id; Field : Entity_Field) return Field_32_Bit | |
954 | is | |
955 | pragma Assert (Field_Checking.Field_Present (Ekind (N), Field)); | |
956 | Desc : Field_Descriptor renames Entity_Field_Descriptors (Field); | |
957 | begin | |
958 | case Field_Size (Desc.Kind) is | |
959 | when 1 => return Field_32_Bit (Get_1_Bit_Val (N, Desc.Offset)); | |
960 | when 2 => return Field_32_Bit (Get_2_Bit_Val (N, Desc.Offset)); | |
961 | when 4 => return Field_32_Bit (Get_4_Bit_Val (N, Desc.Offset)); | |
962 | when 8 => return Field_32_Bit (Get_8_Bit_Val (N, Desc.Offset)); | |
963 | when others => return Get_32_Bit_Val (N, Desc.Offset); -- 32 | |
964 | end case; | |
965 | end Get_Field_Value; | |
d23b8f57 | 966 | |
76f9c7f4 BD |
967 | procedure Set_Field_Value |
968 | (N : Entity_Id; Field : Entity_Field; Val : Field_32_Bit) | |
969 | is | |
970 | pragma Assert (Field_Checking.Field_Present (Ekind (N), Field)); | |
971 | Desc : Field_Descriptor renames Entity_Field_Descriptors (Field); | |
972 | begin | |
973 | case Field_Size (Desc.Kind) is | |
974 | when 1 => Set_1_Bit_Val (N, Desc.Offset, Field_1_Bit (Val)); | |
975 | when 2 => Set_2_Bit_Val (N, Desc.Offset, Field_2_Bit (Val)); | |
976 | when 4 => Set_4_Bit_Val (N, Desc.Offset, Field_4_Bit (Val)); | |
977 | when 8 => Set_8_Bit_Val (N, Desc.Offset, Field_8_Bit (Val)); | |
978 | when others => Set_32_Bit_Val (N, Desc.Offset, Val); -- 32 | |
979 | end case; | |
980 | end Set_Field_Value; | |
d23b8f57 | 981 | |
76f9c7f4 BD |
982 | procedure Reinit_Field_To_Zero (N : Node_Id; Field : Entity_Field) is |
983 | begin | |
984 | Set_Field_Value (N, Field, 0); | |
985 | end Reinit_Field_To_Zero; | |
d23b8f57 | 986 | |
76f9c7f4 BD |
987 | function Field_Is_Initial_Zero |
988 | (N : Entity_Id; Field : Entity_Field) return Boolean is | |
989 | begin | |
990 | return Get_Field_Value (N, Field) = 0; | |
991 | end Field_Is_Initial_Zero; | |
d23b8f57 | 992 | |
76f9c7f4 BD |
993 | procedure Check_Vanishing_Fields |
994 | (Old_N : Entity_Id; New_Kind : Entity_Kind) | |
995 | is | |
996 | Old_Kind : constant Entity_Kind := Ekind (Old_N); | |
d23b8f57 | 997 | |
76f9c7f4 BD |
998 | -- If this fails, it means you need to call Reinit_Field_To_Zero before |
999 | -- calling Set_Ekind. | |
165eab5f | 1000 | |
76f9c7f4 BD |
1001 | begin |
1002 | for J in Entity_Field_Table (Old_Kind)'Range loop | |
1003 | declare | |
1004 | F : constant Entity_Field := Entity_Field_Table (Old_Kind) (J); | |
1005 | begin | |
1006 | if not Field_Checking.Field_Present (New_Kind, F) then | |
1007 | if not Field_Is_Initial_Zero (Old_N, F) then | |
1008 | Write_Str (Old_Kind'Img); | |
1009 | Write_Str (" --> "); | |
1010 | Write_Str (New_Kind'Img); | |
1011 | Write_Str (" Nonzero field "); | |
1012 | Write_Str (F'Img); | |
1013 | Write_Str (" is vanishing"); | |
1014 | Write_Eol; | |
d23b8f57 | 1015 | |
76f9c7f4 | 1016 | pragma Assert (New_Kind = E_Void or else Old_Kind = E_Void); |
d23b8f57 | 1017 | |
76f9c7f4 BD |
1018 | raise Program_Error; |
1019 | end if; | |
d23b8f57 | 1020 | end if; |
76f9c7f4 BD |
1021 | end; |
1022 | end loop; | |
1023 | end Check_Vanishing_Fields; | |
d23b8f57 | 1024 | |
76f9c7f4 BD |
1025 | Nkind_Offset : constant Field_Offset := |
1026 | Node_Field_Descriptors (Nkind).Offset; | |
d23b8f57 | 1027 | |
76f9c7f4 | 1028 | procedure Set_Nkind_Type is new Set_8_Bit_Field (Node_Kind) with Inline; |
165eab5f | 1029 | |
76f9c7f4 BD |
1030 | procedure Init_Nkind (N : Node_Id; Val : Node_Kind) is |
1031 | pragma Assert (Field_Is_Initial_Zero (N, Nkind)); | |
d23b8f57 | 1032 | begin |
76f9c7f4 BD |
1033 | Set_Nkind_Type (N, Nkind_Offset, Val); |
1034 | end Init_Nkind; | |
83dcc2bd | 1035 | |
76f9c7f4 BD |
1036 | procedure Mutate_Nkind |
1037 | (N : Node_Id; Val : Node_Kind) | |
1038 | is | |
1039 | Old_Size : constant Field_Offset := Size_In_Slots (N); | |
1040 | New_Size : constant Field_Offset := Size_In_Slots_To_Alloc (Val); | |
83dcc2bd | 1041 | |
76f9c7f4 BD |
1042 | All_Node_Offsets : Node_Offsets.Table_Type renames |
1043 | Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); | |
1044 | begin | |
1045 | pragma Debug (Check_Vanishing_Fields (N, Val)); | |
83dcc2bd | 1046 | |
76f9c7f4 | 1047 | -- Grow the slots if necessary |
7f5e671b | 1048 | |
76f9c7f4 BD |
1049 | if Old_Size < New_Size then |
1050 | declare | |
1051 | Old_Last_Slot : constant Node_Offset := Slots.Last; | |
1052 | Old_Off_0 : constant Node_Offset := Off_0 (N); | |
1053 | begin | |
1054 | if Old_Last_Slot = Old_Off_0 + Old_Size - 1 then | |
1055 | -- In this case, the slots are at the end of Slots.Table, so we | |
1056 | -- don't need to move them. | |
1057 | Slots.Set_Last (Old_Last_Slot + New_Size - Old_Size); | |
7f5e671b | 1058 | |
76f9c7f4 BD |
1059 | else |
1060 | -- Move the slots | |
1061 | All_Node_Offsets (N) := Alloc_Slots (New_Size); | |
1062 | Copy_Slots (Old_Off_0, Off_0 (N), Old_Size); | |
1063 | pragma Debug (Zero_Slots (Old_Off_0, Old_Off_0 + Old_Size - 1)); | |
1064 | end if; | |
1065 | end; | |
d23b8f57 | 1066 | |
76f9c7f4 BD |
1067 | Zero_Slots (Off_0 (N) + Old_Size, Slots.Last); |
1068 | end if; | |
d23b8f57 | 1069 | |
76f9c7f4 BD |
1070 | Set_Nkind_Type (N, Nkind_Offset, Val); |
1071 | pragma Debug (Validate_Node_Write (N)); | |
1072 | end Mutate_Nkind; | |
83dcc2bd | 1073 | |
76f9c7f4 BD |
1074 | Ekind_Offset : constant Field_Offset := |
1075 | Entity_Field_Descriptors (Ekind).Offset; | |
d23b8f57 | 1076 | |
76f9c7f4 | 1077 | procedure Set_Ekind_Type is new Set_8_Bit_Field (Entity_Kind) with Inline; |
165eab5f | 1078 | |
76f9c7f4 BD |
1079 | procedure Set_Ekind |
1080 | (N : Entity_Id; Val : Entity_Kind) | |
1081 | is | |
1082 | begin | |
1083 | if Ekind (N) = Val then | |
1084 | return; | |
1085 | end if; | |
7324bf49 | 1086 | |
76f9c7f4 BD |
1087 | if Debug_Flag_Underscore_V then |
1088 | pragma Debug (Check_Vanishing_Fields (N, Val)); | |
1089 | end if; | |
d23b8f57 | 1090 | |
76f9c7f4 BD |
1091 | -- For now, we are allocating all entities with the same size, so we |
1092 | -- don't need to reallocate slots here. | |
d23b8f57 | 1093 | |
76f9c7f4 BD |
1094 | Set_Ekind_Type (N, Ekind_Offset, Val); |
1095 | pragma Debug (Validate_Node_Write (N)); | |
1096 | end Set_Ekind; | |
d23b8f57 | 1097 | |
76f9c7f4 BD |
1098 | ----------------------- |
1099 | -- Allocate_New_Node -- | |
1100 | ----------------------- | |
165eab5f | 1101 | |
76f9c7f4 | 1102 | function Allocate_New_Node (Kind : Node_Kind) return Node_Id is |
d23b8f57 | 1103 | begin |
76f9c7f4 BD |
1104 | return Result : constant Node_Id := Alloc_Node_Id do |
1105 | declare | |
1106 | Sz : constant Field_Offset := Size_In_Slots_To_Alloc (Kind); | |
1107 | Sl : constant Node_Offset := Alloc_Slots (Sz); | |
1108 | begin | |
1109 | Node_Offsets.Table (Result) := Sl; | |
1110 | Zero_Slots (Sl, Sl + Sz - 1); | |
1111 | end; | |
d23b8f57 | 1112 | |
76f9c7f4 | 1113 | Init_Nkind (Result, Kind); |
4bcf6815 | 1114 | |
76f9c7f4 BD |
1115 | Orig_Nodes.Append (Result); |
1116 | Set_Comes_From_Source (Result, Comes_From_Source_Default); | |
1117 | Allocate_List_Tables (Result); | |
1118 | Report (Target => Result, Source => Empty); | |
1119 | end return; | |
1120 | end Allocate_New_Node; | |
4bcf6815 | 1121 | |
76f9c7f4 BD |
1122 | -------------------------- |
1123 | -- Check_Error_Detected -- | |
1124 | -------------------------- | |
d23b8f57 | 1125 | |
76f9c7f4 | 1126 | procedure Check_Error_Detected is |
d23b8f57 | 1127 | begin |
76f9c7f4 BD |
1128 | -- An anomaly has been detected which is assumed to be a consequence of |
1129 | -- a previous serious error or configurable run time violation. Raise | |
1130 | -- an exception if no such error has been detected. | |
1131 | ||
1132 | if Serious_Errors_Detected = 0 | |
1133 | and then Configurable_Run_Time_Violations = 0 | |
1134 | then | |
1135 | raise Program_Error; | |
1136 | end if; | |
1137 | end Check_Error_Detected; | |
d23b8f57 | 1138 | |
c159409f | 1139 | ----------------- |
76f9c7f4 | 1140 | -- Change_Node -- |
c159409f AC |
1141 | ----------------- |
1142 | ||
76f9c7f4 BD |
1143 | procedure Change_Node (N : Node_Id; New_Kind : Node_Kind) is |
1144 | pragma Debug (Validate_Node_Write (N)); | |
1145 | pragma Assert (Nkind (N) not in N_Entity); | |
1146 | pragma Assert (New_Kind not in N_Entity); | |
c159409f | 1147 | |
76f9c7f4 BD |
1148 | Old_Size : constant Field_Offset := Size_In_Slots (N); |
1149 | New_Size : constant Field_Offset := Size_In_Slots_To_Alloc (New_Kind); | |
1150 | ||
1151 | Save_Sloc : constant Source_Ptr := Sloc (N); | |
1152 | Save_In_List : constant Boolean := In_List (N); | |
1153 | Save_CFS : constant Boolean := Comes_From_Source (N); | |
1154 | Save_Posted : constant Boolean := Error_Posted (N); | |
1155 | Save_CA : constant Boolean := Check_Actuals (N); | |
1156 | Save_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (N); | |
1157 | Save_Link : constant Union_Id := Link (N); | |
1158 | ||
1159 | Par_Count : Nat := 0; | |
d23b8f57 | 1160 | |
d23b8f57 | 1161 | begin |
76f9c7f4 BD |
1162 | if Nkind (N) in N_Subexpr then |
1163 | Par_Count := Paren_Count (N); | |
1164 | end if; | |
d23b8f57 | 1165 | |
76f9c7f4 BD |
1166 | if New_Size > Old_Size then |
1167 | pragma Debug (Zero_Slots (N)); | |
1168 | Node_Offsets.Table (N) := Alloc_Slots (New_Size); | |
1169 | end if; | |
d23b8f57 | 1170 | |
76f9c7f4 | 1171 | Zero_Slots (N); |
d23b8f57 | 1172 | |
76f9c7f4 | 1173 | Mutate_Nkind (N, New_Kind); |
fbf5a39b | 1174 | |
76f9c7f4 BD |
1175 | Set_Sloc (N, Save_Sloc); |
1176 | Set_In_List (N, Save_In_List); | |
1177 | Set_Comes_From_Source (N, Save_CFS); | |
1178 | Set_Error_Posted (N, Save_Posted); | |
1179 | Set_Check_Actuals (N, Save_CA); | |
1180 | Set_Is_Ignored_Ghost_Node (N, Save_Is_IGN); | |
1181 | Set_Link (N, Save_Link); | |
d23b8f57 | 1182 | |
76f9c7f4 BD |
1183 | if New_Kind in N_Subexpr then |
1184 | Set_Paren_Count (N, Par_Count); | |
1185 | end if; | |
1186 | end Change_Node; | |
5c736541 | 1187 | |
76f9c7f4 BD |
1188 | --------------- |
1189 | -- Copy_Node -- | |
1190 | --------------- | |
5c736541 | 1191 | |
76f9c7f4 BD |
1192 | procedure Copy_Slots (From, To, Num_Slots : Node_Offset) is |
1193 | pragma Assert (From /= To); | |
d23b8f57 | 1194 | |
76f9c7f4 BD |
1195 | All_Slots : Slots.Table_Type renames |
1196 | Slots.Table (Slots.First .. Slots.Last); | |
8636f52f | 1197 | |
76f9c7f4 BD |
1198 | Source_Slots : Slots.Table_Type renames |
1199 | All_Slots (From .. From + Num_Slots - 1); | |
8636f52f | 1200 | |
76f9c7f4 BD |
1201 | Destination_Slots : Slots.Table_Type renames |
1202 | All_Slots (To .. To + Num_Slots - 1); | |
d23b8f57 | 1203 | |
d23b8f57 | 1204 | begin |
76f9c7f4 BD |
1205 | Destination_Slots := Source_Slots; |
1206 | end Copy_Slots; | |
d23b8f57 | 1207 | |
76f9c7f4 BD |
1208 | procedure Copy_Slots (Source, Destination : Node_Id) is |
1209 | pragma Debug (Validate_Node (Source)); | |
1210 | pragma Debug (Validate_Node_Write (Destination)); | |
1211 | pragma Assert (Source /= Destination); | |
d23b8f57 | 1212 | |
76f9c7f4 | 1213 | S_Size : constant Field_Offset := Size_In_Slots (Source); |
d23b8f57 | 1214 | |
76f9c7f4 BD |
1215 | All_Node_Offsets : Node_Offsets.Table_Type renames |
1216 | Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); | |
d23b8f57 | 1217 | |
d23b8f57 | 1218 | begin |
76f9c7f4 BD |
1219 | Copy_Slots |
1220 | (All_Node_Offsets (Source), All_Node_Offsets (Destination), S_Size); | |
1221 | end Copy_Slots; | |
d23b8f57 | 1222 | |
76f9c7f4 BD |
1223 | --------------- |
1224 | -- Copy_Node -- | |
1225 | --------------- | |
d23b8f57 | 1226 | |
76f9c7f4 BD |
1227 | procedure Copy_Node (Source, Destination : Node_Or_Entity_Id) is |
1228 | pragma Debug (New_Node_Debugging_Output (Source)); | |
1229 | pragma Debug (New_Node_Debugging_Output (Destination)); | |
d23b8f57 | 1230 | |
76f9c7f4 | 1231 | pragma Assert (Source /= Destination); |
f68fc405 | 1232 | |
76f9c7f4 BD |
1233 | Save_In_List : constant Boolean := In_List (Destination); |
1234 | Save_Link : constant Union_Id := Link (Destination); | |
f68fc405 | 1235 | |
76f9c7f4 BD |
1236 | S_Size : constant Field_Offset := Size_In_Slots_To_Alloc (Source); |
1237 | D_Size : constant Field_Offset := Size_In_Slots_To_Alloc (Destination); | |
d65a80fd | 1238 | |
d65a80fd | 1239 | begin |
76f9c7f4 BD |
1240 | -- Currently all entities are allocated the same number of slots. |
1241 | -- Hopefully that won't always be the case, but if it is, the following | |
1242 | -- is suboptimal if D_Size < S_Size, because in fact the Destination was | |
1243 | -- allocated the max. | |
d65a80fd | 1244 | |
76f9c7f4 | 1245 | -- If Source doesn't fit in Destination, we need to allocate |
d65a80fd | 1246 | |
76f9c7f4 BD |
1247 | if D_Size < S_Size then |
1248 | pragma Debug (Zero_Slots (Destination)); -- destroy old slots | |
1249 | Node_Offsets.Table (Destination) := Alloc_Slots (S_Size); | |
1250 | end if; | |
d65a80fd | 1251 | |
76f9c7f4 | 1252 | Copy_Slots (Source, Destination); |
980f94b7 | 1253 | |
76f9c7f4 BD |
1254 | Set_In_List (Destination, Save_In_List); |
1255 | Set_Link (Destination, Save_Link); | |
980f94b7 | 1256 | |
76f9c7f4 BD |
1257 | Set_Paren_Count_Of_Copy (Target => Destination, Source => Source); |
1258 | end Copy_Node; | |
d65a80fd | 1259 | |
76f9c7f4 BD |
1260 | ------------------------ |
1261 | -- Copy_Separate_List -- | |
1262 | ------------------------ | |
1263 | ||
1264 | function Copy_Separate_List (Source : List_Id) return List_Id is | |
1265 | Result : constant List_Id := New_List; | |
1266 | Nod : Node_Id := First (Source); | |
d23b8f57 | 1267 | |
d23b8f57 | 1268 | begin |
76f9c7f4 BD |
1269 | while Present (Nod) loop |
1270 | Append (Copy_Separate_Tree (Nod), Result); | |
1271 | Next (Nod); | |
1272 | end loop; | |
d23b8f57 | 1273 | |
76f9c7f4 BD |
1274 | return Result; |
1275 | end Copy_Separate_List; | |
d23b8f57 | 1276 | |
76f9c7f4 BD |
1277 | ------------------------ |
1278 | -- Copy_Separate_Tree -- | |
1279 | ------------------------ | |
d23b8f57 | 1280 | |
76f9c7f4 | 1281 | function Copy_Separate_Tree (Source : Node_Id) return Node_Id is |
d23b8f57 | 1282 | |
76f9c7f4 | 1283 | pragma Debug (Validate_Node (Source)); |
d23b8f57 | 1284 | |
76f9c7f4 | 1285 | New_Id : Node_Id; |
718deaf1 | 1286 | |
76f9c7f4 BD |
1287 | function Copy_Entity (E : Entity_Id) return Entity_Id; |
1288 | -- Copy Entity, copying only Chars field | |
4230bdb7 | 1289 | |
76f9c7f4 BD |
1290 | function Copy_List (List : List_Id) return List_Id; |
1291 | -- Copy list | |
4230bdb7 | 1292 | |
76f9c7f4 BD |
1293 | function Possible_Copy (Field : Union_Id) return Union_Id; |
1294 | -- Given a field, returns a copy of the node or list if its parent is | |
1295 | -- the current source node, and otherwise returns the input. | |
718deaf1 | 1296 | |
76f9c7f4 BD |
1297 | ----------------- |
1298 | -- Copy_Entity -- | |
1299 | ----------------- | |
d65a80fd | 1300 | |
76f9c7f4 BD |
1301 | function Copy_Entity (E : Entity_Id) return Entity_Id is |
1302 | begin | |
1303 | pragma Assert (Nkind (E) in N_Entity); | |
d65a80fd | 1304 | |
76f9c7f4 BD |
1305 | return Result : constant Entity_Id := New_Entity (Nkind (E), Sloc (E)) |
1306 | do | |
1307 | Set_Chars (Result, Chars (E)); | |
1308 | end return; | |
1309 | end Copy_Entity; | |
7324bf49 | 1310 | |
76f9c7f4 BD |
1311 | --------------- |
1312 | -- Copy_List -- | |
1313 | --------------- | |
83dcc2bd | 1314 | |
76f9c7f4 BD |
1315 | function Copy_List (List : List_Id) return List_Id is |
1316 | NL : List_Id; | |
1317 | E : Node_Id; | |
83dcc2bd | 1318 | |
76f9c7f4 BD |
1319 | begin |
1320 | if List = No_List then | |
1321 | return No_List; | |
83dcc2bd | 1322 | |
76f9c7f4 BD |
1323 | else |
1324 | NL := New_List; | |
83dcc2bd | 1325 | |
76f9c7f4 BD |
1326 | E := First (List); |
1327 | while Present (E) loop | |
1328 | if Is_Entity (E) then | |
1329 | Append (Copy_Entity (E), NL); | |
1330 | else | |
1331 | Append (Copy_Separate_Tree (E), NL); | |
1332 | end if; | |
d23b8f57 | 1333 | |
76f9c7f4 BD |
1334 | Next (E); |
1335 | end loop; | |
d23b8f57 | 1336 | |
76f9c7f4 BD |
1337 | return NL; |
1338 | end if; | |
1339 | end Copy_List; | |
d23b8f57 | 1340 | |
76f9c7f4 BD |
1341 | ------------------- |
1342 | -- Possible_Copy -- | |
1343 | ------------------- | |
83dcc2bd | 1344 | |
76f9c7f4 BD |
1345 | function Possible_Copy (Field : Union_Id) return Union_Id is |
1346 | New_N : Union_Id; | |
fbf5a39b | 1347 | |
76f9c7f4 BD |
1348 | begin |
1349 | if Field in Node_Range then | |
1350 | New_N := Union_Id (Copy_Separate_Tree (Node_Id (Field))); | |
fbf5a39b | 1351 | |
76f9c7f4 BD |
1352 | if Parent (Node_Id (Field)) = Source then |
1353 | Set_Parent (Node_Id (New_N), New_Id); | |
1354 | end if; | |
fbf5a39b | 1355 | |
76f9c7f4 | 1356 | return New_N; |
d23b8f57 | 1357 | |
76f9c7f4 BD |
1358 | elsif Field in List_Range then |
1359 | New_N := Union_Id (Copy_List (List_Id (Field))); | |
d65a80fd | 1360 | |
76f9c7f4 BD |
1361 | if Parent (List_Id (Field)) = Source then |
1362 | Set_Parent (List_Id (New_N), New_Id); | |
1363 | end if; | |
d65a80fd | 1364 | |
76f9c7f4 | 1365 | return New_N; |
d23b8f57 | 1366 | |
76f9c7f4 BD |
1367 | else |
1368 | return Field; | |
1369 | end if; | |
1370 | end Possible_Copy; | |
d23b8f57 | 1371 | |
76f9c7f4 | 1372 | procedure Walk is new Walk_Sinfo_Fields_Pairwise (Possible_Copy); |
d23b8f57 | 1373 | |
76f9c7f4 | 1374 | -- Start of processing for Copy_Separate_Tree |
fbf5a39b | 1375 | |
76f9c7f4 BD |
1376 | begin |
1377 | if Source <= Empty_Or_Error then | |
1378 | return Source; | |
fbf5a39b | 1379 | |
76f9c7f4 BD |
1380 | elsif Is_Entity (Source) then |
1381 | return Copy_Entity (Source); | |
d65a80fd | 1382 | |
76f9c7f4 BD |
1383 | else |
1384 | New_Id := New_Copy (Source); | |
d65a80fd | 1385 | |
76f9c7f4 | 1386 | Walk (New_Id, Source); |
d23b8f57 | 1387 | |
76f9c7f4 BD |
1388 | -- Explicitly copy the aspect specifications as those do not reside |
1389 | -- in a node field. | |
4cd52f5e | 1390 | |
76f9c7f4 BD |
1391 | if Permits_Aspect_Specifications (Source) |
1392 | and then Has_Aspects (Source) | |
1393 | then | |
1394 | Set_Aspect_Specifications | |
1395 | (New_Id, Copy_List (Aspect_Specifications (Source))); | |
1396 | end if; | |
4cd52f5e | 1397 | |
76f9c7f4 BD |
1398 | -- Set Entity field to Empty to ensure that no entity references |
1399 | -- are shared between the two, if the source is already analyzed. | |
4cd52f5e | 1400 | |
76f9c7f4 BD |
1401 | if Nkind (New_Id) in N_Has_Entity |
1402 | or else Nkind (New_Id) = N_Freeze_Entity | |
1403 | then | |
1404 | Set_Entity (New_Id, Empty); | |
1405 | end if; | |
4cd52f5e | 1406 | |
76f9c7f4 BD |
1407 | -- Reset all Etype fields and Analyzed flags, because input tree may |
1408 | -- have been fully or partially analyzed. | |
4cd52f5e | 1409 | |
76f9c7f4 BD |
1410 | if Nkind (New_Id) in N_Has_Etype then |
1411 | Set_Etype (New_Id, Empty); | |
4cd52f5e | 1412 | end if; |
4cd52f5e | 1413 | |
76f9c7f4 | 1414 | Set_Analyzed (New_Id, False); |
d23b8f57 | 1415 | |
76f9c7f4 BD |
1416 | -- Rather special case, if we have an expanded name, then change |
1417 | -- it back into a selected component, so that the tree looks the | |
1418 | -- way it did coming out of the parser. This will change back | |
1419 | -- when we analyze the selected component node. | |
d23b8f57 | 1420 | |
76f9c7f4 | 1421 | if Nkind (New_Id) = N_Expanded_Name then |
d23b8f57 | 1422 | |
76f9c7f4 BD |
1423 | -- The following code is a bit kludgy. It would be cleaner to |
1424 | -- Add an entry Change_Expanded_Name_To_Selected_Component to | |
1425 | -- Sinfo.CN, but that's delicate because Atree is used in the | |
1426 | -- binder, so we don't want to add that dependency. | |
1427 | -- ??? Revisit now that ASIS is no longer using this unit. | |
d23b8f57 | 1428 | |
76f9c7f4 BD |
1429 | -- Consequently we have no choice but to hold our noses and do the |
1430 | -- change manually. At least we are Atree, so this is at least all | |
1431 | -- in the family. | |
06f2efd7 | 1432 | |
76f9c7f4 BD |
1433 | -- Clear the Chars field which is not present in a selected |
1434 | -- component node, so we don't want a junk value around. Note that | |
1435 | -- we can't just call Set_Chars, because Empty is of the wrong | |
1436 | -- type, and is outside the range of Name_Id. | |
06f2efd7 | 1437 | |
76f9c7f4 BD |
1438 | Reinit_Field_To_Zero (New_Id, Chars); |
1439 | Reinit_Field_To_Zero (New_Id, Has_Private_View); | |
1440 | Reinit_Field_To_Zero (New_Id, Is_Elaboration_Checks_OK_Node); | |
1441 | Reinit_Field_To_Zero (New_Id, Is_Elaboration_Warnings_OK_Node); | |
1442 | Reinit_Field_To_Zero (New_Id, Is_SPARK_Mode_On_Node); | |
06f2efd7 | 1443 | |
76f9c7f4 | 1444 | -- Change the node type |
06f2efd7 | 1445 | |
76f9c7f4 BD |
1446 | Mutate_Nkind (New_Id, N_Selected_Component); |
1447 | end if; | |
d23b8f57 | 1448 | |
76f9c7f4 | 1449 | -- All done, return copied node |
d23b8f57 | 1450 | |
76f9c7f4 BD |
1451 | return New_Id; |
1452 | end if; | |
1453 | end Copy_Separate_Tree; | |
d23b8f57 | 1454 | |
76f9c7f4 BD |
1455 | ----------------------- |
1456 | -- Exchange_Entities -- | |
1457 | ----------------------- | |
83dcc2bd | 1458 | |
76f9c7f4 BD |
1459 | procedure Exchange_Entities (E1 : Entity_Id; E2 : Entity_Id) is |
1460 | pragma Debug (New_Node_Debugging_Output (E1)); | |
1461 | pragma Debug (New_Node_Debugging_Output (E2)); | |
d23b8f57 | 1462 | |
76f9c7f4 BD |
1463 | pragma Debug (Validate_Node_Write (E1)); |
1464 | pragma Debug (Validate_Node_Write (E2)); | |
1465 | pragma Assert | |
1466 | (Is_Entity (E1) and then Is_Entity (E2) | |
1467 | and then not In_List (E1) and then not In_List (E2)); | |
1468 | ||
1469 | Old_E1 : constant Node_Offset := Node_Offsets.Table (E1); | |
d23b8f57 | 1470 | |
d23b8f57 | 1471 | begin |
76f9c7f4 BD |
1472 | Node_Offsets.Table (E1) := Node_Offsets.Table (E2); |
1473 | Node_Offsets.Table (E2) := Old_E1; | |
1474 | ||
1475 | -- That exchange exchanged the parent pointers as well, which is what | |
1476 | -- we want, but we need to patch up the defining identifier pointers | |
1477 | -- in the parent nodes (the child pointers) to match this switch | |
1478 | -- unless for Implicit types entities which have no parent, in which | |
1479 | -- case we don't do anything otherwise we won't be able to revert back | |
1480 | -- to the original situation. | |
1481 | ||
1482 | -- Shouldn't this use Is_Itype instead of the Parent test??? | |
1483 | ||
1484 | if Present (Parent (E1)) and then Present (Parent (E2)) then | |
1485 | Set_Defining_Identifier (Parent (E1), E1); | |
1486 | Set_Defining_Identifier (Parent (E2), E2); | |
1487 | end if; | |
1488 | end Exchange_Entities; | |
d23b8f57 RK |
1489 | |
1490 | ----------------- | |
76f9c7f4 | 1491 | -- Extend_Node -- |
d23b8f57 RK |
1492 | ----------------- |
1493 | ||
76f9c7f4 BD |
1494 | procedure Extend_Node (Source : Node_Id) is |
1495 | pragma Assert (Present (Source)); | |
1496 | pragma Assert (not Is_Entity (Source)); | |
1497 | ||
1498 | Old_Kind : constant Node_Kind := Nkind (Source); | |
1499 | New_Kind : constant Node_Kind := | |
1500 | (case Old_Kind is | |
1501 | when N_Character_Literal => N_Defining_Character_Literal, | |
1502 | when N_Identifier => N_Defining_Identifier, | |
1503 | when N_Operator_Symbol => N_Defining_Operator_Symbol, | |
1504 | when others => N_Abort_Statement); -- can't happen | |
1505 | -- The new NKind, which is the appropriate value of N_Entity based on | |
1506 | -- the old Nkind. N_xxx is mapped to N_Defining_xxx. | |
1507 | pragma Assert (New_Kind in N_Entity); | |
1508 | ||
1509 | -- Start of processing for Extend_Node | |
d23b8f57 RK |
1510 | |
1511 | begin | |
76f9c7f4 BD |
1512 | Set_Check_Actuals (Source, False); |
1513 | Mutate_Nkind (Source, New_Kind); | |
1514 | Report (Target => Source, Source => Source); | |
1515 | end Extend_Node; | |
d23b8f57 | 1516 | |
76f9c7f4 BD |
1517 | ----------------- |
1518 | -- Fix_Parents -- | |
1519 | ----------------- | |
d23b8f57 | 1520 | |
76f9c7f4 BD |
1521 | procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id) is |
1522 | pragma Assert (Nkind (Ref_Node) = Nkind (Fix_Node)); | |
d23b8f57 | 1523 | |
76f9c7f4 BD |
1524 | procedure Fix_Parent (Field : Union_Id); |
1525 | -- Fix up one parent pointer. Field is checked to see if it points to | |
1526 | -- a node, list, or element list that has a parent that points to | |
1527 | -- Ref_Node. If so, the parent is reset to point to Fix_Node. | |
8133b9d1 | 1528 | |
76f9c7f4 BD |
1529 | ---------------- |
1530 | -- Fix_Parent -- | |
1531 | ---------------- | |
8133b9d1 | 1532 | |
76f9c7f4 BD |
1533 | procedure Fix_Parent (Field : Union_Id) is |
1534 | begin | |
1535 | -- Fix parent of node that is referenced by Field. Note that we must | |
1536 | -- exclude the case where the node is a member of a list, because in | |
1537 | -- this case the parent is the parent of the list. | |
8133b9d1 | 1538 | |
76f9c7f4 BD |
1539 | if Field in Node_Range |
1540 | and then Present (Node_Id (Field)) | |
1541 | and then not In_List (Node_Id (Field)) | |
1542 | and then Parent (Node_Id (Field)) = Ref_Node | |
1543 | then | |
1544 | Set_Parent (Node_Id (Field), Fix_Node); | |
8133b9d1 | 1545 | |
76f9c7f4 | 1546 | -- Fix parent of list that is referenced by Field |
d23b8f57 | 1547 | |
76f9c7f4 BD |
1548 | elsif Field in List_Range |
1549 | and then Present (List_Id (Field)) | |
1550 | and then Parent (List_Id (Field)) = Ref_Node | |
1551 | then | |
1552 | Set_Parent (List_Id (Field), Fix_Node); | |
1553 | end if; | |
1554 | end Fix_Parent; | |
1555 | ||
1556 | Fields : Node_Field_Array renames | |
1557 | Node_Field_Table (Nkind (Fix_Node)).all; | |
1558 | ||
1559 | -- Start of processing for Fix_Parents | |
d23b8f57 | 1560 | |
d23b8f57 | 1561 | begin |
76f9c7f4 BD |
1562 | for J in Fields'Range loop |
1563 | declare | |
1564 | Desc : Field_Descriptor renames | |
1565 | Node_Field_Descriptors (Fields (J)); | |
1566 | begin | |
1567 | if Desc.Kind in Node_Id_Field | List_Id_Field then | |
1568 | Fix_Parent (Get_Node_Field_Union (Fix_Node, Desc.Offset)); | |
1569 | end if; | |
1570 | end; | |
1571 | end loop; | |
1572 | end Fix_Parents; | |
d23b8f57 | 1573 | |
76f9c7f4 BD |
1574 | ----------------------------------- |
1575 | -- Get_Comes_From_Source_Default -- | |
1576 | ----------------------------------- | |
d23b8f57 | 1577 | |
76f9c7f4 | 1578 | function Get_Comes_From_Source_Default return Boolean is |
d23b8f57 | 1579 | begin |
76f9c7f4 BD |
1580 | return Comes_From_Source_Default; |
1581 | end Get_Comes_From_Source_Default; | |
d23b8f57 | 1582 | |
76f9c7f4 BD |
1583 | --------------- |
1584 | -- Is_Entity -- | |
1585 | --------------- | |
d23b8f57 | 1586 | |
76f9c7f4 | 1587 | function Is_Entity (N : Node_Id) return Boolean is |
d23b8f57 | 1588 | begin |
76f9c7f4 BD |
1589 | return Nkind (N) in N_Entity; |
1590 | end Is_Entity; | |
d23b8f57 | 1591 | |
76f9c7f4 BD |
1592 | ---------------- |
1593 | -- Initialize -- | |
1594 | ---------------- | |
7b47778e | 1595 | |
76f9c7f4 BD |
1596 | procedure Initialize is |
1597 | Dummy : Node_Id; | |
1598 | pragma Warnings (Off, Dummy); | |
7b47778e AC |
1599 | |
1600 | begin | |
76f9c7f4 | 1601 | -- Allocate Empty node |
7b47778e | 1602 | |
76f9c7f4 BD |
1603 | Dummy := New_Node (N_Empty, No_Location); |
1604 | Set_Chars (Empty, No_Name); | |
1605 | pragma Assert (Dummy = Empty); | |
7b47778e | 1606 | |
76f9c7f4 BD |
1607 | -- Allocate Error node, and set Error_Posted, since we certainly |
1608 | -- only generate an Error node if we do post some kind of error. | |
7b47778e | 1609 | |
76f9c7f4 BD |
1610 | Dummy := New_Node (N_Error, No_Location); |
1611 | Set_Chars (Error, Error_Name); | |
1612 | Set_Error_Posted (Error, True); | |
1613 | pragma Assert (Dummy = Error); | |
1614 | end Initialize; | |
7b47778e | 1615 | |
76f9c7f4 BD |
1616 | -------------------------- |
1617 | -- Is_Rewrite_Insertion -- | |
1618 | -------------------------- | |
7b47778e | 1619 | |
76f9c7f4 BD |
1620 | function Is_Rewrite_Insertion (Node : Node_Id) return Boolean is |
1621 | begin | |
1622 | return Rewrite_Ins (Node); | |
1623 | end Is_Rewrite_Insertion; | |
7b47778e | 1624 | |
76f9c7f4 BD |
1625 | ----------------------------- |
1626 | -- Is_Rewrite_Substitution -- | |
1627 | ----------------------------- | |
7b47778e | 1628 | |
76f9c7f4 BD |
1629 | function Is_Rewrite_Substitution (Node : Node_Id) return Boolean is |
1630 | begin | |
1631 | return Orig_Nodes.Table (Node) /= Node; | |
1632 | end Is_Rewrite_Substitution; | |
7b47778e | 1633 | |
76f9c7f4 BD |
1634 | ------------------ |
1635 | -- Last_Node_Id -- | |
1636 | ------------------ | |
7b47778e | 1637 | |
76f9c7f4 BD |
1638 | function Last_Node_Id return Node_Id is |
1639 | begin | |
1640 | return Node_Offsets.Last; | |
1641 | end Last_Node_Id; | |
7b47778e | 1642 | |
76f9c7f4 BD |
1643 | ---------- |
1644 | -- Lock -- | |
1645 | ---------- | |
7b47778e | 1646 | |
76f9c7f4 BD |
1647 | procedure Lock is |
1648 | begin | |
1649 | Orig_Nodes.Locked := True; | |
1650 | end Lock; | |
7b47778e | 1651 | |
76f9c7f4 BD |
1652 | ---------------- |
1653 | -- Lock_Nodes -- | |
1654 | ---------------- | |
7b47778e | 1655 | |
76f9c7f4 BD |
1656 | procedure Lock_Nodes is |
1657 | begin | |
1658 | pragma Assert (not Locked); | |
1659 | Locked := True; | |
1660 | end Lock_Nodes; | |
7b47778e | 1661 | |
76f9c7f4 BD |
1662 | ------------------------- |
1663 | -- Mark_New_Ghost_Node -- | |
1664 | ------------------------- | |
7b47778e | 1665 | |
76f9c7f4 BD |
1666 | procedure Mark_New_Ghost_Node (N : Node_Or_Entity_Id) is |
1667 | begin | |
1668 | pragma Debug (Validate_Node_Write (N)); | |
7b47778e | 1669 | |
76f9c7f4 | 1670 | -- The Ghost node is created within a Ghost region |
7b47778e | 1671 | |
76f9c7f4 BD |
1672 | if Ghost_Mode = Check then |
1673 | if Nkind (N) in N_Entity then | |
1674 | Set_Is_Checked_Ghost_Entity (N); | |
1675 | end if; | |
08f52d9f | 1676 | |
76f9c7f4 BD |
1677 | elsif Ghost_Mode = Ignore then |
1678 | if Nkind (N) in N_Entity then | |
1679 | Set_Is_Ignored_Ghost_Entity (N); | |
1680 | end if; | |
08f52d9f | 1681 | |
76f9c7f4 | 1682 | Set_Is_Ignored_Ghost_Node (N); |
08f52d9f | 1683 | |
76f9c7f4 BD |
1684 | -- Record the ignored Ghost node or entity in order to eliminate it |
1685 | -- from the tree later. | |
08f52d9f | 1686 | |
76f9c7f4 BD |
1687 | if Ignored_Ghost_Recording_Proc /= null then |
1688 | Ignored_Ghost_Recording_Proc.all (N); | |
1689 | end if; | |
1690 | end if; | |
1691 | end Mark_New_Ghost_Node; | |
08f52d9f | 1692 | |
76f9c7f4 BD |
1693 | ---------------------------- |
1694 | -- Mark_Rewrite_Insertion -- | |
1695 | ---------------------------- | |
7b47778e | 1696 | |
76f9c7f4 BD |
1697 | procedure Mark_Rewrite_Insertion (New_Node : Node_Id) is |
1698 | begin | |
1699 | Set_Rewrite_Ins (New_Node); | |
1700 | end Mark_Rewrite_Insertion; | |
d23b8f57 | 1701 | |
76f9c7f4 BD |
1702 | -------------- |
1703 | -- New_Copy -- | |
1704 | -------------- | |
1705 | ||
1706 | function New_Copy (Source : Node_Id) return Node_Id is | |
1707 | pragma Debug (Validate_Node (Source)); | |
d23b8f57 | 1708 | |
76f9c7f4 BD |
1709 | New_Id : Node_Id; |
1710 | S_Size : constant Field_Offset := Size_In_Slots_To_Alloc (Source); | |
d23b8f57 | 1711 | begin |
76f9c7f4 BD |
1712 | if Source <= Empty_Or_Error then |
1713 | return Source; | |
d23b8f57 RK |
1714 | end if; |
1715 | ||
76f9c7f4 BD |
1716 | New_Id := Alloc_Node_Id; |
1717 | Node_Offsets.Table (New_Id) := Alloc_Slots (S_Size); | |
1718 | Orig_Nodes.Append (New_Id); | |
1719 | Copy_Slots (Source, New_Id); | |
d23b8f57 | 1720 | |
76f9c7f4 BD |
1721 | Set_Check_Actuals (New_Id, False); |
1722 | Set_Paren_Count_Of_Copy (Target => New_Id, Source => Source); | |
1723 | pragma Assert (Original_Node (Node_Offsets.Last) = Node_Offsets.Last); | |
d23b8f57 | 1724 | |
76f9c7f4 BD |
1725 | Allocate_List_Tables (New_Id); |
1726 | Report (Target => New_Id, Source => Source); | |
fbf5a39b | 1727 | |
76f9c7f4 BD |
1728 | Set_In_List (New_Id, False); |
1729 | Set_Link (New_Id, Empty_List_Or_Node); | |
fbf5a39b | 1730 | |
76f9c7f4 BD |
1731 | -- If the original is marked as a rewrite insertion, then unmark the |
1732 | -- copy, since we inserted the original, not the copy. | |
d23b8f57 | 1733 | |
76f9c7f4 BD |
1734 | Set_Rewrite_Ins (New_Id, False); |
1735 | pragma Debug (New_Node_Debugging_Output (New_Id)); | |
d23b8f57 | 1736 | |
76f9c7f4 BD |
1737 | -- Clear Is_Overloaded since we cannot have semantic interpretations |
1738 | -- of this new node. | |
d23b8f57 | 1739 | |
76f9c7f4 BD |
1740 | if Nkind (Source) in N_Subexpr then |
1741 | Set_Is_Overloaded (New_Id, False); | |
1742 | end if; | |
d23b8f57 | 1743 | |
76f9c7f4 BD |
1744 | -- Always clear Has_Aspects, the caller must take care of copying |
1745 | -- aspects if this is required for the particular situation. | |
d23b8f57 | 1746 | |
76f9c7f4 | 1747 | Set_Has_Aspects (New_Id, False); |
d23b8f57 | 1748 | |
76f9c7f4 | 1749 | -- Mark the copy as Ghost depending on the current Ghost region |
7665e4bd | 1750 | |
76f9c7f4 | 1751 | Mark_New_Ghost_Node (New_Id); |
7665e4bd | 1752 | |
76f9c7f4 BD |
1753 | pragma Assert (New_Id /= Source); |
1754 | return New_Id; | |
1755 | end New_Copy; | |
d23b8f57 | 1756 | |
76f9c7f4 BD |
1757 | ---------------- |
1758 | -- New_Entity -- | |
1759 | ---------------- | |
83dcc2bd | 1760 | |
76f9c7f4 BD |
1761 | function New_Entity |
1762 | (New_Node_Kind : Node_Kind; | |
1763 | New_Sloc : Source_Ptr) return Entity_Id | |
1764 | is | |
1765 | pragma Assert (New_Node_Kind in N_Entity); | |
1766 | New_Id : constant Entity_Id := Allocate_New_Node (New_Node_Kind); | |
1767 | pragma Assert (Original_Node (Node_Offsets.Last) = Node_Offsets.Last); | |
83dcc2bd | 1768 | begin |
76f9c7f4 BD |
1769 | -- If this is a node with a real location and we are generating |
1770 | -- source nodes, then reset Current_Error_Node. This is useful | |
1771 | -- if we bomb during parsing to get a error location for the bomb. | |
980f94b7 | 1772 | |
76f9c7f4 BD |
1773 | if New_Sloc > No_Location and then Comes_From_Source_Default then |
1774 | Current_Error_Node := New_Id; | |
1775 | end if; | |
980f94b7 | 1776 | |
76f9c7f4 BD |
1777 | Set_Sloc (New_Id, New_Sloc); |
1778 | pragma Debug (New_Node_Debugging_Output (New_Id)); | |
980f94b7 | 1779 | |
76f9c7f4 | 1780 | -- Mark the new entity as Ghost depending on the current Ghost region |
d23b8f57 | 1781 | |
76f9c7f4 | 1782 | Mark_New_Ghost_Node (New_Id); |
d23b8f57 | 1783 | |
76f9c7f4 BD |
1784 | return New_Id; |
1785 | end New_Entity; | |
d23b8f57 | 1786 | |
76f9c7f4 BD |
1787 | -------------- |
1788 | -- New_Node -- | |
1789 | -------------- | |
d23b8f57 | 1790 | |
76f9c7f4 BD |
1791 | function New_Node |
1792 | (New_Node_Kind : Node_Kind; | |
1793 | New_Sloc : Source_Ptr) return Node_Id | |
1794 | is | |
1795 | pragma Assert (New_Node_Kind not in N_Entity); | |
1796 | New_Id : constant Node_Id := Allocate_New_Node (New_Node_Kind); | |
1797 | pragma Assert (Original_Node (Node_Offsets.Last) = Node_Offsets.Last); | |
d23b8f57 | 1798 | begin |
76f9c7f4 BD |
1799 | Set_Sloc (New_Id, New_Sloc); |
1800 | pragma Debug (New_Node_Debugging_Output (New_Id)); | |
c159409f | 1801 | |
76f9c7f4 BD |
1802 | -- If this is a node with a real location and we are generating source |
1803 | -- nodes, then reset Current_Error_Node. This is useful if we bomb | |
1804 | -- during parsing to get an error location for the bomb. | |
c159409f | 1805 | |
76f9c7f4 BD |
1806 | if Comes_From_Source_Default and then New_Sloc > No_Location then |
1807 | Current_Error_Node := New_Id; | |
d23b8f57 RK |
1808 | end if; |
1809 | ||
76f9c7f4 | 1810 | -- Mark the new node as Ghost depending on the current Ghost region |
d23b8f57 | 1811 | |
76f9c7f4 | 1812 | Mark_New_Ghost_Node (New_Id); |
d23b8f57 | 1813 | |
76f9c7f4 BD |
1814 | return New_Id; |
1815 | end New_Node; | |
980f94b7 | 1816 | |
76f9c7f4 BD |
1817 | ------------------------- |
1818 | -- New_Node_Breakpoint -- | |
1819 | ------------------------- | |
d23b8f57 | 1820 | |
76f9c7f4 BD |
1821 | procedure nn is |
1822 | begin | |
1823 | Write_Str ("Watched node "); | |
1824 | Write_Int (Int (Watch_Node)); | |
1825 | Write_Eol; | |
1826 | end nn; | |
7665e4bd | 1827 | |
76f9c7f4 BD |
1828 | ------------------------------- |
1829 | -- New_Node_Debugging_Output -- | |
1830 | ------------------------------- | |
7665e4bd | 1831 | |
76f9c7f4 BD |
1832 | procedure nnd (N : Node_Id) is |
1833 | Node_Is_Watched : constant Boolean := N = Watch_Node; | |
90e491a7 | 1834 | |
76f9c7f4 BD |
1835 | begin |
1836 | if Debug_Flag_N or else Node_Is_Watched then | |
1837 | Node_Debug_Output ("Node", N); | |
90e491a7 | 1838 | |
76f9c7f4 BD |
1839 | if Node_Is_Watched then |
1840 | New_Node_Breakpoint; | |
1841 | end if; | |
90e491a7 | 1842 | end if; |
76f9c7f4 | 1843 | end nnd; |
d23b8f57 | 1844 | |
76f9c7f4 BD |
1845 | -------- |
1846 | -- No -- | |
1847 | -------- | |
d23b8f57 | 1848 | |
76f9c7f4 | 1849 | function No (N : Node_Id) return Boolean is |
d23b8f57 | 1850 | begin |
76f9c7f4 BD |
1851 | return N = Empty; |
1852 | end No; | |
d23b8f57 | 1853 | |
b502ba3c | 1854 | ----------------------- |
76f9c7f4 | 1855 | -- Node_Debug_Output -- |
b502ba3c RD |
1856 | ----------------------- |
1857 | ||
76f9c7f4 | 1858 | procedure Node_Debug_Output (Op : String; N : Node_Id) is |
b502ba3c | 1859 | begin |
76f9c7f4 | 1860 | Write_Str (Op); |
b502ba3c | 1861 | |
76f9c7f4 BD |
1862 | if Nkind (N) in N_Entity then |
1863 | Write_Str (" entity"); | |
1864 | else | |
1865 | Write_Str (" node"); | |
1866 | end if; | |
d23b8f57 | 1867 | |
76f9c7f4 BD |
1868 | Write_Str (" Id = "); |
1869 | Write_Int (Int (N)); | |
1870 | Write_Str (" "); | |
1871 | Write_Location (Sloc (N)); | |
1872 | Write_Str (" "); | |
1873 | Write_Str (Node_Kind'Image (Nkind (N))); | |
1874 | Write_Eol; | |
1875 | end Node_Debug_Output; | |
d23b8f57 | 1876 | |
76f9c7f4 BD |
1877 | ------------------- |
1878 | -- Nodes_Address -- | |
1879 | ------------------- | |
d23b8f57 | 1880 | |
76f9c7f4 | 1881 | function Node_Offsets_Address return System.Address is |
d23b8f57 | 1882 | begin |
76f9c7f4 BD |
1883 | return Node_Offsets.Table (First_Node_Id)'Address; |
1884 | end Node_Offsets_Address; | |
d23b8f57 | 1885 | |
76f9c7f4 BD |
1886 | Slot_Byte_Size : constant := 4; |
1887 | pragma Assert (Slot_Byte_Size * 8 = Slot'Size); | |
d23b8f57 | 1888 | |
76f9c7f4 BD |
1889 | function Slots_Address return System.Address is |
1890 | Extra : constant := Slots_Low_Bound * Slot_Byte_Size; | |
1891 | -- Slots does not start at 0, so we need to subtract off the extra | |
1892 | -- amount. We are returning Slots.Table (0)'Address, except that | |
1893 | -- that component does not exist. | |
1894 | use System.Storage_Elements; | |
d23b8f57 | 1895 | begin |
76f9c7f4 BD |
1896 | return Slots.Table (Slots_Low_Bound)'Address - Extra; |
1897 | end Slots_Address; | |
d23b8f57 | 1898 | |
76f9c7f4 BD |
1899 | ----------------------------------- |
1900 | -- Approx_Num_Nodes_And_Entities -- | |
1901 | ----------------------------------- | |
d23b8f57 | 1902 | |
76f9c7f4 | 1903 | function Approx_Num_Nodes_And_Entities return Nat is |
d23b8f57 | 1904 | begin |
76f9c7f4 BD |
1905 | return Nat (Node_Offsets.Last - First_Node_Id); |
1906 | end Approx_Num_Nodes_And_Entities; | |
d23b8f57 | 1907 | |
76f9c7f4 BD |
1908 | ----------- |
1909 | -- Off_0 -- | |
1910 | ----------- | |
1911 | ||
1912 | function Off_0 (N : Node_Id) return Node_Offset is | |
1913 | pragma Debug (Validate_Node (N)); | |
c159409f | 1914 | |
76f9c7f4 BD |
1915 | All_Node_Offsets : Node_Offsets.Table_Type renames |
1916 | Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); | |
c159409f | 1917 | begin |
76f9c7f4 BD |
1918 | return All_Node_Offsets (N); |
1919 | end Off_0; | |
c159409f | 1920 | |
76f9c7f4 BD |
1921 | ----------- |
1922 | -- Off_L -- | |
1923 | ----------- | |
980f94b7 | 1924 | |
76f9c7f4 BD |
1925 | function Off_L (N : Node_Id) return Node_Offset is |
1926 | pragma Debug (Validate_Node (N)); | |
1927 | ||
1928 | All_Node_Offsets : Node_Offsets.Table_Type renames | |
1929 | Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); | |
980f94b7 | 1930 | begin |
76f9c7f4 BD |
1931 | return All_Node_Offsets (N) + Size_In_Slots (N) - 1; |
1932 | end Off_L; | |
980f94b7 | 1933 | |
76f9c7f4 BD |
1934 | ------------------- |
1935 | -- Original_Node -- | |
1936 | ------------------- | |
8636f52f | 1937 | |
76f9c7f4 | 1938 | function Original_Node (Node : Node_Id) return Node_Id is |
8636f52f | 1939 | begin |
76f9c7f4 | 1940 | pragma Debug (Validate_Node (Node)); |
8636f52f | 1941 | |
76f9c7f4 BD |
1942 | return Orig_Nodes.Table (Node); |
1943 | end Original_Node; | |
8c18a165 | 1944 | |
76f9c7f4 BD |
1945 | ----------------- |
1946 | -- Paren_Count -- | |
1947 | ----------------- | |
8c18a165 | 1948 | |
76f9c7f4 BD |
1949 | function Paren_Count (N : Node_Id) return Nat is |
1950 | pragma Debug (Validate_Node (N)); | |
1951 | ||
1952 | C : constant Small_Paren_Count_Type := Small_Paren_Count (N); | |
d23b8f57 | 1953 | |
d23b8f57 | 1954 | begin |
76f9c7f4 | 1955 | -- Value of 0,1,2 returned as is |
8133b9d1 | 1956 | |
76f9c7f4 BD |
1957 | if C <= 2 then |
1958 | return C; | |
8133b9d1 | 1959 | |
76f9c7f4 | 1960 | -- Value of 3 means we search the table, and we must find an entry |
8133b9d1 ES |
1961 | |
1962 | else | |
8133b9d1 ES |
1963 | for J in Paren_Counts.First .. Paren_Counts.Last loop |
1964 | if N = Paren_Counts.Table (J).Nod then | |
76f9c7f4 | 1965 | return Paren_Counts.Table (J).Count; |
8133b9d1 ES |
1966 | end if; |
1967 | end loop; | |
1968 | ||
76f9c7f4 | 1969 | raise Program_Error; |
8133b9d1 | 1970 | end if; |
76f9c7f4 | 1971 | end Paren_Count; |
d23b8f57 | 1972 | |
76f9c7f4 BD |
1973 | ------------ |
1974 | -- Parent -- | |
1975 | ------------ | |
83dcc2bd | 1976 | |
76f9c7f4 | 1977 | function Parent (N : Node_Id) return Node_Id is |
83dcc2bd | 1978 | begin |
76f9c7f4 BD |
1979 | if Is_List_Member (N) then |
1980 | return Parent (List_Containing (N)); | |
1981 | else | |
1982 | return Node_Id (Link (N)); | |
83dcc2bd | 1983 | end if; |
76f9c7f4 | 1984 | end Parent; |
83dcc2bd | 1985 | |
76f9c7f4 BD |
1986 | ------------- |
1987 | -- Present -- | |
1988 | ------------- | |
90e491a7 | 1989 | |
76f9c7f4 | 1990 | function Present (N : Node_Id) return Boolean is |
90e491a7 | 1991 | begin |
76f9c7f4 BD |
1992 | return N /= Empty; |
1993 | end Present; | |
90e491a7 | 1994 | |
76f9c7f4 BD |
1995 | -------------------------------- |
1996 | -- Preserve_Comes_From_Source -- | |
1997 | -------------------------------- | |
d23b8f57 | 1998 | |
76f9c7f4 | 1999 | procedure Preserve_Comes_From_Source (NewN, OldN : Node_Id) is |
d23b8f57 | 2000 | begin |
76f9c7f4 BD |
2001 | Set_Comes_From_Source (NewN, Comes_From_Source (OldN)); |
2002 | end Preserve_Comes_From_Source; | |
d23b8f57 | 2003 | |
76f9c7f4 BD |
2004 | ---------------------- |
2005 | -- Print_Atree_Info -- | |
2006 | ---------------------- | |
90e491a7 | 2007 | |
76f9c7f4 BD |
2008 | procedure Print_Atree_Info (N : Node_Or_Entity_Id) is |
2009 | function Cast is new Unchecked_Conversion (Slot_32_Bit, Int); | |
90e491a7 | 2010 | begin |
76f9c7f4 BD |
2011 | Write_Int (Int (Size_In_Slots (N))); |
2012 | Write_Str (" slots ("); | |
2013 | Write_Int (Int (Off_0 (N))); | |
2014 | Write_Str (" .. "); | |
2015 | Write_Int (Int (Off_L (N))); | |
2016 | Write_Str ("):"); | |
90e491a7 | 2017 | |
76f9c7f4 BD |
2018 | for Off in Off_0 (N) .. Off_L (N) loop |
2019 | Write_Str (" "); | |
2020 | Write_Int (Cast (Slots.Table (Off).Slot_32)); | |
2021 | end loop; | |
d23b8f57 | 2022 | |
76f9c7f4 BD |
2023 | Write_Eol; |
2024 | end Print_Atree_Info; | |
d23b8f57 RK |
2025 | |
2026 | ------------------- | |
76f9c7f4 | 2027 | -- Relocate_Node -- |
d23b8f57 RK |
2028 | ------------------- |
2029 | ||
76f9c7f4 BD |
2030 | function Relocate_Node (Source : Node_Id) return Node_Id is |
2031 | New_Node : Node_Id; | |
d23b8f57 | 2032 | |
76f9c7f4 BD |
2033 | begin |
2034 | if No (Source) then | |
2035 | return Empty; | |
2036 | end if; | |
d23b8f57 | 2037 | |
76f9c7f4 BD |
2038 | New_Node := New_Copy (Source); |
2039 | Fix_Parents (Ref_Node => Source, Fix_Node => New_Node); | |
d23b8f57 | 2040 | |
76f9c7f4 BD |
2041 | -- We now set the parent of the new node to be the same as the parent of |
2042 | -- the source. Almost always this parent will be replaced by a new value | |
2043 | -- when the relocated node is reattached to the tree, but by doing it | |
2044 | -- now, we ensure that this node is not even temporarily disconnected | |
2045 | -- from the tree. Note that this does not happen free, because in the | |
2046 | -- list case, the parent does not get set. | |
d23b8f57 | 2047 | |
76f9c7f4 | 2048 | Set_Parent (New_Node, Parent (Source)); |
b9daa96e | 2049 | |
76f9c7f4 BD |
2050 | -- If the node being relocated was a rewriting of some original node, |
2051 | -- then the relocated node has the same original node. | |
d23b8f57 | 2052 | |
76f9c7f4 BD |
2053 | if Is_Rewrite_Substitution (Source) then |
2054 | Set_Original_Node (New_Node, Original_Node (Source)); | |
2055 | end if; | |
d23b8f57 | 2056 | |
76f9c7f4 BD |
2057 | return New_Node; |
2058 | end Relocate_Node; | |
d23b8f57 | 2059 | |
76f9c7f4 BD |
2060 | ------------- |
2061 | -- Replace -- | |
2062 | ------------- | |
d23b8f57 | 2063 | |
76f9c7f4 BD |
2064 | procedure Replace (Old_Node, New_Node : Node_Id) is |
2065 | pragma Debug (New_Node_Debugging_Output (Old_Node)); | |
2066 | pragma Debug (New_Node_Debugging_Output (New_Node)); | |
d23b8f57 | 2067 | |
76f9c7f4 BD |
2068 | Old_Post : constant Boolean := Error_Posted (Old_Node); |
2069 | Old_HasA : constant Boolean := Has_Aspects (Old_Node); | |
2070 | Old_CFS : constant Boolean := Comes_From_Source (Old_Node); | |
d23b8f57 | 2071 | |
76f9c7f4 BD |
2072 | procedure Destroy_New_Node; |
2073 | -- Overwrite New_Node data with junk, for debugging purposes | |
10303118 | 2074 | |
76f9c7f4 BD |
2075 | procedure Destroy_New_Node is |
2076 | begin | |
2077 | Zero_Slots (New_Node); | |
2078 | Node_Offsets.Table (New_Node) := Field_Offset'Base'Last; | |
2079 | end Destroy_New_Node; | |
d23b8f57 RK |
2080 | |
2081 | begin | |
76f9c7f4 BD |
2082 | pragma Assert |
2083 | (not Is_Entity (Old_Node) | |
2084 | and not Is_Entity (New_Node) | |
2085 | and not In_List (New_Node) | |
2086 | and Old_Node /= New_Node); | |
10303118 | 2087 | |
76f9c7f4 | 2088 | -- Do copy, preserving link and in list status and required flags |
10303118 | 2089 | |
76f9c7f4 BD |
2090 | Copy_Node (Source => New_Node, Destination => Old_Node); |
2091 | Set_Comes_From_Source (Old_Node, Old_CFS); | |
2092 | Set_Error_Posted (Old_Node, Old_Post); | |
2093 | Set_Has_Aspects (Old_Node, Old_HasA); | |
d23b8f57 | 2094 | |
76f9c7f4 | 2095 | -- Fix parents of substituted node, since it has changed identity |
d23b8f57 | 2096 | |
76f9c7f4 | 2097 | Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node); |
d23b8f57 | 2098 | |
76f9c7f4 | 2099 | pragma Debug (Destroy_New_Node); |
10303118 | 2100 | |
76f9c7f4 BD |
2101 | -- Since we are doing a replace, we assume that the original node |
2102 | -- is intended to become the new replaced node. The call would be | |
2103 | -- to Rewrite if there were an intention to save the original node. | |
10303118 | 2104 | |
76f9c7f4 | 2105 | Set_Original_Node (Old_Node, Old_Node); |
366b8af7 | 2106 | |
76f9c7f4 | 2107 | -- Invoke the reporting procedure (if available) |
10303118 | 2108 | |
76f9c7f4 BD |
2109 | if Reporting_Proc /= null then |
2110 | Reporting_Proc.all (Target => Old_Node, Source => New_Node); | |
10303118 | 2111 | end if; |
76f9c7f4 | 2112 | end Replace; |
10303118 | 2113 | |
76f9c7f4 BD |
2114 | ------------ |
2115 | -- Report -- | |
2116 | ------------ | |
d23b8f57 | 2117 | |
76f9c7f4 | 2118 | procedure Report (Target, Source : Node_Id) is |
d23b8f57 | 2119 | begin |
76f9c7f4 BD |
2120 | if Reporting_Proc /= null then |
2121 | Reporting_Proc.all (Target, Source); | |
2122 | end if; | |
2123 | end Report; | |
d23b8f57 | 2124 | |
76f9c7f4 BD |
2125 | ------------- |
2126 | -- Rewrite -- | |
2127 | ------------- | |
d23b8f57 | 2128 | |
76f9c7f4 BD |
2129 | procedure Rewrite (Old_Node, New_Node : Node_Id) is |
2130 | pragma Debug (New_Node_Debugging_Output (Old_Node)); | |
2131 | pragma Debug (New_Node_Debugging_Output (New_Node)); | |
d23b8f57 | 2132 | |
76f9c7f4 BD |
2133 | Old_CA : constant Boolean := Check_Actuals (Old_Node); |
2134 | Old_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Old_Node); | |
2135 | Old_Error_Posted : constant Boolean := | |
2136 | Error_Posted (Old_Node); | |
2137 | Old_Has_Aspects : constant Boolean := | |
2138 | Has_Aspects (Old_Node); | |
d23b8f57 | 2139 | |
76f9c7f4 BD |
2140 | Old_Must_Not_Freeze : constant Boolean := |
2141 | (if Nkind (Old_Node) in N_Subexpr then Must_Not_Freeze (Old_Node) | |
2142 | else False); | |
2143 | Old_Paren_Count : constant Nat := | |
2144 | (if Nkind (Old_Node) in N_Subexpr then Paren_Count (Old_Node) else 0); | |
2145 | -- These fields are preserved in the new node only if the new node and | |
2146 | -- the old node are both subexpression nodes. We might be changing Nkind | |
2147 | -- (Old_Node) from not N_Subexpr to N_Subexpr, so we need a value | |
2148 | -- (False/0) even if Old_Noed is not a N_Subexpr. | |
d23b8f57 | 2149 | |
76f9c7f4 BD |
2150 | -- Note: it is a violation of abstraction levels for Must_Not_Freeze |
2151 | -- to be referenced like this. ??? | |
d23b8f57 | 2152 | |
76f9c7f4 | 2153 | Sav_Node : Node_Id; |
d23b8f57 | 2154 | |
76f9c7f4 BD |
2155 | begin |
2156 | pragma Assert | |
2157 | (not Is_Entity (Old_Node) | |
2158 | and not Is_Entity (New_Node) | |
2159 | and not In_List (New_Node)); | |
d23b8f57 | 2160 | |
76f9c7f4 BD |
2161 | -- Allocate a new node, to be used to preserve the original contents |
2162 | -- of the Old_Node, for possible later retrival by Original_Node and | |
2163 | -- make an entry in the Orig_Nodes table. This is only done if we have | |
2164 | -- not already rewritten the node, as indicated by an Orig_Nodes entry | |
2165 | -- that does not reference the Old_Node. | |
d23b8f57 | 2166 | |
76f9c7f4 BD |
2167 | if Original_Node (Old_Node) = Old_Node then |
2168 | Sav_Node := New_Copy (Old_Node); | |
2169 | Set_Original_Node (Sav_Node, Sav_Node); | |
2170 | Set_Original_Node (Old_Node, Sav_Node); | |
d23b8f57 | 2171 | |
76f9c7f4 BD |
2172 | -- Both the old and new copies of the node will share the same list |
2173 | -- of aspect specifications if aspect specifications are present. | |
d23b8f57 | 2174 | |
76f9c7f4 BD |
2175 | if Old_Has_Aspects then |
2176 | Set_Aspect_Specifications | |
2177 | (Sav_Node, Aspect_Specifications (Old_Node)); | |
2178 | end if; | |
2179 | end if; | |
d23b8f57 | 2180 | |
76f9c7f4 | 2181 | -- Copy substitute node into place, preserving old fields as required |
d23b8f57 | 2182 | |
76f9c7f4 BD |
2183 | Copy_Node (Source => New_Node, Destination => Old_Node); |
2184 | Set_Error_Posted (Old_Node, Old_Error_Posted); | |
2185 | Set_Has_Aspects (Old_Node, Old_Has_Aspects); | |
d23b8f57 | 2186 | |
76f9c7f4 BD |
2187 | Set_Check_Actuals (Old_Node, Old_CA); |
2188 | Set_Is_Ignored_Ghost_Node (Old_Node, Old_Is_IGN); | |
d23b8f57 | 2189 | |
76f9c7f4 BD |
2190 | if Nkind (New_Node) in N_Subexpr then |
2191 | Set_Paren_Count (Old_Node, Old_Paren_Count); | |
2192 | Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze); | |
2193 | end if; | |
d23b8f57 | 2194 | |
76f9c7f4 | 2195 | Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node); |
d23b8f57 | 2196 | |
76f9c7f4 | 2197 | -- Invoke the reporting procedure (if available) |
d23b8f57 | 2198 | |
76f9c7f4 BD |
2199 | if Reporting_Proc /= null then |
2200 | Reporting_Proc.all (Target => Old_Node, Source => New_Node); | |
2201 | end if; | |
d23b8f57 | 2202 | |
76f9c7f4 | 2203 | -- Invoke the rewriting procedure (if available) |
d23b8f57 | 2204 | |
76f9c7f4 BD |
2205 | if Rewriting_Proc /= null then |
2206 | Rewriting_Proc.all (Target => Old_Node, Source => New_Node); | |
2207 | end if; | |
2208 | end Rewrite; | |
39f4e199 | 2209 | |
76f9c7f4 BD |
2210 | ----------------------------------- |
2211 | -- Set_Comes_From_Source_Default -- | |
2212 | ----------------------------------- | |
39f4e199 | 2213 | |
76f9c7f4 BD |
2214 | procedure Set_Comes_From_Source_Default (Default : Boolean) is |
2215 | begin | |
2216 | Comes_From_Source_Default := Default; | |
2217 | end Set_Comes_From_Source_Default; | |
39f4e199 | 2218 | |
76f9c7f4 BD |
2219 | -------------------------------------- |
2220 | -- Set_Ignored_Ghost_Recording_Proc -- | |
2221 | -------------------------------------- | |
39f4e199 | 2222 | |
76f9c7f4 BD |
2223 | procedure Set_Ignored_Ghost_Recording_Proc |
2224 | (Proc : Ignored_Ghost_Record_Proc) | |
2225 | is | |
2226 | begin | |
2227 | pragma Assert (Ignored_Ghost_Recording_Proc = null); | |
2228 | Ignored_Ghost_Recording_Proc := Proc; | |
2229 | end Set_Ignored_Ghost_Recording_Proc; | |
39f4e199 | 2230 | |
76f9c7f4 BD |
2231 | ----------------------- |
2232 | -- Set_Original_Node -- | |
2233 | ----------------------- | |
39f4e199 | 2234 | |
76f9c7f4 BD |
2235 | procedure Set_Original_Node (N : Node_Id; Val : Node_Id) is |
2236 | begin | |
2237 | pragma Debug (Validate_Node_Write (N)); | |
39f4e199 | 2238 | |
76f9c7f4 BD |
2239 | Orig_Nodes.Table (N) := Val; |
2240 | end Set_Original_Node; | |
39f4e199 | 2241 | |
76f9c7f4 BD |
2242 | --------------------- |
2243 | -- Set_Paren_Count -- | |
2244 | --------------------- | |
39f4e199 | 2245 | |
76f9c7f4 BD |
2246 | procedure Set_Paren_Count (N : Node_Id; Val : Nat) is |
2247 | begin | |
2248 | pragma Debug (Validate_Node_Write (N)); | |
2249 | pragma Assert (Nkind (N) in N_Subexpr); | |
ac4d6407 | 2250 | |
76f9c7f4 | 2251 | -- Value of 0,1,2 stored as is |
ac4d6407 | 2252 | |
76f9c7f4 BD |
2253 | if Val <= 2 then |
2254 | Set_Small_Paren_Count (N, Val); | |
ac4d6407 | 2255 | |
76f9c7f4 | 2256 | -- Value of 3 or greater stores 3 in node and makes table entry |
ac4d6407 | 2257 | |
76f9c7f4 BD |
2258 | else |
2259 | Set_Small_Paren_Count (N, 3); | |
ac4d6407 | 2260 | |
76f9c7f4 | 2261 | -- Search for existing table entry |
ac4d6407 | 2262 | |
76f9c7f4 BD |
2263 | for J in Paren_Counts.First .. Paren_Counts.Last loop |
2264 | if N = Paren_Counts.Table (J).Nod then | |
2265 | Paren_Counts.Table (J).Count := Val; | |
2266 | return; | |
2267 | end if; | |
2268 | end loop; | |
ac4d6407 | 2269 | |
76f9c7f4 | 2270 | -- No existing table entry; make a new one |
ac4d6407 | 2271 | |
76f9c7f4 BD |
2272 | Paren_Counts.Append ((Nod => N, Count => Val)); |
2273 | end if; | |
2274 | end Set_Paren_Count; | |
0e564ab4 | 2275 | |
76f9c7f4 BD |
2276 | ----------------------------- |
2277 | -- Set_Paren_Count_Of_Copy -- | |
2278 | ----------------------------- | |
0e564ab4 | 2279 | |
76f9c7f4 BD |
2280 | procedure Set_Paren_Count_Of_Copy (Target, Source : Node_Id) is |
2281 | begin | |
2282 | -- We already copied the Small_Paren_Count. We need to update the | |
2283 | -- Paren_Counts table only if greater than 2. | |
0e564ab4 | 2284 | |
76f9c7f4 BD |
2285 | if Nkind (Source) in N_Subexpr |
2286 | and then Small_Paren_Count (Source) = 3 | |
2287 | then | |
2288 | Set_Paren_Count (Target, Paren_Count (Source)); | |
2289 | end if; | |
0e564ab4 | 2290 | |
76f9c7f4 BD |
2291 | pragma Assert (Paren_Count (Target) = Paren_Count (Source)); |
2292 | end Set_Paren_Count_Of_Copy; | |
0e564ab4 | 2293 | |
76f9c7f4 BD |
2294 | ---------------- |
2295 | -- Set_Parent -- | |
2296 | ---------------- | |
0e564ab4 | 2297 | |
76f9c7f4 BD |
2298 | procedure Set_Parent (N : Node_Id; Val : Node_Id) is |
2299 | begin | |
2300 | pragma Assert (not Locked); | |
2301 | pragma Assert (not In_List (N)); | |
2302 | Set_Link (N, Union_Id (Val)); | |
2303 | end Set_Parent; | |
0e564ab4 | 2304 | |
76f9c7f4 BD |
2305 | ------------------------ |
2306 | -- Set_Reporting_Proc -- | |
2307 | ------------------------ | |
0e564ab4 | 2308 | |
76f9c7f4 BD |
2309 | procedure Set_Reporting_Proc (Proc : Report_Proc) is |
2310 | begin | |
2311 | pragma Assert (Reporting_Proc = null); | |
2312 | Reporting_Proc := Proc; | |
2313 | end Set_Reporting_Proc; | |
0e564ab4 | 2314 | |
76f9c7f4 BD |
2315 | ------------------------ |
2316 | -- Set_Rewriting_Proc -- | |
2317 | ------------------------ | |
0e564ab4 | 2318 | |
76f9c7f4 BD |
2319 | procedure Set_Rewriting_Proc (Proc : Rewrite_Proc) is |
2320 | begin | |
2321 | pragma Assert (Rewriting_Proc = null); | |
2322 | Rewriting_Proc := Proc; | |
2323 | end Set_Rewriting_Proc; | |
0e564ab4 | 2324 | |
76f9c7f4 BD |
2325 | function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Field_Offset is |
2326 | begin | |
2327 | return | |
2328 | (if Kind in N_Entity then Einfo.Entities.Max_Entity_Size | |
2329 | else Sinfo.Nodes.Size (Kind)); | |
2330 | -- Unfortunately, we don't know the Entity_Kind, so we have to use the | |
2331 | -- max. | |
2332 | end Size_In_Slots_To_Alloc; | |
0e564ab4 | 2333 | |
76f9c7f4 BD |
2334 | function Size_In_Slots_To_Alloc |
2335 | (N : Node_Or_Entity_Id) return Field_Offset is | |
2336 | begin | |
2337 | return Size_In_Slots_To_Alloc (Nkind (N)); | |
2338 | end Size_In_Slots_To_Alloc; | |
0e564ab4 | 2339 | |
76f9c7f4 BD |
2340 | function Size_In_Slots (N : Node_Or_Entity_Id) return Field_Offset is |
2341 | begin | |
2342 | return | |
2343 | (if Nkind (N) in N_Entity then Einfo.Entities.Max_Entity_Size | |
2344 | else Sinfo.Nodes.Size (Nkind (N))); | |
2345 | end Size_In_Slots; | |
0e564ab4 | 2346 | |
76f9c7f4 BD |
2347 | ------------------- |
2348 | -- Traverse_Func -- | |
2349 | ------------------- | |
0e564ab4 | 2350 | |
76f9c7f4 BD |
2351 | function Traverse_Func (Node : Node_Id) return Traverse_Final_Result is |
2352 | pragma Debug (Validate_Node (Node)); | |
0e564ab4 | 2353 | |
76f9c7f4 BD |
2354 | function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result; |
2355 | -- Fld is one of the Traversed fields of Nod, which is necessarily a | |
2356 | -- Node_Id or List_Id. It is traversed, and the result is the result of | |
2357 | -- this traversal. | |
0e564ab4 | 2358 | |
76f9c7f4 BD |
2359 | -------------------- |
2360 | -- Traverse_Field -- | |
2361 | -------------------- | |
0e564ab4 | 2362 | |
76f9c7f4 | 2363 | function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result is |
0e564ab4 | 2364 | begin |
76f9c7f4 | 2365 | if Fld /= Union_Id (Empty) then |
0e564ab4 | 2366 | |
76f9c7f4 | 2367 | -- Descendant is a node |
0e564ab4 | 2368 | |
76f9c7f4 BD |
2369 | if Fld in Node_Range then |
2370 | return Traverse_Func (Node_Id (Fld)); | |
0e564ab4 | 2371 | |
76f9c7f4 | 2372 | -- Descendant is a list |
0e564ab4 | 2373 | |
76f9c7f4 BD |
2374 | elsif Fld in List_Range then |
2375 | declare | |
2376 | Elmt : Node_Id := First (List_Id (Fld)); | |
2377 | begin | |
2378 | while Present (Elmt) loop | |
2379 | if Traverse_Func (Elmt) = Abandon then | |
2380 | return Abandon; | |
2381 | end if; | |
0e564ab4 | 2382 | |
76f9c7f4 BD |
2383 | Next (Elmt); |
2384 | end loop; | |
2385 | end; | |
8133b9d1 | 2386 | |
76f9c7f4 BD |
2387 | else |
2388 | raise Program_Error; | |
2389 | end if; | |
8133b9d1 ES |
2390 | end if; |
2391 | ||
76f9c7f4 BD |
2392 | return OK; |
2393 | end Traverse_Field; | |
d23b8f57 | 2394 | |
76f9c7f4 | 2395 | Cur_Node : Node_Id := Node; |
8133b9d1 | 2396 | |
76f9c7f4 | 2397 | -- Start of processing for Traverse_Func |
8133b9d1 | 2398 | |
76f9c7f4 BD |
2399 | begin |
2400 | -- If the last field is a node, we eliminate the tail recursion by | |
2401 | -- jumping back to this label. This is because concatenations are | |
2402 | -- sometimes deeply nested, as in X1&X2&...&Xn. Gen_IL ensures that the | |
2403 | -- Left_Opnd field of N_Op_Concat comes last in Traversed_Fields, so the | |
2404 | -- tail recursion is eliminated in that case. This trick prevents us | |
2405 | -- from running out of stack memory in that case. We don't bother | |
2406 | -- eliminating the tail recursion if the last field is a list. | |
2407 | -- | |
2408 | -- (To check, look in the body of Sinfo.Nodes, search for the Left_Opnd | |
2409 | -- getter, and note the offset of Left_Opnd. Then look in the spec of | |
2410 | -- Sinfo.Nodes, look at the Traversed_Fields table, search for the | |
2411 | -- N_Op_Concat component. The offset of Left_Opnd should be the last | |
2412 | -- component before the No_Field_Offset sentinels.) | |
d23b8f57 | 2413 | |
76f9c7f4 | 2414 | <<Tail_Recurse>> |
8133b9d1 | 2415 | |
76f9c7f4 BD |
2416 | case Process (Cur_Node) is |
2417 | when Abandon => | |
2418 | return Abandon; | |
8133b9d1 | 2419 | |
76f9c7f4 BD |
2420 | when Skip => |
2421 | return OK; | |
d23b8f57 | 2422 | |
76f9c7f4 BD |
2423 | when OK => |
2424 | null; | |
8133b9d1 | 2425 | |
76f9c7f4 BD |
2426 | when OK_Orig => |
2427 | Cur_Node := Original_Node (Cur_Node); | |
2428 | end case; | |
8133b9d1 | 2429 | |
76f9c7f4 BD |
2430 | -- Check for empty Traversed_Fields before entering loop below, so the |
2431 | -- tail recursive step won't go past the end. | |
d23b8f57 | 2432 | |
76f9c7f4 BD |
2433 | declare |
2434 | Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First; | |
2435 | Offsets : Traversed_Offset_Array renames | |
2436 | Traversed_Fields (Nkind (Cur_Node)); | |
8133b9d1 | 2437 | |
76f9c7f4 BD |
2438 | begin |
2439 | if Offsets (Traversed_Offset_Array'First) /= No_Field_Offset then | |
2440 | while Offsets (Cur_Field + 1) /= No_Field_Offset loop | |
2441 | declare | |
2442 | F : constant Union_Id := | |
2443 | Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field)); | |
8133b9d1 | 2444 | |
76f9c7f4 BD |
2445 | begin |
2446 | if Traverse_Field (F) = Abandon then | |
2447 | return Abandon; | |
2448 | end if; | |
2449 | end; | |
d23b8f57 | 2450 | |
76f9c7f4 BD |
2451 | Cur_Field := Cur_Field + 1; |
2452 | end loop; | |
d23b8f57 | 2453 | |
76f9c7f4 BD |
2454 | declare |
2455 | F : constant Union_Id := | |
2456 | Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field)); | |
d23b8f57 | 2457 | |
76f9c7f4 BD |
2458 | begin |
2459 | if F not in Node_Range then | |
2460 | if Traverse_Field (F) = Abandon then | |
2461 | return Abandon; | |
2462 | end if; | |
2463 | ||
2464 | elsif F /= Empty_List_Or_Node then | |
2465 | -- Here is the tail recursion step, we reset Cur_Node and | |
2466 | -- jump back to the start of the procedure, which has the | |
2467 | -- same semantic effect as a call. | |
2468 | ||
2469 | Cur_Node := Node_Id (F); | |
2470 | goto Tail_Recurse; | |
2471 | end if; | |
2472 | end; | |
d23b8f57 | 2473 | end if; |
76f9c7f4 | 2474 | end; |
d23b8f57 | 2475 | |
76f9c7f4 BD |
2476 | return OK; |
2477 | end Traverse_Func; | |
d23b8f57 | 2478 | |
76f9c7f4 BD |
2479 | ------------------- |
2480 | -- Traverse_Proc -- | |
2481 | ------------------- | |
d23b8f57 | 2482 | |
76f9c7f4 BD |
2483 | procedure Traverse_Proc (Node : Node_Id) is |
2484 | function Traverse is new Traverse_Func (Process); | |
2485 | Discard : Traverse_Final_Result; | |
2486 | pragma Warnings (Off, Discard); | |
2487 | begin | |
2488 | Discard := Traverse (Node); | |
2489 | end Traverse_Proc; | |
d23b8f57 | 2490 | |
39f4e199 VC |
2491 | ------------ |
2492 | -- Unlock -- | |
2493 | ------------ | |
2494 | ||
2495 | procedure Unlock is | |
2496 | begin | |
39f4e199 VC |
2497 | Orig_Nodes.Locked := False; |
2498 | end Unlock; | |
2499 | ||
f68fc405 AC |
2500 | ------------------ |
2501 | -- Unlock_Nodes -- | |
2502 | ------------------ | |
2503 | ||
2504 | procedure Unlock_Nodes is | |
2505 | begin | |
2506 | pragma Assert (Locked); | |
2507 | Locked := False; | |
2508 | end Unlock_Nodes; | |
2509 | ||
76f9c7f4 BD |
2510 | Zero : constant Slot := (Field_Size => 32, Slot_32 => 0); |
2511 | ||
2512 | procedure Zero_Slots (F, L : Node_Offset) is | |
2513 | begin | |
2514 | Slots.Table (F .. L) := (others => Zero); | |
2515 | -- Note that Zero.Field_Size is not stored, because Slot is an | |
2516 | -- Unchecked_Union. Hopefully, the compiler can generate efficient code | |
2517 | -- for this. | |
2518 | end Zero_Slots; | |
2519 | ||
2520 | procedure Zero_Slots (N : Node_Or_Entity_Id) is | |
2521 | begin | |
2522 | Zero_Slots (Off_0 (N), Off_L (N)); | |
2523 | end Zero_Slots; | |
2524 | ||
d23b8f57 | 2525 | end Atree; |