1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Debug
; use Debug
;
28 with Debug_A
; use Debug_A
;
29 with Exp_Aggr
; use Exp_Aggr
;
30 with Exp_SPARK
; use Exp_SPARK
;
31 with Exp_Attr
; use Exp_Attr
;
32 with Exp_Ch2
; use Exp_Ch2
;
33 with Exp_Ch3
; use Exp_Ch3
;
34 with Exp_Ch4
; use Exp_Ch4
;
35 with Exp_Ch5
; use Exp_Ch5
;
36 with Exp_Ch6
; use Exp_Ch6
;
37 with Exp_Ch7
; use Exp_Ch7
;
38 with Exp_Ch8
; use Exp_Ch8
;
39 with Exp_Ch9
; use Exp_Ch9
;
40 with Exp_Ch11
; use Exp_Ch11
;
41 with Exp_Ch12
; use Exp_Ch12
;
42 with Exp_Ch13
; use Exp_Ch13
;
43 with Exp_Prag
; use Exp_Prag
;
44 with Ghost
; use Ghost
;
46 with Rtsfind
; use Rtsfind
;
48 with Sem_Ch8
; use Sem_Ch8
;
49 with Sem_Util
; use Sem_Util
;
50 with Sinfo
; use Sinfo
;
53 package body Expander
is
59 -- The following table is used to save values of the Expander_Active flag
60 -- when they are saved by Expander_Mode_Save_And_Set. We use an extendible
61 -- table (which is a bit of overkill) because it is easier than figuring
62 -- out a maximum value or bothering with range checks.
64 package Expander_Flags
is new Table
.Table
(
65 Table_Component_Type
=> Boolean,
66 Table_Index_Type
=> Int
,
69 Table_Increment
=> 200,
70 Table_Name
=> "Expander_Flags");
72 Abort_Bug_Box_Error
: exception;
73 -- Arbitrary exception to raise for implementation of -gnatd.B. See "when
74 -- N_Abort_Statement" below. See also debug.adb.
80 -- WARNING: This routine manages Ghost regions. Return statements must be
81 -- replaced by gotos which jump to the end of the routine and restore the
84 procedure Expand
(N
: Node_Id
) is
85 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
86 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
87 -- Save the Ghost-related attributes to restore on exit
90 -- If we were analyzing a default expression (or other spec expression)
91 -- the Full_Analysis flag must be off. If we are in expansion mode then
92 -- we must be performing a full analysis. If we are analyzing a generic
93 -- then Expansion must be off.
96 (not (Full_Analysis
and then In_Spec_Expression
)
97 and then (Full_Analysis
or else not Expander_Active
)
98 and then not (Inside_A_Generic
and then Expander_Active
));
100 -- Establish the Ghost mode of the context to ensure that any generated
101 -- nodes during expansion are marked as Ghost.
105 -- The GNATprove_Mode flag indicates that a light expansion for formal
106 -- verification should be used. This expansion is never done inside
107 -- generics, because otherwise, this breaks the name resolution
108 -- mechanism for generic instances.
110 if GNATprove_Mode
then
111 if not Inside_A_Generic
then
115 -- Do not reset the Analyzed flag if it has been set on purpose
116 -- during preanalysis.
118 if Full_Analysis
then
122 -- Regular expansion is normally followed by special handling for
123 -- transient scopes for unconstrained results, etc. but this is not
124 -- needed, and in general cannot be done correctly, in this mode, so
129 -- There are three reasons for the Expander_Active flag to be false
131 -- The first is when are not generating code. In this mode the
132 -- Full_Analysis flag indicates whether we are performing a complete
133 -- analysis, in which case Full_Analysis = True or a preanalysis in
134 -- which case Full_Analysis = False. See the spec of Sem for more info
137 -- The second reason for the Expander_Active flag to be False is that
138 -- we are performing a preanalysis. During preanalysis all expansion
139 -- activity is turned off to make sure nodes are semantically decorated
140 -- but no extra nodes are generated. This is for instance needed for
141 -- the first pass of aggregate semantic processing. Note that in this
142 -- case the Full_Analysis flag is set to False because the node will
143 -- subsequently be re-analyzed with expansion on (see the spec of sem).
145 -- Finally, expansion is turned off in a regular compilation if there
146 -- are serious errors. In that case there will be no further expansion,
147 -- but one cleanup action may be required: if a transient scope was
148 -- created (e.g. for a function that returns an unconstrained type) the
149 -- scope may still be on the stack, and must be removed explicitly,
150 -- given that the expansion actions that would normally process it will
151 -- not take place. This prevents cascaded errors due to stack mismatch.
153 elsif not Expander_Active
then
154 Set_Analyzed
(N
, Full_Analysis
);
156 if Serious_Errors_Detected
> 0 and then Scope_Is_Transient
then
158 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
:= (others => No_List
);
166 Debug_A_Entry
("expanding ", N
);
168 -- Processing depends on node kind. For full details on the
169 -- expansion activity required in each case, see bodies of
170 -- corresponding expand routines.
173 when N_Abort_Statement
=>
174 Expand_N_Abort_Statement
(N
);
176 -- If -gnatd.B switch was given, crash the compiler. See
177 -- debug.adb for explanation.
179 if Debug_Flag_Dot_BB
then
180 raise Abort_Bug_Box_Error
;
183 when N_Accept_Statement
=>
184 Expand_N_Accept_Statement
(N
);
187 Expand_N_Aggregate
(N
);
190 Expand_N_Allocator
(N
);
193 Expand_N_And_Then
(N
);
195 when N_Assignment_Statement
=>
196 Expand_N_Assignment_Statement
(N
);
198 when N_Asynchronous_Select
=>
199 Expand_N_Asynchronous_Select
(N
);
201 when N_Attribute_Definition_Clause
=>
202 Expand_N_Attribute_Definition_Clause
(N
);
204 when N_Attribute_Reference
=>
205 Expand_N_Attribute_Reference
(N
);
207 when N_Block_Statement
=>
208 Expand_N_Block_Statement
(N
);
210 when N_Case_Expression
=>
211 Expand_N_Case_Expression
(N
);
213 when N_Case_Statement
=>
214 Expand_N_Case_Statement
(N
);
216 when N_Conditional_Entry_Call
=>
217 Expand_N_Conditional_Entry_Call
(N
);
219 when N_Delay_Relative_Statement
=>
220 Expand_N_Delay_Relative_Statement
(N
);
222 when N_Delay_Until_Statement
=>
223 Expand_N_Delay_Until_Statement
(N
);
225 when N_Delta_Aggregate
=>
226 Expand_N_Delta_Aggregate
(N
);
229 Expand_N_Entry_Body
(N
);
231 when N_Entry_Call_Statement
=>
232 Expand_N_Entry_Call_Statement
(N
);
234 when N_Entry_Declaration
=>
235 Expand_N_Entry_Declaration
(N
);
237 when N_Exception_Declaration
=>
238 Expand_N_Exception_Declaration
(N
);
240 when N_Exception_Renaming_Declaration
=>
241 Expand_N_Exception_Renaming_Declaration
(N
);
243 when N_Exit_Statement
=>
244 Expand_N_Exit_Statement
(N
);
246 when N_Expanded_Name
=>
247 Expand_N_Expanded_Name
(N
);
249 when N_Explicit_Dereference
=>
250 Expand_N_Explicit_Dereference
(N
);
252 when N_Expression_With_Actions
=>
253 Expand_N_Expression_With_Actions
(N
);
255 when N_Extended_Return_Statement
=>
256 Expand_N_Extended_Return_Statement
(N
);
258 when N_Extension_Aggregate
=>
259 Expand_N_Extension_Aggregate
(N
);
261 when N_Free_Statement
=>
262 Expand_N_Free_Statement
(N
);
264 when N_Freeze_Entity
=>
265 Expand_N_Freeze_Entity
(N
);
267 when N_Full_Type_Declaration
=>
268 Expand_N_Full_Type_Declaration
(N
);
270 when N_Function_Call
=>
271 Expand_N_Function_Call
(N
);
273 when N_Generic_Instantiation
=>
274 Expand_N_Generic_Instantiation
(N
);
276 when N_Handled_Sequence_Of_Statements
=>
277 Expand_N_Handled_Sequence_Of_Statements
(N
);
280 Expand_N_Identifier
(N
);
282 when N_If_Expression
=>
283 Expand_N_If_Expression
(N
);
285 when N_Indexed_Component
=>
286 Expand_N_Indexed_Component
(N
);
288 when N_If_Statement
=>
289 Expand_N_If_Statement
(N
);
294 when N_Loop_Statement
=>
295 Expand_N_Loop_Statement
(N
);
303 when N_Object_Declaration
=>
304 Expand_N_Object_Declaration
(N
);
306 when N_Object_Renaming_Declaration
=>
307 Expand_N_Object_Renaming_Declaration
(N
);
319 Expand_N_Op_Concat
(N
);
322 Expand_N_Op_Divide
(N
);
328 Expand_N_Op_Expon
(N
);
343 Expand_N_Op_Minus
(N
);
348 when N_Op_Multiply
=>
349 Expand_N_Op_Multiply
(N
);
361 Expand_N_Op_Plus
(N
);
366 when N_Op_Rotate_Left
=>
367 Expand_N_Op_Rotate_Left
(N
);
369 when N_Op_Rotate_Right
=>
370 Expand_N_Op_Rotate_Right
(N
);
372 when N_Op_Shift_Left
=>
373 Expand_N_Op_Shift_Left
(N
);
375 when N_Op_Shift_Right
=>
376 Expand_N_Op_Shift_Right
(N
);
378 when N_Op_Shift_Right_Arithmetic
=>
379 Expand_N_Op_Shift_Right_Arithmetic
(N
);
381 when N_Op_Subtract
=>
382 Expand_N_Op_Subtract
(N
);
388 Expand_N_Or_Else
(N
);
390 when N_Package_Body
=>
391 Expand_N_Package_Body
(N
);
393 when N_Package_Declaration
=>
394 Expand_N_Package_Declaration
(N
);
396 when N_Package_Renaming_Declaration
=>
397 Expand_N_Package_Renaming_Declaration
(N
);
399 when N_Subprogram_Renaming_Declaration
=>
400 Expand_N_Subprogram_Renaming_Declaration
(N
);
405 when N_Procedure_Call_Statement
=>
406 Expand_N_Procedure_Call_Statement
(N
);
408 when N_Protected_Type_Declaration
=>
409 Expand_N_Protected_Type_Declaration
(N
);
411 when N_Protected_Body
=>
412 Expand_N_Protected_Body
(N
);
414 when N_Qualified_Expression
=>
415 Expand_N_Qualified_Expression
(N
);
417 when N_Quantified_Expression
=>
418 Expand_N_Quantified_Expression
(N
);
420 when N_Raise_Statement
=>
421 Expand_N_Raise_Statement
(N
);
423 when N_Raise_Constraint_Error
=>
424 Expand_N_Raise_Constraint_Error
(N
);
426 when N_Raise_Expression
=>
427 Expand_N_Raise_Expression
(N
);
429 when N_Raise_Program_Error
=>
430 Expand_N_Raise_Program_Error
(N
);
432 when N_Raise_Storage_Error
=>
433 Expand_N_Raise_Storage_Error
(N
);
435 when N_Real_Literal
=>
436 Expand_N_Real_Literal
(N
);
438 when N_Record_Representation_Clause
=>
439 Expand_N_Record_Representation_Clause
(N
);
441 when N_Requeue_Statement
=>
442 Expand_N_Requeue_Statement
(N
);
444 when N_Simple_Return_Statement
=>
445 Expand_N_Simple_Return_Statement
(N
);
447 when N_Selected_Component
=>
448 Expand_N_Selected_Component
(N
);
450 when N_Selective_Accept
=>
451 Expand_N_Selective_Accept
(N
);
453 when N_Single_Protected_Declaration
=>
454 Expand_N_Single_Protected_Declaration
(N
);
456 when N_Single_Task_Declaration
=>
457 Expand_N_Single_Task_Declaration
(N
);
462 when N_Subtype_Indication
=>
463 Expand_N_Subtype_Indication
(N
);
465 when N_Subprogram_Body
=>
466 Expand_N_Subprogram_Body
(N
);
468 when N_Subprogram_Body_Stub
=>
469 Expand_N_Subprogram_Body_Stub
(N
);
471 when N_Subprogram_Declaration
=>
472 Expand_N_Subprogram_Declaration
(N
);
475 Expand_N_Task_Body
(N
);
477 when N_Task_Type_Declaration
=>
478 Expand_N_Task_Type_Declaration
(N
);
480 when N_Timed_Entry_Call
=>
481 Expand_N_Timed_Entry_Call
(N
);
483 when N_Type_Conversion
=>
484 Expand_N_Type_Conversion
(N
);
486 when N_Unchecked_Expression
=>
487 Expand_N_Unchecked_Expression
(N
);
489 when N_Unchecked_Type_Conversion
=>
490 Expand_N_Unchecked_Type_Conversion
(N
);
492 when N_Variant_Part
=>
493 Expand_N_Variant_Part
(N
);
495 -- For all other node kinds, no expansion activity required
502 when RE_Not_Available
=>
506 -- Set result as analyzed and then do a possible transient wrap. The
507 -- transient wrap must be done after the Analyzed flag is set on, so
508 -- that we do not get a recursive attempt to expand the node N.
512 -- Deal with transient scopes
514 if Scope_Is_Transient
and then N
= Node_To_Be_Wrapped
then
516 when N_Procedure_Call_Statement
517 | N_Statement_Other_Than_Procedure_Call
519 Wrap_Transient_Statement
(N
);
521 when N_Object_Declaration
522 | N_Object_Renaming_Declaration
523 | N_Subtype_Declaration
525 Wrap_Transient_Declaration
(N
);
528 Wrap_Transient_Expression
(N
);
532 Debug_A_Exit
("expanding ", N
, " (done)");
536 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
539 ---------------------------
540 -- Expander_Mode_Restore --
541 ---------------------------
543 procedure Expander_Mode_Restore
is
545 -- Not active (has no effect) in GNATprove mode (see comments
546 -- in spec of Expander_Mode_Save_And_Set).
548 if GNATprove_Mode
then
552 -- Otherwise restore the flag
554 Expander_Active
:= Expander_Flags
.Table
(Expander_Flags
.Last
);
555 Expander_Flags
.Decrement_Last
;
557 -- Keep expander off if serious errors detected. In this case we do not
558 -- need expansion, and continued expansion may cause cascaded errors or
561 if Serious_Errors_Detected
/= 0 then
562 Expander_Active
:= False;
564 end Expander_Mode_Restore
;
566 --------------------------------
567 -- Expander_Mode_Save_And_Set --
568 --------------------------------
570 procedure Expander_Mode_Save_And_Set
(Status
: Boolean) is
572 -- Not active (has no effect) in GNATprove modes (see comments
573 -- in spec of Expander_Mode_Save_And_Set).
575 if GNATprove_Mode
then
579 -- Otherwise save and set the flag
581 Expander_Flags
.Increment_Last
;
582 Expander_Flags
.Table
(Expander_Flags
.Last
) := Expander_Active
;
583 Expander_Active
:= Status
;
584 end Expander_Mode_Save_And_Set
;