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 Casing
; use Casing
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Elists
; use Elists
;
32 with Errout
; use Errout
;
33 with Exp_Ch11
; use Exp_Ch11
;
34 with Exp_Util
; use Exp_Util
;
35 with Expander
; use Expander
;
36 with Inline
; use Inline
;
38 with Namet
; use Namet
;
39 with Nlists
; use Nlists
;
40 with Nmake
; use Nmake
;
42 with Restrict
; use Restrict
;
43 with Rident
; use Rident
;
44 with Rtsfind
; use Rtsfind
;
46 with Sem_Aux
; use Sem_Aux
;
47 with Sem_Ch8
; use Sem_Ch8
;
48 with Sem_Prag
; use Sem_Prag
;
49 with Sem_Util
; use Sem_Util
;
50 with Sinfo
; use Sinfo
;
51 with Sinput
; use Sinput
;
52 with Snames
; use Snames
;
53 with Stringt
; use Stringt
;
54 with Stand
; use Stand
;
55 with Tbuild
; use Tbuild
;
56 with Uintp
; use Uintp
;
57 with Validsw
; use Validsw
;
59 package body Exp_Prag
is
61 -----------------------
62 -- Local Subprograms --
63 -----------------------
65 function Arg_N
(N
: Node_Id
; Arg_Number
: Positive) return Node_Id
;
66 -- Obtain specified pragma argument expression
68 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
);
69 procedure Expand_Pragma_Check
(N
: Node_Id
);
70 procedure Expand_Pragma_Common_Object
(N
: Node_Id
);
71 procedure Expand_Pragma_CUDA_Execute
(N
: Node_Id
);
72 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
);
73 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
);
74 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
);
75 procedure Expand_Pragma_Loop_Variant
(N
: Node_Id
);
76 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
);
77 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
);
78 procedure Expand_Pragma_Suppress_Initialization
(N
: Node_Id
);
80 procedure Undo_Initialization
(Def_Id
: Entity_Id
; N
: Node_Id
);
81 -- This procedure is used to undo initialization already done for Def_Id,
82 -- which is always an E_Variable, in response to the occurrence of the
83 -- pragma N, a pragma Interface, Import, or Suppress_Initialization. In all
84 -- these cases we want no initialization to occur, but we have already done
85 -- the initialization by the time we see the pragma, so we have to undo it.
91 function Arg_N
(N
: Node_Id
; Arg_Number
: Positive) return Node_Id
is
92 Arg
: Node_Id
:= First
(Pragma_Argument_Associations
(N
));
98 for J
in 2 .. Arg_Number
loop
106 and then Nkind
(Arg
) = N_Pragma_Argument_Association
108 return Expression
(Arg
);
114 ---------------------
115 -- Expand_N_Pragma --
116 ---------------------
118 procedure Expand_N_Pragma
(N
: Node_Id
) is
119 Pname
: constant Name_Id
:= Pragma_Name
(N
);
120 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
123 -- Suppress the expansion of an ignored assertion pragma. Such a pragma
124 -- should not be transformed into a null statment because:
126 -- * The pragma may be part of the rep item chain of a type, in which
127 -- case rewriting it will destroy the chain.
129 -- * The analysis of the pragma may involve two parts (see routines
130 -- Analyze_xxx_In_Decl_Part). The second part of the analysis will
131 -- not happen if the pragma is rewritten.
133 if Assertion_Expression_Pragma
(Prag_Id
) and then Is_Ignored
(N
) then
136 -- Rewrite the pragma into a null statement when it is ignored using
137 -- pragma Ignore_Pragma, or denotes Default_Scalar_Storage_Order and
138 -- compilation switch -gnatI is in effect.
140 elsif Should_Ignore_Pragma_Sem
(N
)
141 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
142 and then Ignore_Rep_Clauses
)
144 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
150 -- Pragmas requiring special expander action
152 when Pragma_Abort_Defer
=>
153 Expand_Pragma_Abort_Defer
(N
);
156 Expand_Pragma_Check
(N
);
158 when Pragma_Common_Object
=>
159 Expand_Pragma_Common_Object
(N
);
161 when Pragma_CUDA_Execute
=>
162 Expand_Pragma_CUDA_Execute
(N
);
164 when Pragma_Import
=>
165 Expand_Pragma_Import_Or_Interface
(N
);
167 when Pragma_Inspection_Point
=>
168 Expand_Pragma_Inspection_Point
(N
);
170 when Pragma_Interface
=>
171 Expand_Pragma_Import_Or_Interface
(N
);
173 when Pragma_Interrupt_Priority
=>
174 Expand_Pragma_Interrupt_Priority
(N
);
176 when Pragma_Loop_Variant
=>
177 Expand_Pragma_Loop_Variant
(N
);
179 when Pragma_Psect_Object
=>
180 Expand_Pragma_Psect_Object
(N
);
182 when Pragma_Relative_Deadline
=>
183 Expand_Pragma_Relative_Deadline
(N
);
185 when Pragma_Suppress_Initialization
=>
186 Expand_Pragma_Suppress_Initialization
(N
);
188 -- All other pragmas need no expander action (includes
195 -------------------------------
196 -- Expand_Pragma_Abort_Defer --
197 -------------------------------
199 -- An Abort_Defer pragma appears as the first statement in a handled
200 -- statement sequence (right after the begin). It defers aborts for
201 -- the entire statement sequence, but not for any declarations or
202 -- handlers (if any) associated with this statement sequence.
204 -- The transformation is to transform
206 -- pragma Abort_Defer;
215 -- when all others =>
216 -- Abort_Undefer.all;
219 -- Abort_Undefer_Direct;
222 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
) is
224 -- Abort_Defer has no useful effect if Abort's are not allowed
226 if not Abort_Allowed
then
230 -- Normal case where abort is possible
233 Loc
: constant Source_Ptr
:= Sloc
(N
);
237 Blk
: constant Entity_Id
:=
238 New_Internal_Entity
(E_Block
, Current_Scope
, Sloc
(N
), 'B');
239 AUD
: constant Entity_Id
:= RTE
(RE_Abort_Undefer_Direct
);
242 Stms
:= New_List
(Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
244 Stm
:= Remove_Next
(N
);
250 Make_Handled_Sequence_Of_Statements
(Loc
,
252 At_End_Proc
=> New_Occurrence_Of
(AUD
, Loc
));
254 -- Present the Abort_Undefer_Direct function to the backend so that
255 -- it can inline the call to the function.
257 Add_Inlined_Body
(AUD
, N
);
260 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
));
262 Set_Scope
(Blk
, Current_Scope
);
263 Set_Etype
(Blk
, Standard_Void_Type
);
264 Set_Identifier
(N
, New_Occurrence_Of
(Blk
, Sloc
(N
)));
265 Expand_At_End_Handler
(HSS
, Blk
);
268 end Expand_Pragma_Abort_Defer
;
270 --------------------------
271 -- Expand_Pragma_Check --
272 --------------------------
274 procedure Expand_Pragma_Check
(N
: Node_Id
) is
275 Cond
: constant Node_Id
:= Arg_N
(N
, 2);
276 Nam
: constant Name_Id
:= Chars
(Arg_N
(N
, 1));
279 Loc
: constant Source_Ptr
:= Sloc
(First_Node
(Cond
));
280 -- Source location used in the case of a failed assertion: point to the
281 -- failing condition, not Loc. Note that the source location of the
282 -- expression is not usually the best choice here, because it points to
283 -- the location of the topmost tree node, which may be an operator in
284 -- the middle of the source text of the expression. For example, it gets
285 -- located on the last AND keyword in a chain of boolean expressiond
286 -- AND'ed together. It is best to put the message on the first character
287 -- of the condition, which is the effect of the First_Node call here.
288 -- This source location is used to build the default exception message,
289 -- and also as the sloc of the call to the runtime subprogram raising
290 -- Assert_Failure, so that coverage analysis tools can relate the
291 -- call to the failed check.
293 procedure Replace_Discriminals_Of_Protected_Op
(Expr
: Node_Id
);
294 -- Discriminants of the enclosing protected object may be referenced
295 -- in the expression of a precondition of a protected operation.
296 -- In the body of the operation these references must be replaced by
297 -- the discriminal created for them, which are renamings of the
298 -- discriminants of the object that is the target of the operation.
299 -- This replacement is done by visibility when the references appear
300 -- in the subprogram body, but in the case of a condition which appears
301 -- on the specification of the subprogram it has be done separately
302 -- because the condition has been replaced by a Check pragma and
303 -- analyzed earlier, before the creation of the discriminal renaming
304 -- declarations that are added to the subprogram body.
306 ------------------------------------------
307 -- Replace_Discriminals_Of_Protected_Op --
308 ------------------------------------------
310 procedure Replace_Discriminals_Of_Protected_Op
(Expr
: Node_Id
) is
311 function Find_Corresponding_Discriminal
312 (E
: Entity_Id
) return Entity_Id
;
313 -- Find the local entity that renames a discriminant of the enclosing
314 -- protected type, and has a matching name.
316 function Replace_Discr_Ref
(N
: Node_Id
) return Traverse_Result
;
317 -- Replace a reference to a discriminant of the original protected
318 -- type by the local renaming declaration of the discriminant of
319 -- the target object.
321 ------------------------------------
322 -- Find_Corresponding_Discriminal --
323 ------------------------------------
325 function Find_Corresponding_Discriminal
326 (E
: Entity_Id
) return Entity_Id
331 R
:= First_Entity
(Current_Scope
);
333 while Present
(R
) loop
334 if Nkind
(Parent
(R
)) = N_Object_Renaming_Declaration
335 and then Present
(Discriminal_Link
(R
))
336 and then Chars
(Discriminal_Link
(R
)) = Chars
(E
)
345 end Find_Corresponding_Discriminal
;
347 -----------------------
348 -- Replace_Discr_Ref --
349 -----------------------
351 function Replace_Discr_Ref
(N
: Node_Id
) return Traverse_Result
is
355 if Is_Entity_Name
(N
)
356 and then Present
(Discriminal_Link
(Entity
(N
)))
358 R
:= Find_Corresponding_Discriminal
(Entity
(N
));
359 Rewrite
(N
, New_Occurrence_Of
(R
, Sloc
(N
)));
363 end Replace_Discr_Ref
;
365 procedure Replace_Discriminant_References
is
366 new Traverse_Proc
(Replace_Discr_Ref
);
368 -- Start of processing for Replace_Discriminals_Of_Protected_Op
371 Replace_Discriminant_References
(Expr
);
372 end Replace_Discriminals_Of_Protected_Op
;
374 -- Start of processing for Expand_Pragma_Check
377 -- Nothing to do if pragma is ignored
379 if Is_Ignored
(N
) then
383 -- Since this check is active, rewrite the pragma into a corresponding
384 -- if statement, and then analyze the statement.
386 -- The normal case expansion transforms:
388 -- pragma Check (name, condition [,message]);
392 -- if not condition then
393 -- System.Assertions.Raise_Assert_Failure (Str);
396 -- where Str is the message if one is present, or the default of
397 -- name failed at file:line if no message is given (the "name failed
398 -- at" is omitted for name = Assertion, since it is redundant, given
399 -- that the name of the exception is Assert_Failure.)
401 -- Also, instead of "XXX failed at", we generate slightly
402 -- different messages for some of the contract assertions (see
403 -- code below for details).
405 -- An alternative expansion is used when the No_Exception_Propagation
406 -- restriction is active and there is a local Assert_Failure handler.
407 -- This is not a common combination of circumstances, but it occurs in
408 -- the context of Aunit and the zero footprint profile. In this case we
411 -- if not condition then
412 -- raise Assert_Failure;
415 -- This will then be transformed into a goto, and the local handler will
416 -- be able to handle the assert error (which would not be the case if a
417 -- call is made to the Raise_Assert_Failure procedure).
419 -- We also generate the direct raise if the Suppress_Exception_Locations
420 -- is active, since we don't want to generate messages in this case.
422 -- Note that the reason we do not always generate a direct raise is that
423 -- the form in which the procedure is called allows for more efficient
424 -- breakpointing of assertion errors.
426 -- Generate the appropriate if statement. Note that we consider this to
427 -- be an explicit conditional in the source, not an implicit if, so we
428 -- do not call Make_Implicit_If_Statement. Note also that we wrap the
429 -- raise statement in a block statement so that, if the condition is
430 -- evaluated at compile time to False, then the rewriting of the if
431 -- statement will not involve the raise but the block statement, and
432 -- thus not leave a dangling reference to the raise statement in the
433 -- Local_Raise_Statements list of the handler.
435 -- Case where we generate a direct raise
437 if ((Debug_Flag_Dot_G
438 or else Restriction_Active
(No_Exception_Propagation
))
439 and then Present
(Find_Local_Handler
(RTE
(RE_Assert_Failure
), N
)))
440 or else (Opt
.Exception_Locations_Suppressed
and then No
(Arg_N
(N
, 3)))
443 Make_If_Statement
(Loc
,
444 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Cond
),
445 Then_Statements
=> New_List
(
446 Make_Block_Statement
(Loc
,
447 Handled_Statement_Sequence
=>
448 Make_Handled_Sequence_Of_Statements
(Loc
,
449 Statements
=> New_List
(
450 Make_Raise_Statement
(Loc
,
452 New_Occurrence_Of
(RTE
(RE_Assert_Failure
),
455 -- Case where we call the procedure
458 -- If we have a message given, use it
460 if Present
(Arg_N
(N
, 3)) then
461 Msg
:= Get_Pragma_Arg
(Arg_N
(N
, 3));
463 -- Here we have no string, so prepare one
467 Loc_Str
: constant String := Build_Location_String
(Loc
);
472 -- For Assert, we just use the location
474 if Nam
= Name_Assert
then
477 -- For predicate, we generate the string "predicate failed at
478 -- yyy". We prefer all lower case for predicate.
480 elsif Nam
= Name_Predicate
then
481 Add_Str_To_Name_Buffer
("predicate failed at ");
483 -- For special case of Precondition/Postcondition the string is
484 -- "failed xx from yy" where xx is precondition/postcondition
485 -- in all lower case. The reason for this different wording is
486 -- that the failure is not at the point of occurrence of the
487 -- pragma, unlike the other Check cases.
489 elsif Nam
in Name_Precondition | Name_Postcondition
then
490 Get_Name_String
(Nam
);
491 Insert_Str_In_Name_Buffer
("failed ", 1);
492 Add_Str_To_Name_Buffer
(" from ");
494 -- For special case of Invariant, the string is "failed
495 -- invariant from yy", to be consistent with the string that is
496 -- generated for the aspect case (the code later on checks for
497 -- this specific string to modify it in some cases, so this is
498 -- functionally important).
500 elsif Nam
= Name_Invariant
then
501 Add_Str_To_Name_Buffer
("failed invariant from ");
503 -- For all other checks, the string is "xxx failed at yyy"
504 -- where xxx is the check name with appropriate casing.
507 Get_Name_String
(Nam
);
509 (Identifier_Casing
(Source_Index
(Current_Sem_Unit
)));
510 Add_Str_To_Name_Buffer
(" failed at ");
513 -- In all cases, add location string
515 Add_Str_To_Name_Buffer
(Loc_Str
);
519 Msg
:= Make_String_Literal
(Loc
, Name_Buffer
(1 .. Name_Len
));
523 -- For a precondition, replace references to discriminants of a
524 -- protected type with the local discriminals.
526 if Is_Protected_Type
(Scope
(Current_Scope
))
527 and then Has_Discriminants
(Scope
(Current_Scope
))
528 and then From_Aspect_Specification
(N
)
530 Replace_Discriminals_Of_Protected_Op
(Cond
);
533 -- Now rewrite as an if statement
536 Make_If_Statement
(Loc
,
537 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Cond
),
538 Then_Statements
=> New_List
(
539 Make_Procedure_Call_Statement
(Loc
,
541 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
542 Parameter_Associations
=> New_List
(Relocate_Node
(Msg
))))));
547 -- If new condition is always false, give a warning
549 if Warn_On_Assertion_Failure
550 and then Nkind
(N
) = N_Procedure_Call_Statement
551 and then Is_RTE
(Entity
(Name
(N
)), RE_Raise_Assert_Failure
)
553 -- If original condition was a Standard.False, we assume that this is
554 -- indeed intended to raise assert error and no warning is required.
556 if Is_Entity_Name
(Original_Node
(Cond
))
557 and then Entity
(Original_Node
(Cond
)) = Standard_False
561 elsif Nam
= Name_Assert
then
562 Error_Msg_N
("?A?assertion will fail at run time", N
);
564 Error_Msg_N
("?A?check will fail at run time", N
);
567 end Expand_Pragma_Check
;
569 ---------------------------------
570 -- Expand_Pragma_Common_Object --
571 ---------------------------------
573 -- Use a machine attribute to replicate semantic effect in DEC Ada
575 -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
577 -- For now we do nothing with the size attribute ???
579 -- Note: Psect_Object shares this processing
581 procedure Expand_Pragma_Common_Object
(N
: Node_Id
) is
582 Loc
: constant Source_Ptr
:= Sloc
(N
);
584 Internal
: constant Node_Id
:= Arg_N
(N
, 1);
585 External
: constant Node_Id
:= Arg_N
(N
, 2);
588 -- Psect value upper cased as string literal
590 Iloc
: constant Source_Ptr
:= Sloc
(Internal
);
591 Eloc
: constant Source_Ptr
:= Sloc
(External
);
595 -- Acquire Psect value and fold to upper case
597 if Present
(External
) then
598 if Nkind
(External
) = N_String_Literal
then
599 String_To_Name_Buffer
(Strval
(External
));
601 Get_Name_String
(Chars
(External
));
607 Make_String_Literal
(Eloc
, Strval
=> String_From_Name_Buffer
);
610 Get_Name_String
(Chars
(Internal
));
613 Make_String_Literal
(Iloc
, Strval
=> String_From_Name_Buffer
);
616 Ploc
:= Sloc
(Psect
);
620 Insert_After_And_Analyze
(N
,
622 Chars
=> Name_Machine_Attribute
,
623 Pragma_Argument_Associations
=> New_List
(
624 Make_Pragma_Argument_Association
(Iloc
,
625 Expression
=> New_Copy_Tree
(Internal
)),
626 Make_Pragma_Argument_Association
(Eloc
,
628 Make_String_Literal
(Sloc
=> Ploc
, Strval
=> "common_object")),
629 Make_Pragma_Argument_Association
(Ploc
,
630 Expression
=> New_Copy_Tree
(Psect
)))));
631 end Expand_Pragma_Common_Object
;
633 --------------------------------
634 -- Expand_Pragma_CUDA_Execute --
635 --------------------------------
637 -- Pragma CUDA_Execute is expanded in the following manner:
641 -- pragma CUDA_Execute (My_Proc (X, Y), Blocks, Grids, Mem, Stream)
646 -- Blocks_Id : CUDA.Vector_Types.Dim3 := Blocks;
647 -- Grids_Id : CUDA.Vector_Types.Dim3 := Grids;
648 -- Mem_Id : Integer := <Mem or 0>;
649 -- Stream_Id : CUDA.Driver_Types.Stream_T := <Stream or null>;
650 -- X_Id : <Type of X> := X;
651 -- Y_Id : <Type of Y> := Y;
652 -- Arg_Id : Array (1..2) of System.Address :=
653 -- (X'Address,_Id Y'Address);_Id
655 -- CUDA.Internal.Push_Call_Configuration (
660 -- CUDA.Internal.Pop_Call_Configuration (
662 -- Blocks_Id'address,
664 -- Stream_Id'address),
665 -- CUDA.Runtime_Api.Launch_Kernel (
674 procedure Expand_Pragma_CUDA_Execute
(N
: Node_Id
) is
676 Loc
: constant Source_Ptr
:= Sloc
(N
);
678 procedure Append_Copies
682 -- For each parameter in list Params, create an object declaration of
683 -- the followinng form:
685 -- Copy_Id : Param_Typ := Param_Val;
687 -- Param_Typ is the type of the parameter. Param_Val is the initial
688 -- value of the parameter. The declarations are stored in Decls, the
689 -- entities of the new objects are collected in list Copies.
691 function Build_Dim3_Declaration
692 (Decl_Id
: Entity_Id
;
693 Init_Val
: Node_Id
) return Node_Id
;
694 -- Build an object declaration of the form
696 -- Decl_Id : CUDA.Internal.Dim3 := Val;
698 -- Val depends on the nature of Init_Val, as follows:
700 -- * If Init_Val is of type CUDA.Vector_Types.Dim3, then Val has the
703 -- (Interfaces.C.Unsigned (Val.X),
704 -- Interfaces.C.Unsigned (Val.Y),
705 -- Interfaces.C.Unsigned (Val.Z))
707 -- * If Init_Val is a single Integer, Val has the following form:
709 -- (Interfaces.C.Unsigned (Init_Val),
710 -- Interfaces.C.Unsigned (1),
711 -- Interfaces.C.Unsigned (1))
713 -- * If Init_Val is an aggregate of three values, Val has the
716 -- (Interfaces.C.Unsigned (Val_1),
717 -- Interfaces.C.Unsigned (Val_2),
718 -- Interfaces.C.Unsigned (Val_3))
720 function Build_Kernel_Args_Declaration
721 (Kernel_Arg
: Entity_Id
;
722 Var_Ids
: Elist_Id
) return Node_Id
;
723 -- Given a list of variables, return an object declaration of the
726 -- Kernel_Arg : ... := (Var_1'Address, ..., Var_N'Address);
728 function Build_Launch_Kernel_Call
730 Grid_Dims
: Entity_Id
;
731 Block_Dims
: Entity_Id
;
732 Kernel_Arg
: Entity_Id
;
734 Stream
: Entity_Id
) return Node_Id
;
735 -- Builds and returns a call to CUDA.Launch_Kernel using the given
736 -- arguments. Proc is the entity of the procedure passed to the
737 -- CUDA_Execute pragma. Grid_Dims and Block_Dims are entities of the
738 -- generated declarations that hold the kernel's dimensions. Args is the
739 -- entity of the temporary array that holds the arguments of the kernel.
740 -- Memory and Stream are the entities of the temporaries that hold the
741 -- fourth and fith arguments of CUDA_Execute or their default values.
743 function Build_Shared_Memory_Declaration
744 (Decl_Id
: Entity_Id
;
745 Init_Val
: Node_Id
) return Node_Id
;
746 -- Builds a declaration the Defining_Identifier of which is Decl_Id, the
747 -- type of which is inferred from CUDA.Internal.Launch_Kernel and the
748 -- value of which is Init_Val if present or null if not.
750 function Build_Simple_Declaration_With_Default
751 (Decl_Id
: Entity_Id
;
752 Init_Val
: Entity_Id
;
754 Default_Val
: Entity_Id
) return Node_Id
;
755 -- Build a declaration the Defining_Identifier of which is Decl_Id, the
756 -- Object_Definition of which is Typ, the value of which is Init_Val if
757 -- present or Default otherwise.
759 function Build_Stream_Declaration
760 (Decl_Id
: Entity_Id
;
761 Init_Val
: Node_Id
) return Node_Id
;
762 -- Build a declaration the Defining_Identifier of which is Decl_Id, the
763 -- type of which is Integer, the value of which is Init_Val if present
766 function Etype_Or_Dim3
(N
: Node_Id
) return Node_Id
;
767 -- If N is an aggregate whose type is unknown, return a new occurrence
768 -- of the public Dim3 type. Otherwise, return a new occurrence of N's
771 function Get_Nth_Arg_Type
772 (Subprogram
: Entity_Id
;
773 N
: Positive) return Entity_Id
;
774 -- Returns the type of the Nth argument of Subprogram.
776 function To_Addresses
(Elmts
: Elist_Id
) return List_Id
;
777 -- Returns a new list containing each element of Elmts wrapped in an
778 -- 'address attribute reference. When passed No_Elist, returns an empty
785 procedure Append_Copies
794 Param
:= First
(Params
);
795 while Present
(Param
) loop
796 Copy
:= Make_Temporary
(Loc
, 'C');
798 if Nkind
(Param
) = N_Parameter_Association
then
799 Expr
:= Explicit_Actual_Parameter
(Param
);
805 Make_Object_Declaration
(Loc
,
806 Defining_Identifier
=> Copy
,
807 Object_Definition
=> New_Occurrence_Of
(Etype
(Expr
), Loc
),
808 Expression
=> New_Copy_Tree
(Expr
)));
810 Append_Elmt
(Copy
, Copies
);
815 ----------------------------
816 -- Build_Dim3_Declaration --
817 ----------------------------
819 function Build_Dim3_Declaration
820 (Decl_Id
: Entity_Id
;
821 Init_Val
: Node_Id
) return Node_Id
823 -- Expressions for each component of the returned Dim3
828 -- Type of CUDA.Internal.Dim3 - inferred from
829 -- RE_Push_Call_Configuration to avoid needing changes in GNAT when
830 -- the CUDA bindings change (this happens frequently).
831 Internal_Dim3
: constant Entity_Id
:=
832 Get_Nth_Arg_Type
(RTE
(RE_Push_Call_Configuration
), 1);
834 -- Entities for each component of external and internal Dim3
835 First_Component
: Entity_Id
:= First_Entity
(RTE
(RE_Dim3
));
836 Second_Component
: Entity_Id
:= Next_Entity
(First_Component
);
837 Third_Component
: Entity_Id
:= Next_Entity
(Second_Component
);
840 -- Sem_prag.adb ensured that Init_Val is either a Dim3, an
841 -- aggregate of three Any_Integers or Any_Integer.
843 -- If Init_Val is a Dim3, use each of its components.
845 if Etype
(Init_Val
) = RTE
(RE_Dim3
) then
846 Dim_X
:= Make_Selected_Component
(Loc
,
847 Prefix
=> New_Occurrence_Of
(Entity
(Init_Val
), Loc
),
848 Selector_Name
=> New_Occurrence_Of
(First_Component
, Loc
));
850 Dim_Y
:= Make_Selected_Component
(Loc
,
851 Prefix
=> New_Occurrence_Of
(Entity
(Init_Val
), Loc
),
852 Selector_Name
=> New_Occurrence_Of
(Second_Component
, Loc
));
854 Dim_Z
:= Make_Selected_Component
(Loc
,
855 Prefix
=> New_Occurrence_Of
(Entity
(Init_Val
), Loc
),
856 Selector_Name
=> New_Occurrence_Of
(Third_Component
, Loc
));
858 -- If Init_Val is an aggregate, use each of its arguments
860 if Nkind
(Init_Val
) = N_Aggregate
then
861 Dim_X
:= First
(Expressions
(Init_Val
));
862 Dim_Y
:= Next
(Dim_X
);
863 Dim_Z
:= Next
(Dim_Y
);
865 -- Otherwise, we know it is an integer and the rest defaults to 1.
869 Dim_Y
:= Make_Integer_Literal
(Loc
, 1);
870 Dim_Z
:= Make_Integer_Literal
(Loc
, 1);
874 First_Component
:= First_Entity
(Internal_Dim3
);
875 Second_Component
:= Next_Entity
(First_Component
);
876 Third_Component
:= Next_Entity
(Second_Component
);
878 -- Finally return the CUDA.Internal.Dim3 declaration with an
879 -- aggregate initialization expression.
881 return Make_Object_Declaration
(Loc
,
882 Defining_Identifier
=> Decl_Id
,
883 Object_Definition
=> New_Occurrence_Of
(Internal_Dim3
, Loc
),
884 Expression
=> Make_Aggregate
(Loc
,
885 Expressions
=> New_List
(
886 Make_Type_Conversion
(Loc
,
888 New_Occurrence_Of
(Etype
(First_Component
), Loc
),
889 Expression
=> New_Copy_Tree
(Dim_X
)),
890 Make_Type_Conversion
(Loc
,
892 New_Occurrence_Of
(Etype
(Second_Component
), Loc
),
893 Expression
=> New_Copy_Tree
(Dim_Y
)),
894 Make_Type_Conversion
(Loc
,
896 New_Occurrence_Of
(Etype
(Third_Component
), Loc
),
897 Expression
=> New_Copy_Tree
(Dim_Z
)))));
898 end Build_Dim3_Declaration
;
900 -----------------------------------
901 -- Build_Kernel_Args_Declaration --
902 -----------------------------------
904 function Build_Kernel_Args_Declaration
905 (Kernel_Arg
: Entity_Id
;
906 Var_Ids
: Elist_Id
) return Node_Id
908 Vals
: constant List_Id
:= To_Addresses
(Var_Ids
);
911 Make_Object_Declaration
(Loc
,
912 Defining_Identifier
=> Kernel_Arg
,
914 Make_Constrained_Array_Definition
(Loc
,
915 Discrete_Subtype_Definitions
=> New_List
(
917 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
919 Make_Integer_Literal
(Loc
, List_Length
(Vals
)))),
920 Component_Definition
=>
921 Make_Component_Definition
(Loc
,
922 Subtype_Indication
=>
923 New_Occurrence_Of
(Etype
(RTE
(RE_Address
)), Loc
))),
924 Expression
=> Make_Aggregate
(Loc
, Vals
));
925 end Build_Kernel_Args_Declaration
;
927 -------------------------------
928 -- Build_Launch_Kernel_Call --
929 -------------------------------
931 function Build_Launch_Kernel_Call
933 Grid_Dims
: Entity_Id
;
934 Block_Dims
: Entity_Id
;
935 Kernel_Arg
: Entity_Id
;
937 Stream
: Entity_Id
) return Node_Id
is
940 Make_Procedure_Call_Statement
(Loc
,
942 New_Occurrence_Of
(RTE
(RE_Launch_Kernel
), Loc
),
943 Parameter_Associations
=> New_List
(
944 Make_Attribute_Reference
(Loc
,
945 Prefix
=> New_Occurrence_Of
(Proc
, Loc
),
946 Attribute_Name
=> Name_Address
),
947 New_Occurrence_Of
(Grid_Dims
, Loc
),
948 New_Occurrence_Of
(Block_Dims
, Loc
),
949 Make_Attribute_Reference
(Loc
,
950 Prefix
=> New_Occurrence_Of
(Kernel_Arg
, Loc
),
951 Attribute_Name
=> Name_Address
),
952 New_Occurrence_Of
(Memory
, Loc
),
953 New_Occurrence_Of
(Stream
, Loc
)));
954 end Build_Launch_Kernel_Call
;
956 -------------------------------------
957 -- Build_Shared_Memory_Declaration --
958 -------------------------------------
960 function Build_Shared_Memory_Declaration
961 (Decl_Id
: Entity_Id
;
962 Init_Val
: Node_Id
) return Node_Id
965 return Build_Simple_Declaration_With_Default
967 Init_Val
=> Init_Val
,
970 (Get_Nth_Arg_Type
(RTE
(RE_Launch_Kernel
), 5), Loc
),
971 Default_Val
=> Make_Integer_Literal
(Loc
, 0));
972 end Build_Shared_Memory_Declaration
;
974 -------------------------------------------
975 -- Build_Simple_Declaration_With_Default --
976 -------------------------------------------
978 function Build_Simple_Declaration_With_Default
979 (Decl_Id
: Entity_Id
;
982 Default_Val
: Node_Id
) return Node_Id
984 Value
: Node_Id
:= Init_Val
;
987 Value
:= Default_Val
;
990 return Make_Object_Declaration
(Loc
,
991 Defining_Identifier
=> Decl_Id
,
992 Object_Definition
=> Typ
,
993 Expression
=> Value
);
994 end Build_Simple_Declaration_With_Default
;
996 ------------------------------
997 -- Build_Stream_Declaration --
998 ------------------------------
1000 function Build_Stream_Declaration
1001 (Decl_Id
: Entity_Id
;
1002 Init_Val
: Node_Id
) return Node_Id
1005 return Build_Simple_Declaration_With_Default
1006 (Decl_Id
=> Decl_Id
,
1007 Init_Val
=> Init_Val
,
1010 (Get_Nth_Arg_Type
(RTE
(RE_Launch_Kernel
), 6), Loc
),
1011 Default_Val
=> Make_Null
(Loc
));
1012 end Build_Stream_Declaration
;
1014 ------------------------
1016 ------------------------
1018 function Etype_Or_Dim3
(N
: Node_Id
) return Node_Id
is
1020 if Nkind
(N
) = N_Aggregate
and then Is_Composite_Type
(Etype
(N
))
1022 return New_Occurrence_Of
(RTE
(RE_Dim3
), Sloc
(N
));
1025 return New_Occurrence_Of
(Etype
(N
), Loc
);
1028 ----------------------
1029 -- Get_Nth_Arg_Type --
1030 ----------------------
1032 function Get_Nth_Arg_Type
1033 (Subprogram
: Entity_Id
;
1034 N
: Positive) return Entity_Id
1036 Argument
: Entity_Id
:= First_Entity
(Subprogram
);
1038 for J
in 2 .. N
loop
1039 Argument
:= Next_Entity
(Argument
);
1042 return Etype
(Argument
);
1043 end Get_Nth_Arg_Type
;
1049 function To_Addresses
(Elmts
: Elist_Id
) return List_Id
is
1050 Result
: constant List_Id
:= New_List
;
1053 if Elmts
= No_Elist
then
1057 Elmt
:= First_Elmt
(Elmts
);
1058 while Present
(Elmt
) loop
1060 Make_Attribute_Reference
(Loc
,
1061 Prefix
=> New_Occurrence_Of
(Node
(Elmt
), Loc
),
1062 Attribute_Name
=> Name_Address
));
1073 Procedure_Call
: constant Node_Id
:= Get_Pragma_Arg
(Arg_N
(N
, 1));
1074 Grid_Dimensions
: constant Node_Id
:= Get_Pragma_Arg
(Arg_N
(N
, 2));
1075 Block_Dimensions
: constant Node_Id
:= Get_Pragma_Arg
(Arg_N
(N
, 3));
1076 Shared_Memory
: constant Node_Id
:= Get_Pragma_Arg
(Arg_N
(N
, 4));
1077 CUDA_Stream
: constant Node_Id
:= Get_Pragma_Arg
(Arg_N
(N
, 5));
1079 -- Entities of objects that will be overwritten by calls to cuda runtime
1080 Grids_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1081 Blocks_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1082 Memory_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1083 Stream_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1085 -- Entities of objects that capture the value of pragma arguments
1086 Temp_Grid
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1087 Temp_Block
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1089 -- Declarations for temporary block and grids. These needs to be stored
1090 -- in temporary declarations as the expressions will need to be
1091 -- referenced multiple times but could have side effects.
1092 Temp_Grid_Decl
: constant Node_Id
:= Make_Object_Declaration
(Loc
,
1093 Defining_Identifier
=> Temp_Grid
,
1094 Object_Definition
=> Etype_Or_Dim3
(Grid_Dimensions
),
1095 Expression
=> Grid_Dimensions
);
1096 Temp_Block_Decl
: constant Node_Id
:= Make_Object_Declaration
(Loc
,
1097 Defining_Identifier
=> Temp_Block
,
1098 Object_Definition
=> Etype_Or_Dim3
(Block_Dimensions
),
1099 Expression
=> Block_Dimensions
);
1101 -- List holding the entities of the copies of Procedure_Call's
1104 Kernel_Arg_Copies
: constant Elist_Id
:= New_Elmt_List
;
1106 -- Entity of the array that contains the address of each of the kernel's
1109 Kernel_Args_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1111 -- Calls to the CUDA runtime API.
1113 Launch_Kernel_Call
: Node_Id
;
1115 Push_Call
: Node_Id
;
1117 -- Declaration of all temporaries required for CUDA API Calls.
1119 Blk_Decls
: constant List_Id
:= New_List
;
1121 -- Start of processing for CUDA_Execute
1124 -- Append temporary declarations
1126 Append_To
(Blk_Decls
, Temp_Grid_Decl
);
1127 Analyze
(Temp_Grid_Decl
);
1129 Append_To
(Blk_Decls
, Temp_Block_Decl
);
1130 Analyze
(Temp_Block_Decl
);
1132 -- Build parameter declarations for CUDA API calls
1136 Build_Dim3_Declaration
1137 (Grids_Id
, New_Occurrence_Of
(Temp_Grid
, Loc
)));
1141 Build_Dim3_Declaration
1142 (Blocks_Id
, New_Occurrence_Of
(Temp_Block
, Loc
)));
1146 Build_Shared_Memory_Declaration
(Memory_Id
, Shared_Memory
));
1149 (Blk_Decls
, Build_Stream_Declaration
(Stream_Id
, CUDA_Stream
));
1152 (Parameter_Associations
(Procedure_Call
),
1158 Build_Kernel_Args_Declaration
1159 (Kernel_Args_Id
, Kernel_Arg_Copies
));
1161 -- Build calls to the CUDA API
1164 Make_Procedure_Call_Statement
(Loc
,
1166 New_Occurrence_Of
(RTE
(RE_Push_Call_Configuration
), Loc
),
1167 Parameter_Associations
=> New_List
(
1168 New_Occurrence_Of
(Grids_Id
, Loc
),
1169 New_Occurrence_Of
(Blocks_Id
, Loc
),
1170 New_Occurrence_Of
(Memory_Id
, Loc
),
1171 New_Occurrence_Of
(Stream_Id
, Loc
)));
1174 Make_Procedure_Call_Statement
(Loc
,
1176 New_Occurrence_Of
(RTE
(RE_Pop_Call_Configuration
), Loc
),
1177 Parameter_Associations
=> To_Addresses
1184 Launch_Kernel_Call
:= Build_Launch_Kernel_Call
1185 (Proc
=> Entity
(Name
(Procedure_Call
)),
1186 Grid_Dims
=> Grids_Id
,
1187 Block_Dims
=> Blocks_Id
,
1188 Kernel_Arg
=> Kernel_Args_Id
,
1189 Memory
=> Memory_Id
,
1190 Stream
=> Stream_Id
);
1192 -- Finally make the block that holds declarations and calls
1195 Make_Block_Statement
(Loc
,
1196 Declarations
=> Blk_Decls
,
1197 Handled_Statement_Sequence
=>
1198 Make_Handled_Sequence_Of_Statements
(Loc
,
1199 Statements
=> New_List
(
1202 Launch_Kernel_Call
))));
1204 end Expand_Pragma_CUDA_Execute
;
1206 ----------------------------------
1207 -- Expand_Pragma_Contract_Cases --
1208 ----------------------------------
1210 -- Pragma Contract_Cases is expanded in the following manner:
1213 -- Count : Natural := 0;
1214 -- Flag_1 : Boolean := False;
1216 -- Flag_N : Boolean := False;
1217 -- Flag_N+1 : Boolean := False; -- when "others" present
1222 -- <preconditions (if any)>
1224 -- -- Evaluate all case guards
1226 -- if Case_Guard_1 then
1228 -- Count := Count + 1;
1231 -- if Case_Guard_N then
1233 -- Count := Count + 1;
1236 -- -- Emit errors depending on the number of case guards that
1237 -- -- evaluated to True.
1239 -- if Count = 0 then
1240 -- raise Assertion_Error with "xxx contract cases incomplete";
1242 -- Flag_N+1 := True; -- when "others" present
1244 -- elsif Count > 1 then
1246 -- Str0 : constant String :=
1247 -- "contract cases overlap for subprogram ABC";
1248 -- Str1 : constant String :=
1250 -- Str0 & "case guard at xxx evaluates to True"
1252 -- StrN : constant String :=
1254 -- StrN-1 & "case guard at xxx evaluates to True"
1257 -- raise Assertion_Error with StrN;
1261 -- -- Evaluate all attribute 'Old prefixes found in the selected
1265 -- Pref_1 := <prefix of 'Old found in Consequence_1>
1267 -- elsif Flag_N then
1268 -- Pref_M := <prefix of 'Old found in Consequence_N>
1271 -- procedure _Postconditions is
1273 -- <postconditions (if any)>
1275 -- if Flag_1 and then not Consequence_1 then
1276 -- raise Assertion_Error with "failed contract case at xxx";
1279 -- if Flag_N[+1] and then not Consequence_N[+1] then
1280 -- raise Assertion_Error with "failed contract case at xxx";
1282 -- end _Postconditions;
1287 procedure Expand_Pragma_Contract_Cases
1289 Subp_Id
: Entity_Id
;
1291 Stmts
: in out List_Id
)
1293 Loc
: constant Source_Ptr
:= Sloc
(CCs
);
1295 procedure Case_Guard_Error
1298 Error_Loc
: Source_Ptr
;
1299 Msg
: in out Entity_Id
);
1300 -- Given a declarative list Decls, status flag Flag, the location of the
1301 -- error and a string Msg, construct the following check:
1302 -- Msg : constant String :=
1304 -- Msg & "case guard at Error_Loc evaluates to True"
1306 -- The resulting code is added to Decls
1308 procedure Consequence_Error
1309 (Checks
: in out Node_Id
;
1312 -- Given an if statement Checks, status flag Flag and a consequence
1313 -- Conseq, construct the following check:
1314 -- [els]if Flag and then not Conseq then
1315 -- raise Assertion_Error
1316 -- with "failed contract case at Sloc (Conseq)";
1318 -- The resulting code is added to Checks
1320 function Declaration_Of
(Id
: Entity_Id
) return Node_Id
;
1321 -- Given the entity Id of a boolean flag, generate:
1322 -- Id : Boolean := False;
1324 procedure Expand_Attributes_In_Consequence
1326 Evals
: in out Node_Id
;
1329 -- Perform specialized expansion of all attribute 'Old references found
1330 -- in consequence Conseq such that at runtime only prefixes coming from
1331 -- the selected consequence are evaluated. Similarly expand attribute
1332 -- 'Result references by replacing them with identifier _result which
1333 -- resolves to the sole formal parameter of procedure _Postconditions.
1334 -- Any temporaries generated in the process are added to declarations
1335 -- Decls. Evals is a complex if statement tasked with the evaluation of
1336 -- all prefixes coming from a single selected consequence. Flag is the
1337 -- corresponding case guard flag. Conseq is the consequence expression.
1339 function Increment
(Id
: Entity_Id
) return Node_Id
;
1340 -- Given the entity Id of a numerical variable, generate:
1343 function Set
(Id
: Entity_Id
) return Node_Id
;
1344 -- Given the entity Id of a boolean variable, generate:
1347 ----------------------
1348 -- Case_Guard_Error --
1349 ----------------------
1351 procedure Case_Guard_Error
1354 Error_Loc
: Source_Ptr
;
1355 Msg
: in out Entity_Id
)
1357 New_Line
: constant Character := Character'Val (10);
1358 New_Msg
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
1362 Store_String_Char
(New_Line
);
1363 Store_String_Chars
(" case guard at ");
1364 Store_String_Chars
(Build_Location_String
(Error_Loc
));
1365 Store_String_Chars
(" evaluates to True");
1368 -- New_Msg : constant String :=
1370 -- Msg & "case guard at Error_Loc evaluates to True"
1374 Make_Object_Declaration
(Loc
,
1375 Defining_Identifier
=> New_Msg
,
1376 Constant_Present
=> True,
1377 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
1379 Make_If_Expression
(Loc
,
1380 Expressions
=> New_List
(
1381 New_Occurrence_Of
(Flag
, Loc
),
1383 Make_Op_Concat
(Loc
,
1384 Left_Opnd
=> New_Occurrence_Of
(Msg
, Loc
),
1385 Right_Opnd
=> Make_String_Literal
(Loc
, End_String
)),
1387 New_Occurrence_Of
(Msg
, Loc
)))));
1390 end Case_Guard_Error
;
1392 -----------------------
1393 -- Consequence_Error --
1394 -----------------------
1396 procedure Consequence_Error
1397 (Checks
: in out Node_Id
;
1406 -- Flag and then not Conseq
1410 Left_Opnd
=> New_Occurrence_Of
(Flag
, Loc
),
1413 Right_Opnd
=> Relocate_Node
(Conseq
)));
1416 -- raise Assertion_Error
1417 -- with "failed contract case at Sloc (Conseq)";
1420 Store_String_Chars
("failed contract case at ");
1421 Store_String_Chars
(Build_Location_String
(Sloc
(Conseq
)));
1424 Make_Procedure_Call_Statement
(Loc
,
1426 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
1427 Parameter_Associations
=> New_List
(
1428 Make_String_Literal
(Loc
, End_String
)));
1432 Make_Implicit_If_Statement
(CCs
,
1434 Then_Statements
=> New_List
(Error
));
1437 if No
(Elsif_Parts
(Checks
)) then
1438 Set_Elsif_Parts
(Checks
, New_List
);
1441 Append_To
(Elsif_Parts
(Checks
),
1442 Make_Elsif_Part
(Loc
,
1444 Then_Statements
=> New_List
(Error
)));
1446 end Consequence_Error
;
1448 --------------------
1449 -- Declaration_Of --
1450 --------------------
1452 function Declaration_Of
(Id
: Entity_Id
) return Node_Id
is
1455 Make_Object_Declaration
(Loc
,
1456 Defining_Identifier
=> Id
,
1457 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1458 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
));
1461 --------------------------------------
1462 -- Expand_Attributes_In_Consequence --
1463 --------------------------------------
1465 procedure Expand_Attributes_In_Consequence
1467 Evals
: in out Node_Id
;
1471 Eval_Stmts
: List_Id
:= No_List
;
1472 -- The evaluation sequence expressed as assignment statements of all
1473 -- prefixes of attribute 'Old found in the current consequence.
1475 function Expand_Attributes
(N
: Node_Id
) return Traverse_Result
;
1476 -- Determine whether an arbitrary node denotes attribute 'Old or
1477 -- 'Result and if it does, perform all expansion-related actions.
1479 -----------------------
1480 -- Expand_Attributes --
1481 -----------------------
1483 function Expand_Attributes
(N
: Node_Id
) return Traverse_Result
is
1487 Indirect
: Boolean := False;
1489 use Sem_Util
.Old_Attr_Util
.Indirect_Temps
;
1491 procedure Append_For_Indirect_Temp
1492 (N
: Node_Id
; Is_Eval_Stmt
: Boolean);
1494 -- Append either a declaration (which is to be elaborated
1495 -- unconditionally) or an evaluation statement (which is
1496 -- to be executed conditionally).
1498 -------------------------------
1499 -- Append_For_Indirect_Temp --
1500 -------------------------------
1502 procedure Append_For_Indirect_Temp
1503 (N
: Node_Id
; Is_Eval_Stmt
: Boolean)
1506 if Is_Eval_Stmt
then
1507 Append_To
(Eval_Stmts
, N
);
1509 Prepend_To
(Decls
, N
);
1510 -- This use of Prepend (as opposed to Append) is why
1511 -- we have the Append_Decls_In_Reverse_Order parameter.
1513 end Append_For_Indirect_Temp
;
1515 procedure Declare_Indirect_Temporary
is new
1516 Declare_Indirect_Temp
(
1517 Append_Item
=> Append_For_Indirect_Temp
,
1518 Append_Decls_In_Reverse_Order
=> True);
1520 -- Start of processing for Expand_Attributes
1525 if Nkind
(N
) = N_Attribute_Reference
1526 and then Attribute_Name
(N
) = Name_Old
1530 Indirect
:= Indirect_Temp_Needed
(Etype
(Pref
));
1533 if No
(Eval_Stmts
) then
1534 Eval_Stmts
:= New_List
;
1537 Declare_Indirect_Temporary
1538 (Attr_Prefix
=> Pref
,
1539 Indirect_Temp
=> Temp
);
1541 -- Declare a temporary of the prefix type with no explicit
1542 -- initial value. If the appropriate contract case is selected
1543 -- at run time, then the temporary will be initialized via an
1544 -- assignment statement.
1547 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
1548 Set_Etype
(Temp
, Etype
(Pref
));
1550 -- Generate a temporary to capture the value of the prefix:
1551 -- Temp : <Pref type>;
1554 Make_Object_Declaration
(Loc
,
1555 Defining_Identifier
=> Temp
,
1556 Object_Definition
=>
1557 New_Occurrence_Of
(Etype
(Pref
), Loc
));
1559 -- Place that temporary at the beginning of declarations, to
1560 -- prevent anomalies in the GNATprove flow-analysis pass in
1561 -- the precondition procedure that follows.
1563 Prepend_To
(Decls
, Decl
);
1565 -- Initially Temp is uninitialized (which is required for
1566 -- correctness if default initialization might have side
1567 -- effects). Assign prefix value to temp on Eval_Statement
1568 -- list, so assignment will be executed conditionally.
1570 Set_Ekind
(Temp
, E_Variable
);
1571 Set_Suppress_Initialization
(Temp
);
1574 if No
(Eval_Stmts
) then
1575 Eval_Stmts
:= New_List
;
1578 Append_To
(Eval_Stmts
,
1579 Make_Assignment_Statement
(Loc
,
1580 Name
=> New_Occurrence_Of
(Temp
, Loc
),
1581 Expression
=> Pref
));
1584 -- Mark the temporary as coming from a 'Old reference
1586 if Present
(Temp
) then
1587 Set_Stores_Attribute_Old_Prefix
(Temp
);
1590 -- Ensure that the prefix is valid
1592 if Validity_Checks_On
and then Validity_Check_Operands
then
1593 Ensure_Valid
(Pref
);
1596 -- Replace the original attribute 'Old by a reference to the
1597 -- generated temporary.
1602 (Temp
=> Temp
, Typ
=> Etype
(Pref
), Loc
=> Loc
));
1604 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1607 -- Attribute 'Result
1609 elsif Is_Attribute_Result
(N
) then
1610 Rewrite
(N
, Make_Identifier
(Loc
, Name_uResult
));
1614 end Expand_Attributes
;
1616 procedure Expand_Attributes_In
is
1617 new Traverse_Proc
(Expand_Attributes
);
1619 -- Start of processing for Expand_Attributes_In_Consequence
1622 -- Inspect the consequence and expand any attribute 'Old and 'Result
1623 -- references found within.
1625 Expand_Attributes_In
(Conseq
);
1627 -- The consequence does not contain any attribute 'Old references
1629 if No
(Eval_Stmts
) then
1633 -- Augment the machinery to trigger the evaluation of all prefixes
1634 -- found in the step above. If Eval is empty, then this is the first
1635 -- consequence to yield expansion of 'Old. Generate:
1638 -- <evaluation statements>
1643 Make_Implicit_If_Statement
(CCs
,
1644 Condition
=> New_Occurrence_Of
(Flag
, Loc
),
1645 Then_Statements
=> Eval_Stmts
);
1647 -- Otherwise generate:
1649 -- <evaluation statements>
1653 if No
(Elsif_Parts
(Evals
)) then
1654 Set_Elsif_Parts
(Evals
, New_List
);
1657 Append_To
(Elsif_Parts
(Evals
),
1658 Make_Elsif_Part
(Loc
,
1659 Condition
=> New_Occurrence_Of
(Flag
, Loc
),
1660 Then_Statements
=> Eval_Stmts
));
1662 end Expand_Attributes_In_Consequence
;
1668 function Increment
(Id
: Entity_Id
) return Node_Id
is
1671 Make_Assignment_Statement
(Loc
,
1672 Name
=> New_Occurrence_Of
(Id
, Loc
),
1675 Left_Opnd
=> New_Occurrence_Of
(Id
, Loc
),
1676 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
1683 function Set
(Id
: Entity_Id
) return Node_Id
is
1686 Make_Assignment_Statement
(Loc
,
1687 Name
=> New_Occurrence_Of
(Id
, Loc
),
1688 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
1693 Aggr
: constant Node_Id
:=
1694 Expression
(First
(Pragma_Argument_Associations
(CCs
)));
1696 Case_Guard
: Node_Id
;
1697 CG_Checks
: Node_Id
;
1700 Conseq_Checks
: Node_Id
:= Empty
;
1702 Count_Decl
: Node_Id
;
1703 Error_Decls
: List_Id
:= No_List
; -- init to avoid warning
1705 Flag_Decl
: Node_Id
;
1707 Msg_Str
: Entity_Id
:= Empty
;
1708 Multiple_PCs
: Boolean;
1709 Old_Evals
: Node_Id
:= Empty
;
1710 Others_Decl
: Node_Id
;
1711 Others_Flag
: Entity_Id
:= Empty
;
1712 Post_Case
: Node_Id
;
1714 -- Start of processing for Expand_Pragma_Contract_Cases
1717 -- Do nothing if pragma is not enabled. If pragma is disabled, it has
1718 -- already been rewritten as a Null statement.
1720 if Is_Ignored
(CCs
) then
1723 -- Guard against malformed contract cases
1725 elsif Nkind
(Aggr
) /= N_Aggregate
then
1729 -- The expansion of contract cases is quite distributed as it produces
1730 -- various statements to evaluate the case guards and consequences. To
1731 -- preserve the original context, set the Is_Assertion_Expr flag. This
1732 -- aids the Ghost legality checks when verifying the placement of a
1733 -- reference to a Ghost entity.
1735 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
1737 Multiple_PCs
:= List_Length
(Component_Associations
(Aggr
)) > 1;
1739 -- Create the counter which tracks the number of case guards that
1740 -- evaluate to True.
1742 -- Count : Natural := 0;
1744 Count
:= Make_Temporary
(Loc
, 'C');
1746 Make_Object_Declaration
(Loc
,
1747 Defining_Identifier
=> Count
,
1748 Object_Definition
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1749 Expression
=> Make_Integer_Literal
(Loc
, 0));
1751 Prepend_To
(Decls
, Count_Decl
);
1752 Analyze
(Count_Decl
);
1754 -- Create the base error message for multiple overlapping case guards
1756 -- Msg_Str : constant String :=
1757 -- "contract cases overlap for subprogram Subp_Id";
1759 if Multiple_PCs
then
1760 Msg_Str
:= Make_Temporary
(Loc
, 'S');
1763 Store_String_Chars
("contract cases overlap for subprogram ");
1764 Store_String_Chars
(Get_Name_String
(Chars
(Subp_Id
)));
1766 Error_Decls
:= New_List
(
1767 Make_Object_Declaration
(Loc
,
1768 Defining_Identifier
=> Msg_Str
,
1769 Constant_Present
=> True,
1770 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
1771 Expression
=> Make_String_Literal
(Loc
, End_String
)));
1774 -- Process individual post cases
1776 Post_Case
:= First
(Component_Associations
(Aggr
));
1777 while Present
(Post_Case
) loop
1778 Case_Guard
:= First
(Choices
(Post_Case
));
1779 Conseq
:= Expression
(Post_Case
);
1781 -- The "others" choice requires special processing
1783 if Nkind
(Case_Guard
) = N_Others_Choice
then
1784 Others_Flag
:= Make_Temporary
(Loc
, 'F');
1785 Others_Decl
:= Declaration_Of
(Others_Flag
);
1787 Prepend_To
(Decls
, Others_Decl
);
1788 Analyze
(Others_Decl
);
1790 -- Check possible overlap between a case guard and "others"
1792 if Multiple_PCs
and Exception_Extra_Info
then
1794 (Decls
=> Error_Decls
,
1795 Flag
=> Others_Flag
,
1796 Error_Loc
=> Sloc
(Case_Guard
),
1800 -- Inspect the consequence and perform special expansion of any
1801 -- attribute 'Old and 'Result references found within.
1803 Expand_Attributes_In_Consequence
1806 Flag
=> Others_Flag
,
1809 -- Check the corresponding consequence of "others"
1812 (Checks
=> Conseq_Checks
,
1813 Flag
=> Others_Flag
,
1816 -- Regular post case
1819 -- Create the flag which tracks the state of its associated case
1822 Flag
:= Make_Temporary
(Loc
, 'F');
1823 Flag_Decl
:= Declaration_Of
(Flag
);
1825 Prepend_To
(Decls
, Flag_Decl
);
1826 Analyze
(Flag_Decl
);
1828 -- The flag is set when the case guard is evaluated to True
1829 -- if Case_Guard then
1831 -- Count := Count + 1;
1835 Make_Implicit_If_Statement
(CCs
,
1836 Condition
=> Relocate_Node
(Case_Guard
),
1837 Then_Statements
=> New_List
(
1839 Increment
(Count
)));
1841 Append_To
(Decls
, If_Stmt
);
1844 -- Check whether this case guard overlaps with another one
1846 if Multiple_PCs
and Exception_Extra_Info
then
1848 (Decls
=> Error_Decls
,
1850 Error_Loc
=> Sloc
(Case_Guard
),
1854 -- Inspect the consequence and perform special expansion of any
1855 -- attribute 'Old and 'Result references found within.
1857 Expand_Attributes_In_Consequence
1863 -- The corresponding consequence of the case guard which evaluated
1864 -- to True must hold on exit from the subprogram.
1867 (Checks
=> Conseq_Checks
,
1875 -- Raise Assertion_Error when none of the case guards evaluate to True.
1876 -- The only exception is when we have "others", in which case there is
1877 -- no error because "others" acts as a default True.
1882 if Present
(Others_Flag
) then
1883 CG_Stmts
:= New_List
(Set
(Others_Flag
));
1886 -- raise Assertion_Error with "xxx contract cases incomplete";
1890 Store_String_Chars
(Build_Location_String
(Loc
));
1891 Store_String_Chars
(" contract cases incomplete");
1893 CG_Stmts
:= New_List
(
1894 Make_Procedure_Call_Statement
(Loc
,
1896 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
1897 Parameter_Associations
=> New_List
(
1898 Make_String_Literal
(Loc
, End_String
))));
1902 Make_Implicit_If_Statement
(CCs
,
1905 Left_Opnd
=> New_Occurrence_Of
(Count
, Loc
),
1906 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1907 Then_Statements
=> CG_Stmts
);
1909 -- Detect a possible failure due to several case guards evaluating to
1913 -- elsif Count > 0 then
1917 -- raise Assertion_Error with <Msg_Str>;
1920 if Multiple_PCs
then
1921 Set_Elsif_Parts
(CG_Checks
, New_List
(
1922 Make_Elsif_Part
(Loc
,
1925 Left_Opnd
=> New_Occurrence_Of
(Count
, Loc
),
1926 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)),
1928 Then_Statements
=> New_List
(
1929 Make_Block_Statement
(Loc
,
1930 Declarations
=> Error_Decls
,
1931 Handled_Statement_Sequence
=>
1932 Make_Handled_Sequence_Of_Statements
(Loc
,
1933 Statements
=> New_List
(
1934 Make_Procedure_Call_Statement
(Loc
,
1937 (RTE
(RE_Raise_Assert_Failure
), Loc
),
1938 Parameter_Associations
=> New_List
(
1939 New_Occurrence_Of
(Msg_Str
, Loc
))))))))));
1942 Append_To
(Decls
, CG_Checks
);
1943 Analyze
(CG_Checks
);
1945 -- Once all case guards are evaluated and checked, evaluate any prefixes
1946 -- of attribute 'Old founds in the selected consequence.
1948 if Present
(Old_Evals
) then
1949 Append_To
(Decls
, Old_Evals
);
1950 Analyze
(Old_Evals
);
1953 -- Raise Assertion_Error when the corresponding consequence of a case
1954 -- guard that evaluated to True fails.
1956 Append_New_To
(Stmts
, Conseq_Checks
);
1958 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
1959 end Expand_Pragma_Contract_Cases
;
1961 ---------------------------------------
1962 -- Expand_Pragma_Import_Or_Interface --
1963 ---------------------------------------
1965 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
) is
1969 -- In Relaxed_RM_Semantics, support old Ada 83 style:
1970 -- pragma Import (Entity, "external name");
1972 if Relaxed_RM_Semantics
1973 and then List_Length
(Pragma_Argument_Associations
(N
)) = 2
1974 and then Pragma_Name
(N
) = Name_Import
1975 and then Nkind
(Arg_N
(N
, 2)) = N_String_Literal
1977 Def_Id
:= Entity
(Arg_N
(N
, 1));
1979 Def_Id
:= Entity
(Arg_N
(N
, 2));
1982 -- Variable case (we have to undo any initialization already done)
1984 if Ekind
(Def_Id
) = E_Variable
then
1985 Undo_Initialization
(Def_Id
, N
);
1987 -- Case of exception with convention C++
1989 elsif Ekind
(Def_Id
) = E_Exception
1990 and then Convention
(Def_Id
) = Convention_CPP
1992 -- Import a C++ convention
1995 Loc
: constant Source_Ptr
:= Sloc
(N
);
1996 Rtti_Name
: constant Node_Id
:= Arg_N
(N
, 3);
1997 Dum
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
1999 Lang_Char
: Node_Id
;
2000 Foreign_Data
: Node_Id
;
2003 Exdata
:= Component_Associations
(Expression
(Parent
(Def_Id
)));
2005 Lang_Char
:= Next
(First
(Exdata
));
2007 -- Change the one-character language designator to 'C'
2009 Rewrite
(Expression
(Lang_Char
),
2010 Make_Character_Literal
(Loc
,
2012 Char_Literal_Value
=> UI_From_Int
(Character'Pos ('C'))));
2013 Analyze
(Expression
(Lang_Char
));
2015 -- Change the value of Foreign_Data
2017 Foreign_Data
:= Next
(Next
(Next
(Next
(Lang_Char
))));
2019 Insert_Actions
(Def_Id
, New_List
(
2020 Make_Object_Declaration
(Loc
,
2021 Defining_Identifier
=> Dum
,
2022 Object_Definition
=>
2023 New_Occurrence_Of
(Standard_Character
, Loc
)),
2026 Chars
=> Name_Import
,
2027 Pragma_Argument_Associations
=> New_List
(
2028 Make_Pragma_Argument_Association
(Loc
,
2029 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
2031 Make_Pragma_Argument_Association
(Loc
,
2032 Expression
=> Make_Identifier
(Loc
, Chars
(Dum
))),
2034 Make_Pragma_Argument_Association
(Loc
,
2035 Chars
=> Name_External_Name
,
2036 Expression
=> Relocate_Node
(Rtti_Name
))))));
2038 Rewrite
(Expression
(Foreign_Data
),
2039 Unchecked_Convert_To
(Standard_A_Char
,
2040 Make_Attribute_Reference
(Loc
,
2041 Prefix
=> Make_Identifier
(Loc
, Chars
(Dum
)),
2042 Attribute_Name
=> Name_Address
)));
2043 Analyze
(Expression
(Foreign_Data
));
2046 -- No special expansion required for any other case
2051 end Expand_Pragma_Import_Or_Interface
;
2053 -------------------------------------
2054 -- Expand_Pragma_Initial_Condition --
2055 -------------------------------------
2057 procedure Expand_Pragma_Initial_Condition
2058 (Pack_Id
: Entity_Id
;
2061 procedure Extract_Package_Body_Lists
2062 (Pack_Body
: Node_Id
;
2063 Body_List
: out List_Id
;
2064 Call_List
: out List_Id
;
2065 Spec_List
: out List_Id
);
2066 -- Obtain the various declarative and statement lists of package body
2067 -- Pack_Body needed to insert the initial condition procedure and the
2068 -- call to it. The lists are as follows:
2070 -- * Body_List - used to insert the initial condition procedure body
2072 -- * Call_List - used to insert the call to the initial condition
2075 -- * Spec_List - used to insert the initial condition procedure spec
2077 procedure Extract_Package_Declaration_Lists
2078 (Pack_Decl
: Node_Id
;
2079 Body_List
: out List_Id
;
2080 Call_List
: out List_Id
;
2081 Spec_List
: out List_Id
);
2082 -- Obtain the various declarative lists of package declaration Pack_Decl
2083 -- needed to insert the initial condition procedure and the call to it.
2084 -- The lists are as follows:
2086 -- * Body_List - used to insert the initial condition procedure body
2088 -- * Call_List - used to insert the call to the initial condition
2091 -- * Spec_List - used to insert the initial condition procedure spec
2093 --------------------------------
2094 -- Extract_Package_Body_Lists --
2095 --------------------------------
2097 procedure Extract_Package_Body_Lists
2098 (Pack_Body
: Node_Id
;
2099 Body_List
: out List_Id
;
2100 Call_List
: out List_Id
;
2101 Spec_List
: out List_Id
)
2103 Pack_Spec
: constant Entity_Id
:= Corresponding_Spec
(Pack_Body
);
2110 pragma Assert
(Present
(Pack_Spec
));
2112 -- The different parts of the invariant procedure are inserted as
2115 -- package Pack is package body Pack is
2116 -- <IC spec> <IC body>
2119 -- end Pack; end Pack;
2121 -- The initial condition procedure spec is inserted in the visible
2122 -- declaration of the corresponding package spec.
2124 Extract_Package_Declaration_Lists
2125 (Pack_Decl
=> Unit_Declaration_Node
(Pack_Spec
),
2126 Body_List
=> Dummy_1
,
2127 Call_List
=> Dummy_2
,
2128 Spec_List
=> Spec_List
);
2130 -- The initial condition procedure body is added to the declarations
2131 -- of the package body.
2133 Body_List
:= Declarations
(Pack_Body
);
2135 if No
(Body_List
) then
2136 Body_List
:= New_List
;
2137 Set_Declarations
(Pack_Body
, Body_List
);
2140 -- The call to the initial condition procedure is inserted in the
2141 -- statements of the package body.
2143 HSS
:= Handled_Statement_Sequence
(Pack_Body
);
2147 Make_Handled_Sequence_Of_Statements
(Sloc
(Pack_Body
),
2148 Statements
=> New_List
);
2149 Set_Handled_Statement_Sequence
(Pack_Body
, HSS
);
2152 Call_List
:= Statements
(HSS
);
2153 end Extract_Package_Body_Lists
;
2155 ---------------------------------------
2156 -- Extract_Package_Declaration_Lists --
2157 ---------------------------------------
2159 procedure Extract_Package_Declaration_Lists
2160 (Pack_Decl
: Node_Id
;
2161 Body_List
: out List_Id
;
2162 Call_List
: out List_Id
;
2163 Spec_List
: out List_Id
)
2165 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
2168 -- The different parts of the invariant procedure are inserted as
2178 -- The initial condition procedure spec and body are inserted in the
2179 -- visible declarations of the package spec.
2181 Body_List
:= Visible_Declarations
(Pack_Spec
);
2183 if No
(Body_List
) then
2184 Body_List
:= New_List
;
2185 Set_Visible_Declarations
(Pack_Spec
, Body_List
);
2188 Spec_List
:= Body_List
;
2190 -- The call to the initial procedure is inserted in the private
2191 -- declarations of the package spec.
2193 Call_List
:= Private_Declarations
(Pack_Spec
);
2195 if No
(Call_List
) then
2196 Call_List
:= New_List
;
2197 Set_Private_Declarations
(Pack_Spec
, Call_List
);
2199 end Extract_Package_Declaration_Lists
;
2203 IC_Prag
: constant Node_Id
:=
2204 Get_Pragma
(Pack_Id
, Pragma_Initial_Condition
);
2206 Body_List
: List_Id
;
2208 Call_List
: List_Id
;
2209 Call_Loc
: Source_Ptr
;
2212 Proc_Body
: Node_Id
;
2213 Proc_Body_Id
: Entity_Id
;
2214 Proc_Decl
: Node_Id
;
2215 Proc_Id
: Entity_Id
;
2216 Spec_List
: List_Id
;
2218 -- Start of processing for Expand_Pragma_Initial_Condition
2221 -- Nothing to do when the package is not subject to an Initial_Condition
2224 if No
(IC_Prag
) then
2228 Expr
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(IC_Prag
)));
2229 Loc
:= Sloc
(IC_Prag
);
2231 -- Nothing to do when the pragma is ignored because its semantics are
2234 if Is_Ignored
(IC_Prag
) then
2237 -- Nothing to do when the pragma or its argument are illegal because
2238 -- there is no valid expression to check.
2240 elsif Error_Posted
(IC_Prag
) or else Error_Posted
(Expr
) then
2244 -- Obtain the various lists of the context where the individual pieces
2245 -- of the initial condition procedure are to be inserted.
2247 if Nkind
(N
) = N_Package_Body
then
2248 Extract_Package_Body_Lists
2250 Body_List
=> Body_List
,
2251 Call_List
=> Call_List
,
2252 Spec_List
=> Spec_List
);
2254 elsif Nkind
(N
) = N_Package_Declaration
then
2255 Extract_Package_Declaration_Lists
2257 Body_List
=> Body_List
,
2258 Call_List
=> Call_List
,
2259 Spec_List
=> Spec_List
);
2261 -- This routine should not be used on anything other than packages
2264 pragma Assert
(False);
2269 Make_Defining_Identifier
(Loc
,
2270 Chars
=> New_External_Name
(Chars
(Pack_Id
), "Initial_Condition"));
2272 Set_Ekind
(Proc_Id
, E_Procedure
);
2273 Set_Is_Initial_Condition_Procedure
(Proc_Id
);
2276 -- procedure <Pack_Id>Initial_Condition;
2279 Make_Subprogram_Declaration
(Loc
,
2280 Make_Procedure_Specification
(Loc
,
2281 Defining_Unit_Name
=> Proc_Id
));
2283 Append_To
(Spec_List
, Proc_Decl
);
2285 -- The initial condition procedure requires debug info when initial
2286 -- condition is subject to Source Coverage Obligations.
2288 if Generate_SCO
then
2289 Set_Debug_Info_Needed
(Proc_Id
);
2293 -- procedure <Pack_Id>Initial_Condition is
2295 -- pragma Check (Initial_Condition, <Expr>);
2296 -- end <Pack_Id>Initial_Condition;
2299 Make_Subprogram_Body
(Loc
,
2301 Copy_Subprogram_Spec
(Specification
(Proc_Decl
)),
2302 Declarations
=> Empty_List
,
2303 Handled_Statement_Sequence
=>
2304 Make_Handled_Sequence_Of_Statements
(Loc
,
2305 Statements
=> New_List
(
2307 Chars
=> Name_Check
,
2308 Pragma_Argument_Associations
=> New_List
(
2309 Make_Pragma_Argument_Association
(Loc
,
2311 Make_Identifier
(Loc
, Name_Initial_Condition
)),
2312 Make_Pragma_Argument_Association
(Loc
,
2313 Expression
=> New_Copy_Tree
(Expr
)))))));
2315 Append_To
(Body_List
, Proc_Body
);
2317 -- The initial condition procedure requires debug info when initial
2318 -- condition is subject to Source Coverage Obligations.
2320 Proc_Body_Id
:= Defining_Entity
(Proc_Body
);
2322 if Generate_SCO
then
2323 Set_Debug_Info_Needed
(Proc_Body_Id
);
2326 -- The location of the initial condition procedure call must be as close
2327 -- as possible to the intended semantic location of the check because
2328 -- the ABE mechanism relies heavily on accurate locations.
2330 Call_Loc
:= End_Keyword_Location
(N
);
2333 -- <Pack_Id>Initial_Condition;
2336 Make_Procedure_Call_Statement
(Call_Loc
,
2337 Name
=> New_Occurrence_Of
(Proc_Id
, Call_Loc
));
2339 Append_To
(Call_List
, Call
);
2341 Analyze
(Proc_Decl
);
2342 Analyze
(Proc_Body
);
2344 end Expand_Pragma_Initial_Condition
;
2346 ------------------------------------
2347 -- Expand_Pragma_Inspection_Point --
2348 ------------------------------------
2350 -- If no argument is given, then we supply a default argument list that
2351 -- includes all objects declared at the source level in all subprograms
2352 -- that enclose the inspection point pragma.
2354 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
) is
2355 Loc
: constant Source_Ptr
:= Sloc
(N
);
2362 if No
(Pragma_Argument_Associations
(N
)) then
2366 while S
/= Standard_Standard
loop
2367 E
:= First_Entity
(S
);
2368 while Present
(E
) loop
2369 if Comes_From_Source
(E
)
2370 and then Is_Object
(E
)
2371 and then not Is_Entry_Formal
(E
)
2372 and then Ekind
(E
) /= E_Component
2373 and then Ekind
(E
) /= E_Discriminant
2374 and then Ekind
(E
) /= E_Generic_In_Parameter
2375 and then Ekind
(E
) /= E_Generic_In_Out_Parameter
2378 Make_Pragma_Argument_Association
(Loc
,
2379 Expression
=> New_Occurrence_Of
(E
, Loc
)));
2388 Set_Pragma_Argument_Associations
(N
, A
);
2391 -- Expand the arguments of the pragma. Expanding an entity reference
2392 -- is a noop, except in a protected operation, where a reference may
2393 -- have to be transformed into a reference to the corresponding prival.
2394 -- Are there other pragmas that may require this ???
2396 Assoc
:= First
(Pragma_Argument_Associations
(N
));
2397 while Present
(Assoc
) loop
2398 Expand
(Expression
(Assoc
));
2401 end Expand_Pragma_Inspection_Point
;
2403 --------------------------------------
2404 -- Expand_Pragma_Interrupt_Priority --
2405 --------------------------------------
2407 -- Supply default argument if none exists (System.Interrupt_Priority'Last)
2409 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
) is
2410 Loc
: constant Source_Ptr
:= Sloc
(N
);
2412 if No
(Pragma_Argument_Associations
(N
)) then
2413 Set_Pragma_Argument_Associations
(N
, New_List
(
2414 Make_Pragma_Argument_Association
(Loc
,
2416 Make_Attribute_Reference
(Loc
,
2418 New_Occurrence_Of
(RTE
(RE_Interrupt_Priority
), Loc
),
2419 Attribute_Name
=> Name_Last
))));
2421 end Expand_Pragma_Interrupt_Priority
;
2423 --------------------------------
2424 -- Expand_Pragma_Loop_Variant --
2425 --------------------------------
2427 -- Pragma Loop_Variant is expanded in the following manner:
2431 -- for | while ... loop
2432 -- <preceding source statements>
2433 -- pragma Loop_Variant
2434 -- (Increases => Incr_Expr,
2435 -- Decreases => Decr_Expr);
2436 -- <succeeding source statements>
2441 -- Curr_1 : <type of Incr_Expr>;
2442 -- Curr_2 : <type of Decr_Expr>;
2443 -- Old_1 : <type of Incr_Expr>;
2444 -- Old_2 : <type of Decr_Expr>;
2445 -- Flag : Boolean := False;
2447 -- for | while ... loop
2448 -- <preceding source statements>
2455 -- Curr_1 := <Incr_Expr>;
2456 -- Curr_2 := <Decr_Expr>;
2459 -- if Curr_1 /= Old_1 then
2460 -- pragma Check (Loop_Variant, Curr_1 > Old_1);
2462 -- pragma Check (Loop_Variant, Curr_2 < Old_2);
2468 -- <succeeding source statements>
2471 procedure Expand_Pragma_Loop_Variant
(N
: Node_Id
) is
2472 Loc
: constant Source_Ptr
:= Sloc
(N
);
2473 Last_Var
: constant Node_Id
:=
2474 Last
(Pragma_Argument_Associations
(N
));
2476 Curr_Assign
: List_Id
:= No_List
;
2477 Flag_Id
: Entity_Id
:= Empty
;
2478 If_Stmt
: Node_Id
:= Empty
;
2479 Old_Assign
: List_Id
:= No_List
;
2480 Loop_Scop
: Entity_Id
;
2481 Loop_Stmt
: Node_Id
;
2484 procedure Process_Variant
(Variant
: Node_Id
; Is_Last
: Boolean);
2485 -- Process a single increasing / decreasing termination variant. Flag
2486 -- Is_Last should be set when processing the last variant.
2488 ---------------------
2489 -- Process_Variant --
2490 ---------------------
2492 procedure Process_Variant
(Variant
: Node_Id
; Is_Last
: Boolean) is
2493 Expr
: constant Node_Id
:= Expression
(Variant
);
2494 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
2495 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2496 Loop_Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
2497 Curr_Id
: Entity_Id
;
2502 -- All temporaries generated in this routine must be inserted before
2503 -- the related loop statement. Ensure that the proper scope is on the
2504 -- stack when analyzing the temporaries. Note that we also use the
2505 -- Sloc of the related loop.
2507 Push_Scope
(Scope
(Loop_Scop
));
2509 -- Step 1: Create the declaration of the flag which controls the
2510 -- behavior of the assertion on the first iteration of the loop.
2512 if No
(Flag_Id
) then
2515 -- Flag : Boolean := False;
2517 Flag_Id
:= Make_Temporary
(Loop_Loc
, 'F');
2519 Insert_Action
(Loop_Stmt
,
2520 Make_Object_Declaration
(Loop_Loc
,
2521 Defining_Identifier
=> Flag_Id
,
2522 Object_Definition
=>
2523 New_Occurrence_Of
(Standard_Boolean
, Loop_Loc
),
2525 New_Occurrence_Of
(Standard_False
, Loop_Loc
)));
2527 -- Prevent an unwanted optimization where the Current_Value of
2528 -- the flag eliminates the if statement which stores the variant
2529 -- values coming from the previous iteration.
2531 -- Flag : Boolean := False;
2533 -- if Flag then -- condition rewritten to False
2534 -- Old_N := Curr_N; -- and if statement eliminated
2540 Set_Current_Value
(Flag_Id
, Empty
);
2543 -- Step 2: Create the temporaries which store the old and current
2544 -- values of the associated expression.
2547 -- Curr : <type of Expr>;
2549 Curr_Id
:= Make_Temporary
(Loc
, 'C');
2551 Insert_Action
(Loop_Stmt
,
2552 Make_Object_Declaration
(Loop_Loc
,
2553 Defining_Identifier
=> Curr_Id
,
2554 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loop_Loc
)));
2557 -- Old : <type of Expr>;
2559 Old_Id
:= Make_Temporary
(Loc
, 'P');
2561 Insert_Action
(Loop_Stmt
,
2562 Make_Object_Declaration
(Loop_Loc
,
2563 Defining_Identifier
=> Old_Id
,
2564 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loop_Loc
)));
2566 -- Restore original scope after all temporaries have been analyzed
2570 -- Step 3: Store value of the expression from the previous iteration
2575 Append_New_To
(Old_Assign
,
2576 Make_Assignment_Statement
(Loc
,
2577 Name
=> New_Occurrence_Of
(Old_Id
, Loc
),
2578 Expression
=> New_Occurrence_Of
(Curr_Id
, Loc
)));
2580 -- Step 4: Store the current value of the expression
2585 Append_New_To
(Curr_Assign
,
2586 Make_Assignment_Statement
(Loc
,
2587 Name
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2588 Expression
=> Relocate_Node
(Expr
)));
2590 -- Step 5: Create corresponding assertion to verify change of value
2593 -- pragma Check (Loop_Variant, Curr <|> Old);
2597 Chars
=> Name_Check
,
2598 Pragma_Argument_Associations
=> New_List
(
2599 Make_Pragma_Argument_Association
(Loc
,
2600 Expression
=> Make_Identifier
(Loc
, Name_Loop_Variant
)),
2601 Make_Pragma_Argument_Association
(Loc
,
2603 Make_Variant_Comparison
(Loc
,
2604 Mode
=> Chars
(Variant
),
2605 Curr_Val
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2606 Old_Val
=> New_Occurrence_Of
(Old_Id
, Loc
)))));
2609 -- if Curr /= Old then
2612 if No
(If_Stmt
) then
2614 -- When there is just one termination variant, do not compare the
2615 -- old and current value for equality, just check the pragma.
2621 Make_If_Statement
(Loc
,
2624 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2625 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
2626 Then_Statements
=> New_List
(Prag
));
2635 Set_Else_Statements
(If_Stmt
, New_List
(Prag
));
2638 -- elsif Curr /= Old then
2642 if Elsif_Parts
(If_Stmt
) = No_List
then
2643 Set_Elsif_Parts
(If_Stmt
, New_List
);
2646 Append_To
(Elsif_Parts
(If_Stmt
),
2647 Make_Elsif_Part
(Loc
,
2650 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2651 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
2652 Then_Statements
=> New_List
(Prag
)));
2654 end Process_Variant
;
2656 -- Start of processing for Expand_Pragma_Loop_Variant
2659 -- If pragma is not enabled, rewrite as Null statement. If pragma is
2660 -- disabled, it has already been rewritten as a Null statement.
2662 if Is_Ignored
(N
) then
2663 Rewrite
(N
, Make_Null_Statement
(Loc
));
2668 -- The expansion of Loop_Variant is quite distributed as it produces
2669 -- various statements to capture and compare the arguments. To preserve
2670 -- the original context, set the Is_Assertion_Expr flag. This aids the
2671 -- Ghost legality checks when verifying the placement of a reference to
2674 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
2676 -- Locate the enclosing loop for which this assertion applies. In the
2677 -- case of Ada 2012 array iteration, we might be dealing with nested
2678 -- loops. Only the outermost loop has an identifier.
2681 while Present
(Loop_Stmt
) loop
2682 if Nkind
(Loop_Stmt
) = N_Loop_Statement
2683 and then Present
(Identifier
(Loop_Stmt
))
2688 Loop_Stmt
:= Parent
(Loop_Stmt
);
2691 Loop_Scop
:= Entity
(Identifier
(Loop_Stmt
));
2693 -- Create the circuitry which verifies individual variants
2695 Variant
:= First
(Pragma_Argument_Associations
(N
));
2696 while Present
(Variant
) loop
2697 Process_Variant
(Variant
, Is_Last
=> Variant
= Last_Var
);
2701 -- Construct the segment which stores the old values of all expressions.
2708 Make_If_Statement
(Loc
,
2709 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
2710 Then_Statements
=> Old_Assign
));
2712 -- Update the values of all expressions
2714 Insert_Actions
(N
, Curr_Assign
);
2716 -- Add the assertion circuitry to test all changes in expressions.
2725 Make_If_Statement
(Loc
,
2726 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
2727 Then_Statements
=> New_List
(If_Stmt
),
2728 Else_Statements
=> New_List
(
2729 Make_Assignment_Statement
(Loc
,
2730 Name
=> New_Occurrence_Of
(Flag_Id
, Loc
),
2731 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
2733 -- Note: the pragma has been completely transformed into a sequence of
2734 -- corresponding declarations and statements. We leave it in the tree
2735 -- for documentation purposes. It will be ignored by the backend.
2737 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
2738 end Expand_Pragma_Loop_Variant
;
2740 --------------------------------
2741 -- Expand_Pragma_Psect_Object --
2742 --------------------------------
2744 -- Convert to Common_Object, and expand the resulting pragma
2746 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
)
2747 renames Expand_Pragma_Common_Object
;
2749 -------------------------------------
2750 -- Expand_Pragma_Relative_Deadline --
2751 -------------------------------------
2753 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
) is
2754 P
: constant Node_Id
:= Parent
(N
);
2755 Loc
: constant Source_Ptr
:= Sloc
(N
);
2758 -- Expand the pragma only in the case of the main subprogram. For tasks
2759 -- the expansion is done in exp_ch9. Generate a call to Set_Deadline
2760 -- at Clock plus the relative deadline specified in the pragma. Time
2761 -- values are translated into Duration to allow for non-private
2762 -- addition operation.
2764 if Nkind
(P
) = N_Subprogram_Body
then
2767 Make_Procedure_Call_Statement
(Loc
,
2768 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Deadline
), Loc
),
2769 Parameter_Associations
=> New_List
(
2770 Unchecked_Convert_To
(RTE
(RO_RT_Time
),
2773 Make_Function_Call
(Loc
,
2774 New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
2777 (Loc
, New_Occurrence_Of
(RTE
(RE_Clock
), Loc
)))),
2779 Unchecked_Convert_To
(
2785 end Expand_Pragma_Relative_Deadline
;
2787 --------------------------------------
2788 -- Expand_Pragma_Subprogram_Variant --
2789 --------------------------------------
2791 -- Aspect Subprogram_Variant is expanded in the following manner:
2795 -- procedure Proc (Param : T) with
2796 -- with Variant (Increases => Incr_Expr,
2797 -- Decreases => Decr_Expr)
2800 -- <source statements>
2801 -- Proc (New_Param_Value);
2806 -- procedure Proc (Param : T) is
2807 -- Old_Incr : constant <type of Incr_Expr> := <Incr_Expr>;
2808 -- Old_Decr : constant <type of Decr_Expr> := <Decr_Expr> ;
2810 -- procedure Variants (Param : T);
2812 -- procedure Variants (Param : T) is
2813 -- Curr_Incr : constant <type of Incr_Expr> := <Incr_Expr>;
2814 -- Curr_Decr : constant <type of Decr_Expr> := <Decr_Expr>;
2816 -- if Curr_Incr /= Old_Incr then
2817 -- pragma Check (Variant, Curr_Incr > Old_Incr);
2819 -- pragma Check (Variant, Curr_Decr < Old_Decr);
2825 -- <source statements>
2826 -- Variants (New_Param_Value);
2827 -- Proc (New_Param_Value);
2830 procedure Expand_Pragma_Subprogram_Variant
2833 Body_Decls
: List_Id
)
2835 Curr_Decls
: List_Id
;
2836 If_Stmt
: Node_Id
:= Empty
;
2838 function Formal_Param_Map
2839 (Old_Subp
: Entity_Id
;
2840 New_Subp
: Entity_Id
) return Elist_Id
;
2841 -- Given two subprogram entities Old_Subp and New_Subp with the same
2842 -- number of formal parameters return a list of the form:
2850 -- as required by New_Copy_Tree to replace references to formal
2851 -- parameters of Old_Subp with references to formal parameters of
2854 procedure Process_Variant
2856 Formal_Map
: Elist_Id
;
2857 Prev_Decl
: in out Node_Id
;
2859 -- Process a single increasing / decreasing termination variant given by
2860 -- a component association Variant. Formal_Map is a list of formal
2861 -- parameters of the annotated subprogram and of the internal procedure
2862 -- that verifies the variant in the format required by New_Copy_Tree.
2863 -- The Old_... object created by this routine will be appended after
2864 -- Prev_Decl and is stored in this parameter for a next call to this
2865 -- routine. Is_Last is True when there are no more variants to process.
2867 ----------------------
2868 -- Formal_Param_Map --
2869 ----------------------
2871 function Formal_Param_Map
2872 (Old_Subp
: Entity_Id
;
2873 New_Subp
: Entity_Id
) return Elist_Id
2875 Old_Formal
: Entity_Id
:= First_Formal
(Old_Subp
);
2876 New_Formal
: Entity_Id
:= First_Formal
(New_Subp
);
2878 Param_Map
: Elist_Id
;
2880 if Present
(Old_Formal
) then
2881 Param_Map
:= New_Elmt_List
;
2882 while Present
(Old_Formal
) and then Present
(New_Formal
) loop
2883 Append_Elmt
(Old_Formal
, Param_Map
);
2884 Append_Elmt
(New_Formal
, Param_Map
);
2886 Next_Formal
(Old_Formal
);
2887 Next_Formal
(New_Formal
);
2894 end Formal_Param_Map
;
2896 ---------------------
2897 -- Process_Variant --
2898 ---------------------
2900 procedure Process_Variant
2902 Formal_Map
: Elist_Id
;
2903 Prev_Decl
: in out Node_Id
;
2906 Expr
: constant Node_Id
:= Expression
(Variant
);
2907 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
2908 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2912 Curr_Id
: Entity_Id
;
2913 Curr_Decl
: Node_Id
;
2917 -- Create temporaries that store the old values of the associated
2921 -- Old : constant <type of Expr> := <Expr>;
2923 Old_Id
:= Make_Temporary
(Loc
, 'P');
2926 Make_Object_Declaration
(Loc
,
2927 Defining_Identifier
=> Old_Id
,
2928 Constant_Present
=> True,
2929 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loc
),
2930 Expression
=> New_Copy_Tree
(Expr
));
2932 Insert_After_And_Analyze
(Prev_Decl
, Old_Decl
);
2934 Prev_Decl
:= Old_Decl
;
2937 -- Curr : constant <type of Expr> := <Expr>;
2939 Curr_Id
:= Make_Temporary
(Loc
, 'C');
2942 Make_Object_Declaration
(Loc
,
2943 Defining_Identifier
=> Curr_Id
,
2944 Constant_Present
=> True,
2945 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loc
),
2947 New_Copy_Tree
(Expr
, Map
=> Formal_Map
));
2949 Append
(Curr_Decl
, Curr_Decls
);
2952 -- pragma Check (Variant, Curr <|> Old);
2956 Chars
=> Name_Check
,
2957 Pragma_Argument_Associations
=> New_List
(
2958 Make_Pragma_Argument_Association
(Loc
,
2960 Make_Identifier
(Loc
,
2961 Name_Subprogram_Variant
)),
2962 Make_Pragma_Argument_Association
(Loc
,
2964 Make_Variant_Comparison
(Loc
,
2965 Mode
=> Chars
(First
(Choices
(Variant
))),
2966 Curr_Val
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2967 Old_Val
=> New_Occurrence_Of
(Old_Id
, Loc
)))));
2970 -- if Curr /= Old then
2973 if No
(If_Stmt
) then
2975 -- When there is just one termination variant, do not compare
2976 -- the old and current value for equality, just check the
2983 Make_If_Statement
(Loc
,
2986 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2987 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
2988 Then_Statements
=> New_List
(Prag
));
2997 Set_Else_Statements
(If_Stmt
, New_List
(Prag
));
3000 -- elsif Curr /= Old then
3004 if Elsif_Parts
(If_Stmt
) = No_List
then
3005 Set_Elsif_Parts
(If_Stmt
, New_List
);
3008 Append_To
(Elsif_Parts
(If_Stmt
),
3009 Make_Elsif_Part
(Loc
,
3012 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
3013 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
3014 Then_Statements
=> New_List
(Prag
)));
3016 end Process_Variant
;
3020 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
3023 Formal_Map
: Elist_Id
;
3025 Last_Variant
: Node_Id
;
3027 Proc_Decl
: Node_Id
;
3028 Proc_Id
: Entity_Id
;
3029 Proc_Spec
: Node_Id
;
3033 -- Do nothing if pragma is not present or is disabled
3035 if Is_Ignored
(Prag
) then
3039 Aggr
:= Expression
(First
(Pragma_Argument_Associations
(Prag
)));
3041 -- The expansion of Subprogram Variant is quite distributed as it
3042 -- produces various statements to capture and compare the arguments.
3043 -- To preserve the original context, set the Is_Assertion_Expr flag.
3044 -- This aids the Ghost legality checks when verifying the placement
3045 -- of a reference to a Ghost entity.
3047 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
3049 -- Create declaration of the procedure that compares values of the
3050 -- variant expressions captured at the start of subprogram with their
3051 -- values at the recursive call of the subprogram.
3053 Proc_Id
:= Make_Defining_Identifier
(Loc
, Name_uVariants
);
3056 Make_Procedure_Specification
3058 Defining_Unit_Name
=> Proc_Id
,
3059 Parameter_Specifications
=> Copy_Parameter_List
(Subp_Id
));
3062 Make_Subprogram_Declaration
(Loc
, Proc_Spec
);
3064 Insert_Before_First_Source_Declaration
(Proc_Decl
, Body_Decls
);
3065 Analyze
(Proc_Decl
);
3067 -- Create a mapping between formals of the annotated subprogram (which
3068 -- are used to compute values of the variant expression at the start of
3069 -- subprogram) and formals of the internal procedure (which are used to
3070 -- compute values of of the variant expression at the recursive call).
3073 Formal_Param_Map
(Old_Subp
=> Subp_Id
, New_Subp
=> Proc_Id
);
3075 -- Process invidual increasing / decreasing variants
3078 Curr_Decls
:= New_List
;
3079 Last_Variant
:= Nlists
.Last
(Component_Associations
(Aggr
));
3081 Variant
:= First
(Component_Associations
(Aggr
));
3082 while Present
(Variant
) loop
3084 (Variant
=> Variant
,
3085 Formal_Map
=> Formal_Map
,
3087 Is_Last
=> Variant
= Last_Variant
);
3091 -- Create a subprogram body with declarations of objects that capture
3092 -- the current values of variant expressions at a recursive call and an
3093 -- if-then-else statement that compares current with old values.
3096 Make_Subprogram_Body
(Loc
,
3098 Copy_Subprogram_Spec
(Proc_Spec
),
3099 Declarations
=> Curr_Decls
,
3100 Handled_Statement_Sequence
=>
3101 Make_Handled_Sequence_Of_Statements
(Loc
,
3102 Statements
=> New_List
(If_Stmt
),
3103 End_Label
=> Make_Identifier
(Loc
, Chars
(Proc_Id
))));
3105 Insert_After_And_Analyze
(Last
, Proc_Bod
);
3107 -- Restore assertion context
3109 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
3111 -- Rewrite the aspect expression, which is no longer needed, with
3112 -- a reference to the procedure that has just been created. We will
3113 -- generate a call to this procedure at each recursive call of the
3114 -- subprogram that has been annotated with Subprogram_Variant.
3116 Rewrite
(Aggr
, New_Occurrence_Of
(Proc_Id
, Loc
));
3117 end Expand_Pragma_Subprogram_Variant
;
3119 -------------------------------------------
3120 -- Expand_Pragma_Suppress_Initialization --
3121 -------------------------------------------
3123 procedure Expand_Pragma_Suppress_Initialization
(N
: Node_Id
) is
3124 Def_Id
: constant Entity_Id
:= Entity
(Arg_N
(N
, 1));
3127 -- Variable case (we have to undo any initialization already done)
3129 if Ekind
(Def_Id
) = E_Variable
then
3130 Undo_Initialization
(Def_Id
, N
);
3132 end Expand_Pragma_Suppress_Initialization
;
3134 -------------------------
3135 -- Undo_Initialization --
3136 -------------------------
3138 procedure Undo_Initialization
(Def_Id
: Entity_Id
; N
: Node_Id
) is
3139 Init_Call
: Node_Id
;
3142 -- When applied to a variable, the default initialization must not be
3143 -- done. As it is already done when the pragma is found, we just get rid
3144 -- of the call the initialization procedure which followed the object
3145 -- declaration. The call is inserted after the declaration, but validity
3146 -- checks may also have been inserted and thus the initialization call
3147 -- does not necessarily appear immediately after the object declaration.
3149 -- We can't use the freezing mechanism for this purpose, since we have
3150 -- to elaborate the initialization expression when it is first seen (so
3151 -- this elaboration cannot be deferred to the freeze point).
3153 -- Find and remove generated initialization call for object, if any
3155 Init_Call
:= Remove_Init_Call
(Def_Id
, Rep_Clause
=> N
);
3157 -- Any default initialization expression should be removed (e.g.
3158 -- null defaults for access objects, zero initialization of packed
3159 -- bit arrays). Imported objects aren't allowed to have explicit
3160 -- initialization, so the expression must have been generated by
3163 if No
(Init_Call
) and then Present
(Expression
(Parent
(Def_Id
))) then
3164 Set_Expression
(Parent
(Def_Id
), Empty
);
3167 -- The object may not have any initialization, but in the presence of
3168 -- Initialize_Scalars code is inserted after then declaration, which
3169 -- must now be removed as well. The code carries the same source
3170 -- location as the declaration itself.
3172 if Initialize_Scalars
and then Is_Array_Type
(Etype
(Def_Id
)) then
3177 Init
:= Next
(Parent
(Def_Id
));
3178 while not Comes_From_Source
(Init
)
3179 and then Sloc
(Init
) = Sloc
(Def_Id
)
3187 end Undo_Initialization
;