1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with 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 Einfo
.Entities
; use Einfo
.Entities
;
32 with Einfo
.Utils
; use Einfo
.Utils
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Exp_Ch11
; use Exp_Ch11
;
36 with Exp_Util
; use Exp_Util
;
37 with Inline
; use Inline
;
39 with Namet
; use Namet
;
40 with Nlists
; use Nlists
;
41 with Nmake
; use Nmake
;
43 with Restrict
; use Restrict
;
44 with Rident
; use Rident
;
45 with Rtsfind
; use Rtsfind
;
47 with Sem_Aux
; use Sem_Aux
;
48 with Sem_Ch8
; use Sem_Ch8
;
49 with Sem_Prag
; use Sem_Prag
;
50 with Sem_Util
; use Sem_Util
;
51 with Sinfo
; use Sinfo
;
52 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
53 with Sinfo
.Utils
; use Sinfo
.Utils
;
54 with Sinput
; use Sinput
;
55 with Snames
; use Snames
;
56 with Stringt
; use Stringt
;
57 with Stand
; use Stand
;
58 with Tbuild
; use Tbuild
;
59 with Uintp
; use Uintp
;
60 with Validsw
; use Validsw
;
61 with Warnsw
; use Warnsw
;
63 package body Exp_Prag
is
65 -----------------------
66 -- Local Subprograms --
67 -----------------------
69 function Arg_N
(N
: Node_Id
; Arg_Number
: Positive) return Node_Id
;
70 -- Obtain specified pragma argument expression
72 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
);
73 procedure Expand_Pragma_Check
(N
: Node_Id
);
74 procedure Expand_Pragma_Common_Object
(N
: Node_Id
);
75 procedure Expand_Pragma_CUDA_Execute
(N
: Node_Id
);
76 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
);
77 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
);
78 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
);
79 procedure Expand_Pragma_Loop_Variant
(N
: Node_Id
);
80 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
);
81 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
);
82 procedure Expand_Pragma_Suppress_Initialization
(N
: Node_Id
);
84 procedure Undo_Initialization
(Def_Id
: Entity_Id
; N
: Node_Id
);
85 -- This procedure is used to undo initialization already done for Def_Id,
86 -- which is always an E_Variable, in response to the occurrence of the
87 -- pragma N, a pragma Interface, Import, or Suppress_Initialization. In all
88 -- these cases we want no initialization to occur, but we have already done
89 -- the initialization by the time we see the pragma, so we have to undo it.
95 function Arg_N
(N
: Node_Id
; Arg_Number
: Positive) return Node_Id
is
96 Arg
: Node_Id
:= First
(Pragma_Argument_Associations
(N
));
102 for J
in 2 .. Arg_Number
loop
109 if Present
(Arg
) then
110 return Get_Pragma_Arg
(Arg
);
116 ---------------------
117 -- Expand_N_Pragma --
118 ---------------------
120 procedure Expand_N_Pragma
(N
: Node_Id
) is
121 Pname
: constant Name_Id
:= Pragma_Name
(N
);
122 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
125 -- Suppress the expansion of an ignored assertion pragma. Such a pragma
126 -- should not be transformed into a null statement because:
128 -- * The pragma may be part of the rep item chain of a type, in which
129 -- case rewriting it will destroy the chain.
131 -- * The analysis of the pragma may involve two parts (see routines
132 -- Analyze_xxx_In_Decl_Part). The second part of the analysis will
133 -- not happen if the pragma is rewritten.
135 if Assertion_Expression_Pragma
(Prag_Id
) and then Is_Ignored
(N
) then
138 -- Rewrite the pragma into a null statement when it is ignored using
139 -- pragma Ignore_Pragma, or denotes Default_Scalar_Storage_Order and
140 -- compilation switch -gnatI is in effect.
142 elsif Should_Ignore_Pragma_Sem
(N
)
143 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
144 and then Ignore_Rep_Clauses
)
146 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
152 -- Pragmas requiring special expander action
154 when Pragma_Abort_Defer
=>
155 Expand_Pragma_Abort_Defer
(N
);
158 Expand_Pragma_Check
(N
);
160 when Pragma_Common_Object
=>
161 Expand_Pragma_Common_Object
(N
);
163 when Pragma_CUDA_Execute
=>
164 Expand_Pragma_CUDA_Execute
(N
);
166 when Pragma_Import
=>
167 Expand_Pragma_Import_Or_Interface
(N
);
169 when Pragma_Inspection_Point
=>
170 Expand_Pragma_Inspection_Point
(N
);
172 when Pragma_Interface
=>
173 Expand_Pragma_Import_Or_Interface
(N
);
175 when Pragma_Interrupt_Priority
=>
176 Expand_Pragma_Interrupt_Priority
(N
);
178 when Pragma_Loop_Variant
=>
179 Expand_Pragma_Loop_Variant
(N
);
181 when Pragma_Psect_Object
=>
182 Expand_Pragma_Psect_Object
(N
);
184 when Pragma_Relative_Deadline
=>
185 Expand_Pragma_Relative_Deadline
(N
);
187 when Pragma_Suppress_Initialization
=>
188 Expand_Pragma_Suppress_Initialization
(N
);
190 -- All other pragmas need no expander action (includes
197 -------------------------------
198 -- Expand_Pragma_Abort_Defer --
199 -------------------------------
201 -- An Abort_Defer pragma appears as the first statement in a handled
202 -- statement sequence (right after the begin). It defers aborts for
203 -- the entire statement sequence, but not for any declarations or
204 -- handlers (if any) associated with this statement sequence.
206 -- The transformation is to transform
208 -- pragma Abort_Defer;
217 -- when all others =>
218 -- Abort_Undefer.all;
221 -- Abort_Undefer_Direct;
224 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
) is
226 -- Abort_Defer has no useful effect if Abort's are not allowed
228 if not Abort_Allowed
then
232 -- Normal case where abort is possible
235 Loc
: constant Source_Ptr
:= Sloc
(N
);
239 Blk
: constant Entity_Id
:=
240 New_Internal_Entity
(E_Block
, Current_Scope
, Sloc
(N
), 'B');
241 AUD
: constant Entity_Id
:= RTE
(RE_Abort_Undefer_Direct
);
244 Stms
:= New_List
(Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
246 Stm
:= Remove_Next
(N
);
252 Make_Handled_Sequence_Of_Statements
(Loc
,
254 At_End_Proc
=> New_Occurrence_Of
(AUD
, Loc
));
256 -- Present the Abort_Undefer_Direct function to the backend so that
257 -- it can inline the call to the function.
259 Add_Inlined_Body
(AUD
, N
);
262 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
));
264 Set_Scope
(Blk
, Current_Scope
);
265 Set_Etype
(Blk
, Standard_Void_Type
);
266 Set_Identifier
(N
, New_Occurrence_Of
(Blk
, Sloc
(N
)));
267 Expand_At_End_Handler
(HSS
, Blk
);
270 end Expand_Pragma_Abort_Defer
;
272 --------------------------
273 -- Expand_Pragma_Check --
274 --------------------------
276 procedure Expand_Pragma_Check
(N
: Node_Id
) is
277 Cond
: constant Node_Id
:= Arg_N
(N
, 2);
278 Nam
: constant Name_Id
:= Chars
(Arg_N
(N
, 1));
281 Loc
: constant Source_Ptr
:= Sloc
(First_Node
(Cond
));
282 -- Source location used in the case of a failed assertion: point to the
283 -- failing condition, not Loc. Note that the source location of the
284 -- expression is not usually the best choice here, because it points to
285 -- the location of the topmost tree node, which may be an operator in
286 -- the middle of the source text of the expression. For example, it gets
287 -- located on the last AND keyword in a chain of boolean expressions
288 -- AND'ed together. It is best to put the message on the first character
289 -- of the condition, which is the effect of the First_Node call here.
290 -- This source location is used to build the default exception message,
291 -- and also as the sloc of the call to the runtime subprogram raising
292 -- Assert_Failure, so that coverage analysis tools can relate the
293 -- call to the failed check.
295 procedure Replace_Discriminals_Of_Protected_Op
(Expr
: Node_Id
);
296 -- Discriminants of the enclosing protected object may be referenced
297 -- in the expression of a precondition of a protected operation.
298 -- In the body of the operation these references must be replaced by
299 -- the discriminal created for them, which are renamings of the
300 -- discriminants of the object that is the target of the operation.
301 -- This replacement is done by visibility when the references appear
302 -- in the subprogram body, but in the case of a condition which appears
303 -- on the specification of the subprogram it has be done separately
304 -- because the condition has been replaced by a Check pragma and
305 -- analyzed earlier, before the creation of the discriminal renaming
306 -- declarations that are added to the subprogram body.
308 ------------------------------------------
309 -- Replace_Discriminals_Of_Protected_Op --
310 ------------------------------------------
312 procedure Replace_Discriminals_Of_Protected_Op
(Expr
: Node_Id
) is
313 function Find_Corresponding_Discriminal
314 (E
: Entity_Id
) return Entity_Id
;
315 -- Find the local entity that renames a discriminant of the enclosing
316 -- protected type, and has a matching name.
318 function Replace_Discr_Ref
(N
: Node_Id
) return Traverse_Result
;
319 -- Replace a reference to a discriminant of the original protected
320 -- type by the local renaming declaration of the discriminant of
321 -- the target object.
323 ------------------------------------
324 -- Find_Corresponding_Discriminal --
325 ------------------------------------
327 function Find_Corresponding_Discriminal
328 (E
: Entity_Id
) return Entity_Id
333 R
:= First_Entity
(Current_Scope
);
335 while Present
(R
) loop
336 if Nkind
(Parent
(R
)) = N_Object_Renaming_Declaration
337 and then Present
(Discriminal_Link
(R
))
338 and then Chars
(Discriminal_Link
(R
)) = Chars
(E
)
347 end Find_Corresponding_Discriminal
;
349 -----------------------
350 -- Replace_Discr_Ref --
351 -----------------------
353 function Replace_Discr_Ref
(N
: Node_Id
) return Traverse_Result
is
357 if Is_Entity_Name
(N
)
358 and then Present
(Discriminal_Link
(Entity
(N
)))
360 R
:= Find_Corresponding_Discriminal
(Entity
(N
));
361 Rewrite
(N
, New_Occurrence_Of
(R
, Sloc
(N
)));
365 end Replace_Discr_Ref
;
367 procedure Replace_Discriminant_References
is
368 new Traverse_Proc
(Replace_Discr_Ref
);
370 -- Start of processing for Replace_Discriminals_Of_Protected_Op
373 Replace_Discriminant_References
(Expr
);
374 end Replace_Discriminals_Of_Protected_Op
;
376 -- Start of processing for Expand_Pragma_Check
379 -- Nothing to do if pragma is ignored
381 if Is_Ignored
(N
) then
385 -- Since this check is active, rewrite the pragma into a corresponding
386 -- if statement, and then analyze the statement.
388 -- The normal case expansion transforms:
390 -- pragma Check (name, condition [,message]);
394 -- if not condition then
395 -- System.Assertions.Raise_Assert_Failure (Str);
398 -- where Str is the message if one is present, or the default of
399 -- name failed at file:line if no message is given (the "name failed
400 -- at" is omitted for name = Assertion, since it is redundant, given
401 -- that the name of the exception is Assert_Failure.)
403 -- Also, instead of "XXX failed at", we generate slightly
404 -- different messages for some of the contract assertions (see
405 -- code below for details).
407 -- An alternative expansion is used when the No_Exception_Propagation
408 -- restriction is active and there is a local Assert_Failure handler.
409 -- This is not a common combination of circumstances, but it occurs in
410 -- the context of Aunit and the zero footprint profile. In this case we
413 -- if not condition then
414 -- raise Assert_Failure;
417 -- This will then be transformed into a goto, and the local handler will
418 -- be able to handle the assert error (which would not be the case if a
419 -- call is made to the Raise_Assert_Failure procedure).
421 -- We also generate the direct raise if the Suppress_Exception_Locations
422 -- is active, since we don't want to generate messages in this case.
424 -- Note that the reason we do not always generate a direct raise is that
425 -- the form in which the procedure is called allows for more efficient
426 -- breakpointing of assertion errors.
428 -- Generate the appropriate if statement. Note that we consider this to
429 -- be an explicit conditional in the source, not an implicit if, so we
430 -- do not call Make_Implicit_If_Statement. Note also that we wrap the
431 -- raise statement in a block statement so that, if the condition is
432 -- evaluated at compile time to False, then the rewriting of the if
433 -- statement will not involve the raise but the block statement, and
434 -- thus not leave a dangling reference to the raise statement in the
435 -- Local_Raise_Statements list of the handler.
437 -- Case where we generate a direct raise
439 if ((Debug_Flag_Dot_G
440 or else Restriction_Active
(No_Exception_Propagation
))
441 and then Present
(Find_Local_Handler
(RTE
(RE_Assert_Failure
), N
)))
442 or else (Opt
.Exception_Locations_Suppressed
and then No
(Arg_N
(N
, 3)))
445 Make_If_Statement
(Loc
,
446 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Cond
),
447 Then_Statements
=> New_List
(
448 Make_Block_Statement
(Loc
,
449 Handled_Statement_Sequence
=>
450 Make_Handled_Sequence_Of_Statements
(Loc
,
451 Statements
=> New_List
(
452 Make_Raise_Statement
(Loc
,
454 New_Occurrence_Of
(RTE
(RE_Assert_Failure
),
457 Set_Comes_From_Check_Or_Contract
(N
);
459 -- Case where we call the procedure
462 -- If we have a message given, use it
464 if Present
(Arg_N
(N
, 3)) then
465 Msg
:= Get_Pragma_Arg
(Arg_N
(N
, 3));
467 -- Here we have no string, so prepare one
471 Loc_Str
: constant String := Build_Location_String
(Loc
);
476 -- For Assert, we just use the location
478 if Nam
= Name_Assert
then
481 -- For predicate, we generate the string "predicate failed at
482 -- yyy". We prefer all lower case for predicate.
484 elsif Nam
= Name_Predicate
then
485 Add_Str_To_Name_Buffer
("predicate failed at ");
487 -- For special case of Precondition/Postcondition the string is
488 -- "failed xx from yy" where xx is precondition/postcondition
489 -- in all lower case. The reason for this different wording is
490 -- that the failure is not at the point of occurrence of the
491 -- pragma, unlike the other Check cases.
493 elsif Nam
in Name_Precondition | Name_Postcondition
then
494 Get_Name_String
(Nam
);
495 Insert_Str_In_Name_Buffer
("failed ", 1);
496 Add_Str_To_Name_Buffer
(" from ");
498 -- For special case of Invariant, the string is "failed
499 -- invariant from yy", to be consistent with the string that is
500 -- generated for the aspect case (the code later on checks for
501 -- this specific string to modify it in some cases, so this is
502 -- functionally important).
504 elsif Nam
= Name_Invariant
then
505 Add_Str_To_Name_Buffer
("failed invariant from ");
507 -- For all other checks, the string is "xxx failed at yyy"
508 -- where xxx is the check name with appropriate casing.
511 Get_Name_String
(Nam
);
513 (Identifier_Casing
(Source_Index
(Current_Sem_Unit
)));
514 Add_Str_To_Name_Buffer
(" failed at ");
517 -- In all cases, add location string
519 Add_Str_To_Name_Buffer
(Loc_Str
);
523 Msg
:= Make_String_Literal
(Loc
, Name_Buffer
(1 .. Name_Len
));
527 -- For a precondition, replace references to discriminants of a
528 -- protected type with the local discriminals.
530 if Is_Protected_Type
(Scope
(Current_Scope
))
531 and then Has_Discriminants
(Scope
(Current_Scope
))
532 and then From_Aspect_Specification
(N
)
534 Replace_Discriminals_Of_Protected_Op
(Cond
);
537 -- Now rewrite as an if statement
540 Make_If_Statement
(Loc
,
541 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Cond
),
542 Then_Statements
=> New_List
(
543 Make_Procedure_Call_Statement
(Loc
,
545 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
546 Parameter_Associations
=> New_List
(Relocate_Node
(Msg
))))));
548 Set_Comes_From_Check_Or_Contract
(N
);
553 -- If new condition is always false, give a warning
555 if Warn_On_Assertion_Failure
556 and then Nkind
(N
) = N_Procedure_Call_Statement
557 and then Is_RTE
(Entity
(Name
(N
)), RE_Raise_Assert_Failure
)
559 -- If original condition was a Standard.False, we assume that this is
560 -- indeed intended to raise assert error and no warning is required.
562 if Is_Entity_Name
(Original_Node
(Cond
))
563 and then Entity
(Original_Node
(Cond
)) = Standard_False
567 elsif Nam
= Name_Assert
then
568 Error_Msg_N
("?.a?assertion will fail at run time", N
);
570 Error_Msg_N
("?.a?check will fail at run time", N
);
573 end Expand_Pragma_Check
;
575 ---------------------------------
576 -- Expand_Pragma_Common_Object --
577 ---------------------------------
579 -- Use a machine attribute to replicate semantic effect in DEC Ada
581 -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
583 -- For now we do nothing with the size attribute ???
585 -- Note: Psect_Object shares this processing
587 procedure Expand_Pragma_Common_Object
(N
: Node_Id
) is
588 Loc
: constant Source_Ptr
:= Sloc
(N
);
590 Internal
: constant Node_Id
:= Arg_N
(N
, 1);
591 External
: constant Node_Id
:= Arg_N
(N
, 2);
594 -- Psect value upper cased as string literal
596 Iloc
: constant Source_Ptr
:= Sloc
(Internal
);
597 Eloc
: constant Source_Ptr
:= Sloc
(External
);
601 -- Acquire Psect value and fold to upper case
603 if Present
(External
) then
604 if Nkind
(External
) = N_String_Literal
then
605 String_To_Name_Buffer
(Strval
(External
));
607 Get_Name_String
(Chars
(External
));
610 Set_Casing
(All_Upper_Case
);
613 Make_String_Literal
(Eloc
, Strval
=> String_From_Name_Buffer
);
616 Get_Name_String
(Chars
(Internal
));
617 Set_Casing
(All_Upper_Case
);
619 Make_String_Literal
(Iloc
, Strval
=> String_From_Name_Buffer
);
622 Ploc
:= Sloc
(Psect
);
626 Insert_After_And_Analyze
(N
,
628 Chars
=> Name_Machine_Attribute
,
629 Pragma_Argument_Associations
=> New_List
(
630 Make_Pragma_Argument_Association
(Iloc
,
631 Expression
=> New_Copy_Tree
(Internal
)),
632 Make_Pragma_Argument_Association
(Eloc
,
634 Make_String_Literal
(Sloc
=> Ploc
, Strval
=> "common_object")),
635 Make_Pragma_Argument_Association
(Ploc
,
636 Expression
=> New_Copy_Tree
(Psect
)))));
637 end Expand_Pragma_Common_Object
;
639 --------------------------------
640 -- Expand_Pragma_CUDA_Execute --
641 --------------------------------
643 -- Pragma CUDA_Execute is expanded in the following manner:
647 -- pragma CUDA_Execute (My_Proc (X, Y), Blocks, Grids, Mem, Stream)
652 -- Blocks_Id : CUDA.Vector_Types.Dim3 := Blocks;
653 -- Grids_Id : CUDA.Vector_Types.Dim3 := Grids;
654 -- Mem_Id : Integer := <Mem or 0>;
655 -- Stream_Id : CUDA.Driver_Types.Stream_T := <Stream or null>;
656 -- X_Id : <Type of X> := X;
657 -- Y_Id : <Type of Y> := Y;
658 -- Arg_Id : Array (1..2) of System.Address :=
659 -- (X'Address,_Id Y'Address);_Id
661 -- CUDA.Internal.Push_Call_Configuration (
666 -- CUDA.Internal.Pop_Call_Configuration (
668 -- Blocks_Id'address,
670 -- Stream_Id'address),
671 -- CUDA.Runtime_Api.Launch_Kernel (
680 procedure Expand_Pragma_CUDA_Execute
(N
: Node_Id
) is
682 Loc
: constant Source_Ptr
:= Sloc
(N
);
684 procedure Append_Copies
688 -- For each parameter in list Params, create an object declaration of
689 -- the followinng form:
691 -- Copy_Id : Param_Typ := Param_Val;
693 -- Param_Typ is the type of the parameter. Param_Val is the initial
694 -- value of the parameter. The declarations are stored in Decls, the
695 -- entities of the new objects are collected in list Copies.
697 function Build_Dim3_Declaration
698 (Decl_Id
: Entity_Id
;
699 Init_Val
: Node_Id
) return Node_Id
;
700 -- Build an object declaration of the form
702 -- Decl_Id : CUDA.Internal.Dim3 := Val;
704 -- Val depends on the nature of Init_Val, as follows:
706 -- * If Init_Val is of type CUDA.Vector_Types.Dim3, then Val has the
709 -- (Interfaces.C.Unsigned (Val.X),
710 -- Interfaces.C.Unsigned (Val.Y),
711 -- Interfaces.C.Unsigned (Val.Z))
713 -- * If Init_Val is a single Integer, Val has the following form:
715 -- (Interfaces.C.Unsigned (Init_Val),
716 -- Interfaces.C.Unsigned (1),
717 -- Interfaces.C.Unsigned (1))
719 -- * If Init_Val is an aggregate of three values, Val has the
722 -- (Interfaces.C.Unsigned (Val_1),
723 -- Interfaces.C.Unsigned (Val_2),
724 -- Interfaces.C.Unsigned (Val_3))
726 function Build_Kernel_Args_Declaration
727 (Kernel_Arg
: Entity_Id
;
728 Var_Ids
: Elist_Id
) return Node_Id
;
729 -- Given a list of variables, return an object declaration of the
732 -- Kernel_Arg : ... := (Var_1'Address, ..., Var_N'Address);
734 function Build_Launch_Kernel_Call
736 Grid_Dims
: Entity_Id
;
737 Block_Dims
: Entity_Id
;
738 Kernel_Arg
: Entity_Id
;
740 Stream
: Entity_Id
) return Node_Id
;
741 -- Builds and returns a call to CUDA.Launch_Kernel using the given
742 -- arguments. Proc is the entity of the procedure passed to the
743 -- CUDA_Execute pragma. Grid_Dims and Block_Dims are entities of the
744 -- generated declarations that hold the kernel's dimensions. Args is the
745 -- entity of the temporary array that holds the arguments of the kernel.
746 -- Memory and Stream are the entities of the temporaries that hold the
747 -- fourth and fith arguments of CUDA_Execute or their default values.
749 function Build_Shared_Memory_Declaration
750 (Decl_Id
: Entity_Id
;
751 Init_Val
: Node_Id
) return Node_Id
;
752 -- Builds a declaration the Defining_Identifier of which is Decl_Id, the
753 -- type of which is inferred from CUDA.Internal.Launch_Kernel and the
754 -- value of which is Init_Val if present or null if not.
756 function Build_Simple_Declaration_With_Default
757 (Decl_Id
: Entity_Id
;
760 Default_Val
: Node_Id
) return Node_Id
;
761 -- Build a declaration the Defining_Identifier of which is Decl_Id, the
762 -- Object_Definition of which is Typ, the value of which is Init_Val if
763 -- present or Default otherwise.
765 function Build_Stream_Declaration
766 (Decl_Id
: Entity_Id
;
767 Init_Val
: Node_Id
) return Node_Id
;
768 -- Build a declaration the Defining_Identifier of which is Decl_Id, the
769 -- type of which is Integer, the value of which is Init_Val if present
772 function Etype_Or_Dim3
(N
: Node_Id
) return Node_Id
;
773 -- If N is an aggregate whose type is unknown, return a new occurrence
774 -- of the public Dim3 type. Otherwise, return a new occurrence of N's
777 function Get_Nth_Arg_Type
778 (Subprogram
: Entity_Id
;
779 N
: Positive) return Entity_Id
;
780 -- Returns the type of the Nth argument of Subprogram
782 function To_Addresses
(Elmts
: Elist_Id
) return List_Id
;
783 -- Returns a new list containing each element of Elmts wrapped in an
784 -- 'address attribute reference. When passed No_Elist, returns an empty
791 procedure Append_Copies
800 Param
:= First
(Params
);
801 while Present
(Param
) loop
802 Copy
:= Make_Temporary
(Loc
, 'C');
804 if Nkind
(Param
) = N_Parameter_Association
then
805 Expr
:= Explicit_Actual_Parameter
(Param
);
811 Make_Object_Declaration
(Loc
,
812 Defining_Identifier
=> Copy
,
813 Object_Definition
=> New_Occurrence_Of
(Etype
(Expr
), Loc
),
814 Expression
=> New_Copy_Tree
(Expr
)));
816 Append_Elmt
(Copy
, Copies
);
821 ----------------------------
822 -- Build_Dim3_Declaration --
823 ----------------------------
825 function Build_Dim3_Declaration
826 (Decl_Id
: Entity_Id
;
827 Init_Val
: Node_Id
) return Node_Id
829 -- Expressions for each component of the returned Dim3
834 -- Type of CUDA.Internal.Dim3 - inferred from
835 -- RE_Push_Call_Configuration to avoid needing changes in GNAT when
836 -- the CUDA bindings change (this happens frequently).
837 Internal_Dim3
: constant Entity_Id
:=
838 Get_Nth_Arg_Type
(RTE
(RE_Push_Call_Configuration
), 1);
840 -- Entities for each component of external and internal Dim3
841 First_Component
: Entity_Id
:= First_Entity
(RTE
(RE_Dim3
));
842 Second_Component
: Entity_Id
:= Next_Entity
(First_Component
);
843 Third_Component
: Entity_Id
:= Next_Entity
(Second_Component
);
847 -- Sem_prag.adb ensured that Init_Val is either a Dim3, an aggregate
848 -- of three Any_Integers or Any_Integer.
850 -- If Init_Val is a Dim3, use each of its components
852 if Etype
(Init_Val
) = RTE
(RE_Dim3
) then
853 Dim_X
:= Make_Selected_Component
(Loc
,
854 Prefix
=> New_Occurrence_Of
(Entity
(Init_Val
), Loc
),
855 Selector_Name
=> New_Occurrence_Of
(First_Component
, Loc
));
857 Dim_Y
:= Make_Selected_Component
(Loc
,
858 Prefix
=> New_Occurrence_Of
(Entity
(Init_Val
), Loc
),
859 Selector_Name
=> New_Occurrence_Of
(Second_Component
, Loc
));
861 Dim_Z
:= Make_Selected_Component
(Loc
,
862 Prefix
=> New_Occurrence_Of
(Entity
(Init_Val
), Loc
),
863 Selector_Name
=> New_Occurrence_Of
(Third_Component
, Loc
));
865 -- If Init_Val is an aggregate, use each of its arguments
867 if Nkind
(Init_Val
) = N_Aggregate
then
868 Dim_X
:= First
(Expressions
(Init_Val
));
869 Dim_Y
:= Next
(Dim_X
);
870 Dim_Z
:= Next
(Dim_Y
);
872 -- Otherwise, we know it is an integer and the rest defaults to 1
876 Dim_Y
:= Make_Integer_Literal
(Loc
, 1);
877 Dim_Z
:= Make_Integer_Literal
(Loc
, 1);
881 First_Component
:= First_Entity
(Internal_Dim3
);
882 Second_Component
:= Next_Entity
(First_Component
);
883 Third_Component
:= Next_Entity
(Second_Component
);
885 -- Finally return the CUDA.Internal.Dim3 declaration with an
886 -- aggregate initialization expression.
888 return Make_Object_Declaration
(Loc
,
889 Defining_Identifier
=> Decl_Id
,
890 Object_Definition
=> New_Occurrence_Of
(Internal_Dim3
, Loc
),
891 Expression
=> Make_Aggregate
(Loc
,
892 Expressions
=> New_List
(
893 Make_Type_Conversion
(Loc
,
895 New_Occurrence_Of
(Etype
(First_Component
), Loc
),
896 Expression
=> New_Copy_Tree
(Dim_X
)),
897 Make_Type_Conversion
(Loc
,
899 New_Occurrence_Of
(Etype
(Second_Component
), Loc
),
900 Expression
=> New_Copy_Tree
(Dim_Y
)),
901 Make_Type_Conversion
(Loc
,
903 New_Occurrence_Of
(Etype
(Third_Component
), Loc
),
904 Expression
=> New_Copy_Tree
(Dim_Z
)))));
905 end Build_Dim3_Declaration
;
907 -----------------------------------
908 -- Build_Kernel_Args_Declaration --
909 -----------------------------------
911 function Build_Kernel_Args_Declaration
912 (Kernel_Arg
: Entity_Id
;
913 Var_Ids
: Elist_Id
) return Node_Id
915 Vals
: constant List_Id
:= To_Addresses
(Var_Ids
);
918 Make_Object_Declaration
(Loc
,
919 Defining_Identifier
=> Kernel_Arg
,
921 Make_Constrained_Array_Definition
(Loc
,
922 Discrete_Subtype_Definitions
=> New_List
(
924 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
926 Make_Integer_Literal
(Loc
, List_Length
(Vals
)))),
927 Component_Definition
=>
928 Make_Component_Definition
(Loc
,
929 Subtype_Indication
=>
930 New_Occurrence_Of
(Etype
(RTE
(RE_Address
)), Loc
))),
931 Expression
=> Make_Aggregate
(Loc
, Vals
));
932 end Build_Kernel_Args_Declaration
;
934 -------------------------------
935 -- Build_Launch_Kernel_Call --
936 -------------------------------
938 function Build_Launch_Kernel_Call
940 Grid_Dims
: Entity_Id
;
941 Block_Dims
: Entity_Id
;
942 Kernel_Arg
: Entity_Id
;
944 Stream
: Entity_Id
) return Node_Id
is
947 Make_Procedure_Call_Statement
(Loc
,
949 New_Occurrence_Of
(RTE
(RE_Launch_Kernel
), Loc
),
950 Parameter_Associations
=> New_List
(
951 Make_Attribute_Reference
(Loc
,
952 Prefix
=> New_Occurrence_Of
(Proc
, Loc
),
953 Attribute_Name
=> Name_Address
),
954 New_Occurrence_Of
(Grid_Dims
, Loc
),
955 New_Occurrence_Of
(Block_Dims
, Loc
),
956 Make_Attribute_Reference
(Loc
,
957 Prefix
=> New_Occurrence_Of
(Kernel_Arg
, Loc
),
958 Attribute_Name
=> Name_Address
),
959 New_Occurrence_Of
(Memory
, Loc
),
960 New_Occurrence_Of
(Stream
, Loc
)));
961 end Build_Launch_Kernel_Call
;
963 -------------------------------------
964 -- Build_Shared_Memory_Declaration --
965 -------------------------------------
967 function Build_Shared_Memory_Declaration
968 (Decl_Id
: Entity_Id
;
969 Init_Val
: Node_Id
) return Node_Id
972 return Build_Simple_Declaration_With_Default
974 Init_Val
=> Init_Val
,
977 (Get_Nth_Arg_Type
(RTE
(RE_Launch_Kernel
), 5), Loc
),
978 Default_Val
=> Make_Integer_Literal
(Loc
, 0));
979 end Build_Shared_Memory_Declaration
;
981 -------------------------------------------
982 -- Build_Simple_Declaration_With_Default --
983 -------------------------------------------
985 function Build_Simple_Declaration_With_Default
986 (Decl_Id
: Entity_Id
;
989 Default_Val
: Node_Id
) return Node_Id
991 Value
: Node_Id
:= Init_Val
;
994 Value
:= Default_Val
;
997 return Make_Object_Declaration
(Loc
,
998 Defining_Identifier
=> Decl_Id
,
999 Object_Definition
=> Typ
,
1000 Expression
=> Value
);
1001 end Build_Simple_Declaration_With_Default
;
1003 ------------------------------
1004 -- Build_Stream_Declaration --
1005 ------------------------------
1007 function Build_Stream_Declaration
1008 (Decl_Id
: Entity_Id
;
1009 Init_Val
: Node_Id
) return Node_Id
1012 return Build_Simple_Declaration_With_Default
1013 (Decl_Id
=> Decl_Id
,
1014 Init_Val
=> Init_Val
,
1017 (Get_Nth_Arg_Type
(RTE
(RE_Launch_Kernel
), 6), Loc
),
1018 Default_Val
=> Make_Null
(Loc
));
1019 end Build_Stream_Declaration
;
1025 function Etype_Or_Dim3
(N
: Node_Id
) return Node_Id
is
1027 if Nkind
(N
) = N_Aggregate
and then Is_Composite_Type
(Etype
(N
)) then
1028 return New_Occurrence_Of
(RTE
(RE_Dim3
), Sloc
(N
));
1031 return New_Occurrence_Of
(Etype
(N
), Loc
);
1034 ----------------------
1035 -- Get_Nth_Arg_Type --
1036 ----------------------
1038 function Get_Nth_Arg_Type
1039 (Subprogram
: Entity_Id
;
1040 N
: Positive) return Entity_Id
1042 Argument
: Entity_Id
:= First_Entity
(Subprogram
);
1044 for J
in 2 .. N
loop
1045 Next_Entity
(Argument
);
1048 return Etype
(Argument
);
1049 end Get_Nth_Arg_Type
;
1055 function To_Addresses
(Elmts
: Elist_Id
) return List_Id
is
1056 Result
: constant List_Id
:= New_List
;
1063 Elmt
:= First_Elmt
(Elmts
);
1064 while Present
(Elmt
) loop
1066 Make_Attribute_Reference
(Loc
,
1067 Prefix
=> New_Occurrence_Of
(Node
(Elmt
), Loc
),
1068 Attribute_Name
=> Name_Address
));
1079 Procedure_Call
: constant Node_Id
:= Get_Pragma_Arg
(Arg_N
(N
, 1));
1080 Grid_Dimensions
: constant Node_Id
:= Get_Pragma_Arg
(Arg_N
(N
, 2));
1081 Block_Dimensions
: constant Node_Id
:= Get_Pragma_Arg
(Arg_N
(N
, 3));
1082 Shared_Memory
: constant Node_Id
:= Get_Pragma_Arg
(Arg_N
(N
, 4));
1083 CUDA_Stream
: constant Node_Id
:= Get_Pragma_Arg
(Arg_N
(N
, 5));
1085 -- Entities of objects that will be overwritten by calls to cuda runtime
1086 Grids_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1087 Blocks_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1088 Memory_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1089 Stream_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1091 -- Entities of objects that capture the value of pragma arguments
1092 Temp_Grid
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1093 Temp_Block
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1095 -- Declarations for temporary block and grids. These needs to be stored
1096 -- in temporary declarations as the expressions will need to be
1097 -- referenced multiple times but could have side effects.
1098 Temp_Grid_Decl
: constant Node_Id
:= Make_Object_Declaration
(Loc
,
1099 Defining_Identifier
=> Temp_Grid
,
1100 Object_Definition
=> Etype_Or_Dim3
(Grid_Dimensions
),
1101 Expression
=> Grid_Dimensions
);
1102 Temp_Block_Decl
: constant Node_Id
:= Make_Object_Declaration
(Loc
,
1103 Defining_Identifier
=> Temp_Block
,
1104 Object_Definition
=> Etype_Or_Dim3
(Block_Dimensions
),
1105 Expression
=> Block_Dimensions
);
1107 -- List holding the entities of the copies of Procedure_Call's arguments
1109 Kernel_Arg_Copies
: constant Elist_Id
:= New_Elmt_List
;
1111 -- Entity of the array that contains the address of each of the kernel's
1114 Kernel_Args_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'C');
1116 -- Calls to the CUDA runtime API.
1118 Launch_Kernel_Call
: Node_Id
;
1120 Push_Call
: Node_Id
;
1122 -- Declaration of all temporaries required for CUDA API Calls
1124 Blk_Decls
: constant List_Id
:= New_List
;
1126 -- Start of processing for CUDA_Execute
1129 -- Append temporary declarations
1131 Append_To
(Blk_Decls
, Temp_Grid_Decl
);
1132 Analyze
(Temp_Grid_Decl
);
1134 Append_To
(Blk_Decls
, Temp_Block_Decl
);
1135 Analyze
(Temp_Block_Decl
);
1137 -- Build parameter declarations for CUDA API calls
1141 Build_Dim3_Declaration
1142 (Grids_Id
, New_Occurrence_Of
(Temp_Grid
, Loc
)));
1146 Build_Dim3_Declaration
1147 (Blocks_Id
, New_Occurrence_Of
(Temp_Block
, Loc
)));
1151 Build_Shared_Memory_Declaration
(Memory_Id
, Shared_Memory
));
1154 (Blk_Decls
, Build_Stream_Declaration
(Stream_Id
, CUDA_Stream
));
1157 (Parameter_Associations
(Procedure_Call
),
1163 Build_Kernel_Args_Declaration
1164 (Kernel_Args_Id
, Kernel_Arg_Copies
));
1166 -- Build calls to the CUDA API
1169 Make_Procedure_Call_Statement
(Loc
,
1171 New_Occurrence_Of
(RTE
(RE_Push_Call_Configuration
), Loc
),
1172 Parameter_Associations
=> New_List
(
1173 New_Occurrence_Of
(Grids_Id
, Loc
),
1174 New_Occurrence_Of
(Blocks_Id
, Loc
),
1175 New_Occurrence_Of
(Memory_Id
, Loc
),
1176 New_Occurrence_Of
(Stream_Id
, Loc
)));
1179 Make_Procedure_Call_Statement
(Loc
,
1181 New_Occurrence_Of
(RTE
(RE_Pop_Call_Configuration
), Loc
),
1182 Parameter_Associations
=> To_Addresses
1189 Launch_Kernel_Call
:= Build_Launch_Kernel_Call
1190 (Proc
=> Entity
(Name
(Procedure_Call
)),
1191 Grid_Dims
=> Grids_Id
,
1192 Block_Dims
=> Blocks_Id
,
1193 Kernel_Arg
=> Kernel_Args_Id
,
1194 Memory
=> Memory_Id
,
1195 Stream
=> Stream_Id
);
1197 -- Finally make the block that holds declarations and calls
1200 Make_Block_Statement
(Loc
,
1201 Declarations
=> Blk_Decls
,
1202 Handled_Statement_Sequence
=>
1203 Make_Handled_Sequence_Of_Statements
(Loc
,
1204 Statements
=> New_List
(
1207 Launch_Kernel_Call
))));
1209 end Expand_Pragma_CUDA_Execute
;
1211 ----------------------------------
1212 -- Expand_Pragma_Contract_Cases --
1213 ----------------------------------
1215 -- Pragma Contract_Cases is expanded in the following manner:
1218 -- Count : Natural := 0;
1219 -- Flag_1 : Boolean := False;
1221 -- Flag_N : Boolean := False;
1222 -- Flag_N+1 : Boolean := False; -- when "others" present
1227 -- <preconditions (if any)>
1229 -- -- Evaluate all case guards
1231 -- if Case_Guard_1 then
1233 -- Count := Count + 1;
1236 -- if Case_Guard_N then
1238 -- Count := Count + 1;
1241 -- -- Emit errors depending on the number of case guards that
1242 -- -- evaluated to True.
1244 -- if Count = 0 then
1245 -- raise Assertion_Error with "xxx contract cases incomplete";
1247 -- Flag_N+1 := True; -- when "others" present
1249 -- elsif Count > 1 then
1251 -- Str0 : constant String :=
1252 -- "contract cases overlap for subprogram ABC";
1253 -- Str1 : constant String :=
1255 -- Str0 & "case guard at xxx evaluates to True"
1257 -- StrN : constant String :=
1259 -- StrN-1 & "case guard at xxx evaluates to True"
1262 -- raise Assertion_Error with StrN;
1266 -- -- Evaluate all attribute 'Old prefixes found in the selected
1270 -- Pref_1 := <prefix of 'Old found in Consequence_1>
1272 -- elsif Flag_N then
1273 -- Pref_M := <prefix of 'Old found in Consequence_N>
1276 -- procedure _Postconditions is
1278 -- <postconditions (if any)>
1280 -- if Flag_1 and then not Consequence_1 then
1281 -- raise Assertion_Error with "failed contract case at xxx";
1284 -- if Flag_N[+1] and then not Consequence_N[+1] then
1285 -- raise Assertion_Error with "failed contract case at xxx";
1287 -- end _Postconditions;
1292 procedure Expand_Pragma_Contract_Cases
1294 Subp_Id
: Entity_Id
;
1296 Stmts
: in out List_Id
)
1298 Loc
: constant Source_Ptr
:= Sloc
(CCs
);
1300 procedure Case_Guard_Error
1303 Error_Loc
: Source_Ptr
;
1304 Msg
: in out Entity_Id
);
1305 -- Given a declarative list Decls, status flag Flag, the location of the
1306 -- error and a string Msg, construct the following check:
1307 -- Msg : constant String :=
1309 -- Msg & "case guard at Error_Loc evaluates to True"
1311 -- The resulting code is added to Decls
1313 procedure Consequence_Error
1314 (Checks
: in out Node_Id
;
1317 -- Given an if statement Checks, status flag Flag and a consequence
1318 -- Conseq, construct the following check:
1319 -- [els]if Flag and then not Conseq then
1320 -- raise Assertion_Error
1321 -- with "failed contract case at Sloc (Conseq)";
1323 -- The resulting code is added to Checks
1325 function Declaration_Of
(Id
: Entity_Id
) return Node_Id
;
1326 -- Given the entity Id of a boolean flag, generate:
1327 -- Id : Boolean := False;
1329 procedure Expand_Attributes_In_Consequence
1331 Evals
: in out Node_Id
;
1334 -- Perform specialized expansion of all attribute 'Old references found
1335 -- in consequence Conseq such that at runtime only prefixes coming from
1336 -- the selected consequence are evaluated. Similarly expand attribute
1337 -- 'Result references by replacing them with identifier _result which
1338 -- resolves to the sole formal parameter of procedure _Postconditions.
1339 -- Any temporaries generated in the process are added to declarations
1340 -- Decls. Evals is a complex if statement tasked with the evaluation of
1341 -- all prefixes coming from a single selected consequence. Flag is the
1342 -- corresponding case guard flag. Conseq is the consequence expression.
1344 function Increment
(Id
: Entity_Id
) return Node_Id
;
1345 -- Given the entity Id of a numerical variable, generate:
1348 function Set
(Id
: Entity_Id
) return Node_Id
;
1349 -- Given the entity Id of a boolean variable, generate:
1352 ----------------------
1353 -- Case_Guard_Error --
1354 ----------------------
1356 procedure Case_Guard_Error
1359 Error_Loc
: Source_Ptr
;
1360 Msg
: in out Entity_Id
)
1362 New_Line
: constant Character := Character'Val (10);
1363 New_Msg
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
1367 Store_String_Char
(New_Line
);
1368 Store_String_Chars
(" case guard at ");
1369 Store_String_Chars
(Build_Location_String
(Error_Loc
));
1370 Store_String_Chars
(" evaluates to True");
1373 -- New_Msg : constant String :=
1375 -- Msg & "case guard at Error_Loc evaluates to True"
1379 Make_Object_Declaration
(Loc
,
1380 Defining_Identifier
=> New_Msg
,
1381 Constant_Present
=> True,
1382 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
1384 Make_If_Expression
(Loc
,
1385 Expressions
=> New_List
(
1386 New_Occurrence_Of
(Flag
, Loc
),
1388 Make_Op_Concat
(Loc
,
1389 Left_Opnd
=> New_Occurrence_Of
(Msg
, Loc
),
1390 Right_Opnd
=> Make_String_Literal
(Loc
, End_String
)),
1392 New_Occurrence_Of
(Msg
, Loc
)))));
1395 end Case_Guard_Error
;
1397 -----------------------
1398 -- Consequence_Error --
1399 -----------------------
1401 procedure Consequence_Error
1402 (Checks
: in out Node_Id
;
1411 -- Flag and then not Conseq
1415 Left_Opnd
=> New_Occurrence_Of
(Flag
, Loc
),
1418 Right_Opnd
=> Relocate_Node
(Conseq
)));
1421 -- raise Assertion_Error
1422 -- with "failed contract case at Sloc (Conseq)";
1425 Store_String_Chars
("failed contract case at ");
1426 Store_String_Chars
(Build_Location_String
(Sloc
(Conseq
)));
1429 Make_Procedure_Call_Statement
(Loc
,
1431 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
1432 Parameter_Associations
=> New_List
(
1433 Make_String_Literal
(Loc
, End_String
)));
1437 Make_Implicit_If_Statement
(CCs
,
1439 Then_Statements
=> New_List
(Error
));
1441 Set_Comes_From_Check_Or_Contract
(Checks
);
1444 if No
(Elsif_Parts
(Checks
)) then
1445 Set_Elsif_Parts
(Checks
, New_List
);
1448 Append_To
(Elsif_Parts
(Checks
),
1449 Make_Elsif_Part
(Loc
,
1451 Then_Statements
=> New_List
(Error
)));
1453 end Consequence_Error
;
1455 --------------------
1456 -- Declaration_Of --
1457 --------------------
1459 function Declaration_Of
(Id
: Entity_Id
) return Node_Id
is
1462 Make_Object_Declaration
(Loc
,
1463 Defining_Identifier
=> Id
,
1464 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1465 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
));
1468 --------------------------------------
1469 -- Expand_Attributes_In_Consequence --
1470 --------------------------------------
1472 procedure Expand_Attributes_In_Consequence
1474 Evals
: in out Node_Id
;
1478 Eval_Stmts
: List_Id
:= No_List
;
1479 -- The evaluation sequence expressed as assignment statements of all
1480 -- prefixes of attribute 'Old found in the current consequence.
1482 function Expand_Attributes
(N
: Node_Id
) return Traverse_Result
;
1483 -- Determine whether an arbitrary node denotes attribute 'Old or
1484 -- 'Result and if it does, perform all expansion-related actions.
1486 -----------------------
1487 -- Expand_Attributes --
1488 -----------------------
1490 function Expand_Attributes
(N
: Node_Id
) return Traverse_Result
is
1494 Indirect
: Boolean := False;
1496 use Sem_Util
.Old_Attr_Util
.Indirect_Temps
;
1498 procedure Append_For_Indirect_Temp
1499 (N
: Node_Id
; Is_Eval_Stmt
: Boolean);
1501 -- Append either a declaration (which is to be elaborated
1502 -- unconditionally) or an evaluation statement (which is
1503 -- to be executed conditionally).
1505 -------------------------------
1506 -- Append_For_Indirect_Temp --
1507 -------------------------------
1509 procedure Append_For_Indirect_Temp
1510 (N
: Node_Id
; Is_Eval_Stmt
: Boolean)
1513 if Is_Eval_Stmt
then
1514 Append_To
(Eval_Stmts
, N
);
1516 Prepend_To
(Decls
, N
);
1517 -- This use of Prepend (as opposed to Append) is why
1518 -- we have the Append_Decls_In_Reverse_Order parameter.
1520 end Append_For_Indirect_Temp
;
1522 procedure Declare_Indirect_Temporary
is new
1523 Declare_Indirect_Temp
(
1524 Append_Item
=> Append_For_Indirect_Temp
,
1525 Append_Decls_In_Reverse_Order
=> True);
1527 -- Start of processing for Expand_Attributes
1532 if Is_Attribute_Old
(N
) then
1535 Indirect
:= Indirect_Temp_Needed
(Etype
(Pref
));
1538 if No
(Eval_Stmts
) then
1539 Eval_Stmts
:= New_List
;
1542 Declare_Indirect_Temporary
1543 (Attr_Prefix
=> Pref
,
1544 Indirect_Temp
=> Temp
);
1546 -- Declare a temporary of the prefix type with no explicit
1547 -- initial value. If the appropriate contract case is selected
1548 -- at run time, then the temporary will be initialized via an
1549 -- assignment statement.
1552 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
1553 Set_Etype
(Temp
, Etype
(Pref
));
1555 -- Generate a temporary to capture the value of the prefix:
1556 -- Temp : <Pref type>;
1559 Make_Object_Declaration
(Loc
,
1560 Defining_Identifier
=> Temp
,
1561 Object_Definition
=>
1562 New_Occurrence_Of
(Etype
(Pref
), Loc
));
1564 -- Place that temporary at the beginning of declarations, to
1565 -- prevent anomalies in the GNATprove flow-analysis pass in
1566 -- the precondition procedure that follows.
1568 Prepend_To
(Decls
, Decl
);
1570 -- Initially Temp is uninitialized (which is required for
1571 -- correctness if default initialization might have side
1572 -- effects). Assign prefix value to temp on Eval_Statement
1573 -- list, so assignment will be executed conditionally.
1575 Mutate_Ekind
(Temp
, E_Variable
);
1576 Set_Suppress_Initialization
(Temp
);
1579 if No
(Eval_Stmts
) then
1580 Eval_Stmts
:= New_List
;
1583 Append_To
(Eval_Stmts
,
1584 Make_Assignment_Statement
(Loc
,
1585 Name
=> New_Occurrence_Of
(Temp
, Loc
),
1586 Expression
=> Pref
));
1589 -- Mark the temporary as coming from a 'Old reference
1591 if Present
(Temp
) then
1592 Set_Stores_Attribute_Old_Prefix
(Temp
);
1595 -- Ensure that the prefix is valid
1597 if Validity_Checks_On
and then Validity_Check_Operands
then
1598 Ensure_Valid
(Pref
);
1601 -- Replace the original attribute 'Old by a reference to the
1602 -- generated temporary.
1607 (Temp
=> Temp
, Typ
=> Etype
(Pref
), Loc
=> Loc
));
1609 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
1612 -- Attribute 'Result
1614 elsif Is_Attribute_Result
(N
) then
1615 Rewrite
(N
, Make_Identifier
(Loc
, Name_uResult
));
1619 end Expand_Attributes
;
1621 procedure Expand_Attributes_In
is
1622 new Traverse_Proc
(Expand_Attributes
);
1624 -- Start of processing for Expand_Attributes_In_Consequence
1627 -- Inspect the consequence and expand any attribute 'Old and 'Result
1628 -- references found within.
1630 Expand_Attributes_In
(Conseq
);
1632 -- The consequence does not contain any attribute 'Old references
1634 if No
(Eval_Stmts
) then
1638 -- Augment the machinery to trigger the evaluation of all prefixes
1639 -- found in the step above. If Eval is empty, then this is the first
1640 -- consequence to yield expansion of 'Old. Generate:
1643 -- <evaluation statements>
1648 Make_Implicit_If_Statement
(CCs
,
1649 Condition
=> New_Occurrence_Of
(Flag
, Loc
),
1650 Then_Statements
=> Eval_Stmts
);
1652 Set_Comes_From_Check_Or_Contract
(Evals
);
1654 -- Otherwise generate:
1656 -- <evaluation statements>
1660 if No
(Elsif_Parts
(Evals
)) then
1661 Set_Elsif_Parts
(Evals
, New_List
);
1664 Append_To
(Elsif_Parts
(Evals
),
1665 Make_Elsif_Part
(Loc
,
1666 Condition
=> New_Occurrence_Of
(Flag
, Loc
),
1667 Then_Statements
=> Eval_Stmts
));
1669 end Expand_Attributes_In_Consequence
;
1675 function Increment
(Id
: Entity_Id
) return Node_Id
is
1678 Make_Assignment_Statement
(Loc
,
1679 Name
=> New_Occurrence_Of
(Id
, Loc
),
1682 Left_Opnd
=> New_Occurrence_Of
(Id
, Loc
),
1683 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
1690 function Set
(Id
: Entity_Id
) return Node_Id
is
1693 Make_Assignment_Statement
(Loc
,
1694 Name
=> New_Occurrence_Of
(Id
, Loc
),
1695 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
1700 Aggr
: constant Node_Id
:=
1701 Expression
(First
(Pragma_Argument_Associations
(CCs
)));
1703 Case_Guard
: Node_Id
;
1704 CG_Checks
: Node_Id
;
1707 Conseq_Checks
: Node_Id
:= Empty
;
1709 Count_Decl
: Node_Id
;
1710 Error_Decls
: List_Id
:= No_List
; -- init to avoid warning
1712 Flag_Decl
: Node_Id
;
1714 Msg_Str
: Entity_Id
:= Empty
;
1715 Multiple_PCs
: Boolean;
1716 Old_Evals
: Node_Id
:= Empty
;
1717 Others_Decl
: Node_Id
;
1718 Others_Flag
: Entity_Id
:= Empty
;
1719 Post_Case
: Node_Id
;
1721 -- Start of processing for Expand_Pragma_Contract_Cases
1724 -- Do nothing if pragma is not enabled. If pragma is disabled, it has
1725 -- already been rewritten as a Null statement.
1727 if Is_Ignored
(CCs
) then
1730 -- Guard against malformed contract cases
1732 elsif Nkind
(Aggr
) /= N_Aggregate
then
1736 -- The expansion of contract cases is quite distributed as it produces
1737 -- various statements to evaluate the case guards and consequences. To
1738 -- preserve the original context, set the Is_Assertion_Expr flag. This
1739 -- aids the Ghost legality checks when verifying the placement of a
1740 -- reference to a Ghost entity.
1742 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
1744 Multiple_PCs
:= List_Length
(Component_Associations
(Aggr
)) > 1;
1746 -- Create the counter which tracks the number of case guards that
1747 -- evaluate to True.
1749 -- Count : Natural := 0;
1751 Count
:= Make_Temporary
(Loc
, 'C');
1753 Make_Object_Declaration
(Loc
,
1754 Defining_Identifier
=> Count
,
1755 Object_Definition
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1756 Expression
=> Make_Integer_Literal
(Loc
, 0));
1758 Prepend_To
(Decls
, Count_Decl
);
1759 Analyze
(Count_Decl
);
1761 -- Create the base error message for multiple overlapping case guards
1763 -- Msg_Str : constant String :=
1764 -- "contract cases overlap for subprogram Subp_Id";
1766 if Multiple_PCs
then
1767 Msg_Str
:= Make_Temporary
(Loc
, 'S');
1770 Store_String_Chars
("contract cases overlap for subprogram ");
1771 Store_String_Chars
(Get_Name_String
(Chars
(Subp_Id
)));
1773 Error_Decls
:= New_List
(
1774 Make_Object_Declaration
(Loc
,
1775 Defining_Identifier
=> Msg_Str
,
1776 Constant_Present
=> True,
1777 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
1778 Expression
=> Make_String_Literal
(Loc
, End_String
)));
1781 -- Process individual post cases
1783 Post_Case
:= First
(Component_Associations
(Aggr
));
1784 while Present
(Post_Case
) loop
1785 Case_Guard
:= First
(Choices
(Post_Case
));
1786 Conseq
:= Expression
(Post_Case
);
1788 -- The "others" choice requires special processing
1790 if Nkind
(Case_Guard
) = N_Others_Choice
then
1791 Others_Flag
:= Make_Temporary
(Loc
, 'F');
1792 Others_Decl
:= Declaration_Of
(Others_Flag
);
1794 Prepend_To
(Decls
, Others_Decl
);
1795 Analyze
(Others_Decl
);
1797 -- Check possible overlap between a case guard and "others"
1799 if Multiple_PCs
and Exception_Extra_Info
then
1801 (Decls
=> Error_Decls
,
1802 Flag
=> Others_Flag
,
1803 Error_Loc
=> Sloc
(Case_Guard
),
1807 -- Inspect the consequence and perform special expansion of any
1808 -- attribute 'Old and 'Result references found within.
1810 Expand_Attributes_In_Consequence
1813 Flag
=> Others_Flag
,
1816 -- Check the corresponding consequence of "others"
1819 (Checks
=> Conseq_Checks
,
1820 Flag
=> Others_Flag
,
1823 -- Regular post case
1826 -- Create the flag which tracks the state of its associated case
1829 Flag
:= Make_Temporary
(Loc
, 'F');
1830 Flag_Decl
:= Declaration_Of
(Flag
);
1832 Prepend_To
(Decls
, Flag_Decl
);
1833 Analyze
(Flag_Decl
);
1835 -- The flag is set when the case guard is evaluated to True
1836 -- if Case_Guard then
1838 -- Count := Count + 1;
1842 Make_Implicit_If_Statement
(CCs
,
1843 Condition
=> Relocate_Node
(Case_Guard
),
1844 Then_Statements
=> New_List
(
1846 Increment
(Count
)));
1848 Set_Comes_From_Check_Or_Contract
(If_Stmt
);
1850 Append_To
(Decls
, If_Stmt
);
1853 -- Check whether this case guard overlaps with another one
1855 if Multiple_PCs
and Exception_Extra_Info
then
1857 (Decls
=> Error_Decls
,
1859 Error_Loc
=> Sloc
(Case_Guard
),
1863 -- Inspect the consequence and perform special expansion of any
1864 -- attribute 'Old and 'Result references found within.
1866 Expand_Attributes_In_Consequence
1872 -- The corresponding consequence of the case guard which evaluated
1873 -- to True must hold on exit from the subprogram.
1876 (Checks
=> Conseq_Checks
,
1884 -- Raise Assertion_Error when none of the case guards evaluate to True.
1885 -- The only exception is when we have "others", in which case there is
1886 -- no error because "others" acts as a default True.
1891 if Present
(Others_Flag
) then
1892 CG_Stmts
:= New_List
(Set
(Others_Flag
));
1895 -- raise Assertion_Error with "xxx contract cases incomplete";
1899 Store_String_Chars
(Build_Location_String
(Loc
));
1900 Store_String_Chars
(" contract cases incomplete");
1902 CG_Stmts
:= New_List
(
1903 Make_Procedure_Call_Statement
(Loc
,
1905 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
1906 Parameter_Associations
=> New_List
(
1907 Make_String_Literal
(Loc
, End_String
))));
1911 Make_Implicit_If_Statement
(CCs
,
1914 Left_Opnd
=> New_Occurrence_Of
(Count
, Loc
),
1915 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1916 Then_Statements
=> CG_Stmts
);
1918 Set_Comes_From_Check_Or_Contract
(CG_Checks
);
1920 -- Detect a possible failure due to several case guards evaluating to
1924 -- elsif Count > 0 then
1928 -- raise Assertion_Error with <Msg_Str>;
1931 if Multiple_PCs
then
1932 Set_Elsif_Parts
(CG_Checks
, New_List
(
1933 Make_Elsif_Part
(Loc
,
1936 Left_Opnd
=> New_Occurrence_Of
(Count
, Loc
),
1937 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)),
1939 Then_Statements
=> New_List
(
1940 Make_Block_Statement
(Loc
,
1941 Declarations
=> Error_Decls
,
1942 Handled_Statement_Sequence
=>
1943 Make_Handled_Sequence_Of_Statements
(Loc
,
1944 Statements
=> New_List
(
1945 Make_Procedure_Call_Statement
(Loc
,
1948 (RTE
(RE_Raise_Assert_Failure
), Loc
),
1949 Parameter_Associations
=> New_List
(
1950 New_Occurrence_Of
(Msg_Str
, Loc
))))))))));
1953 -- Append the checks, but do not analyze them at this point, because
1954 -- contracts get potentially expanded as part of a wrapper which gets
1955 -- fully analyzed once it is fully formed.
1957 Append_To
(Decls
, CG_Checks
);
1959 -- Once all case guards are evaluated and checked, evaluate any prefixes
1960 -- of attribute 'Old founds in the selected consequence.
1962 if Present
(Old_Evals
) then
1963 Append_To
(Decls
, Old_Evals
);
1966 -- Raise Assertion_Error when the corresponding consequence of a case
1967 -- guard that evaluated to True fails.
1969 Append_New_To
(Stmts
, Conseq_Checks
);
1971 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
1972 end Expand_Pragma_Contract_Cases
;
1974 ---------------------------------------
1975 -- Expand_Pragma_Import_Or_Interface --
1976 ---------------------------------------
1978 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
) is
1982 -- In Relaxed_RM_Semantics, support old Ada 83 style:
1983 -- pragma Import (Entity, "external name");
1985 if Relaxed_RM_Semantics
1986 and then List_Length
(Pragma_Argument_Associations
(N
)) = 2
1987 and then Pragma_Name
(N
) = Name_Import
1988 and then Nkind
(Arg_N
(N
, 2)) = N_String_Literal
1990 Def_Id
:= Entity
(Arg_N
(N
, 1));
1992 Def_Id
:= Entity
(Arg_N
(N
, 2));
1995 -- Variable case (we have to undo any initialization already done)
1997 if Ekind
(Def_Id
) = E_Variable
then
1998 Undo_Initialization
(Def_Id
, N
);
2000 -- Case of exception with convention C++
2002 elsif Ekind
(Def_Id
) = E_Exception
2003 and then Convention
(Def_Id
) = Convention_CPP
2005 -- Import a C++ convention
2008 Loc
: constant Source_Ptr
:= Sloc
(N
);
2009 Rtti_Name
: constant Node_Id
:= Arg_N
(N
, 3);
2010 Dum
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
2012 Lang_Char
: Node_Id
;
2013 Foreign_Data
: Node_Id
;
2016 Exdata
:= Component_Associations
(Expression
(Parent
(Def_Id
)));
2018 Lang_Char
:= Next
(First
(Exdata
));
2020 -- Change the one-character language designator to 'C'
2022 Rewrite
(Expression
(Lang_Char
),
2023 Make_Character_Literal
(Loc
,
2025 Char_Literal_Value
=> UI_From_CC
(Get_Char_Code
('C'))));
2026 Analyze
(Expression
(Lang_Char
));
2028 -- Change the value of Foreign_Data
2030 Foreign_Data
:= Next
(Next
(Next
(Next
(Lang_Char
))));
2032 Insert_Actions
(Def_Id
, New_List
(
2033 Make_Object_Declaration
(Loc
,
2034 Defining_Identifier
=> Dum
,
2035 Object_Definition
=>
2036 New_Occurrence_Of
(Standard_Character
, Loc
)),
2039 Chars
=> Name_Import
,
2040 Pragma_Argument_Associations
=> New_List
(
2041 Make_Pragma_Argument_Association
(Loc
,
2042 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
2044 Make_Pragma_Argument_Association
(Loc
,
2045 Expression
=> Make_Identifier
(Loc
, Chars
(Dum
))),
2047 Make_Pragma_Argument_Association
(Loc
,
2048 Chars
=> Name_External_Name
,
2049 Expression
=> Relocate_Node
(Rtti_Name
))))));
2051 Rewrite
(Expression
(Foreign_Data
),
2052 OK_Convert_To
(Standard_Address
,
2053 Make_Attribute_Reference
(Loc
,
2054 Prefix
=> Make_Identifier
(Loc
, Chars
(Dum
)),
2055 Attribute_Name
=> Name_Address
)));
2056 Analyze
(Expression
(Foreign_Data
));
2059 -- No special expansion required for any other case
2064 end Expand_Pragma_Import_Or_Interface
;
2066 -------------------------------------
2067 -- Expand_Pragma_Initial_Condition --
2068 -------------------------------------
2070 procedure Expand_Pragma_Initial_Condition
2071 (Pack_Id
: Entity_Id
;
2074 procedure Extract_Package_Body_Lists
2075 (Pack_Body
: Node_Id
;
2076 Body_List
: out List_Id
;
2077 Call_List
: out List_Id
;
2078 Spec_List
: out List_Id
);
2079 -- Obtain the various declarative and statement lists of package body
2080 -- Pack_Body needed to insert the initial condition procedure and the
2081 -- call to it. The lists are as follows:
2083 -- * Body_List - used to insert the initial condition procedure body
2085 -- * Call_List - used to insert the call to the initial condition
2088 -- * Spec_List - used to insert the initial condition procedure spec
2090 procedure Extract_Package_Declaration_Lists
2091 (Pack_Decl
: Node_Id
;
2092 Body_List
: out List_Id
;
2093 Call_List
: out List_Id
;
2094 Spec_List
: out List_Id
);
2095 -- Obtain the various declarative lists of package declaration Pack_Decl
2096 -- needed to insert the initial condition procedure and the call to it.
2097 -- The lists are as follows:
2099 -- * Body_List - used to insert the initial condition procedure body
2101 -- * Call_List - used to insert the call to the initial condition
2104 -- * Spec_List - used to insert the initial condition procedure spec
2106 --------------------------------
2107 -- Extract_Package_Body_Lists --
2108 --------------------------------
2110 procedure Extract_Package_Body_Lists
2111 (Pack_Body
: Node_Id
;
2112 Body_List
: out List_Id
;
2113 Call_List
: out List_Id
;
2114 Spec_List
: out List_Id
)
2116 Pack_Spec
: constant Entity_Id
:= Corresponding_Spec
(Pack_Body
);
2123 pragma Assert
(Present
(Pack_Spec
));
2125 -- The different parts of the invariant procedure are inserted as
2128 -- package Pack is package body Pack is
2129 -- <IC spec> <IC body>
2132 -- end Pack; end Pack;
2134 -- The initial condition procedure spec is inserted in the visible
2135 -- declaration of the corresponding package spec.
2137 Extract_Package_Declaration_Lists
2138 (Pack_Decl
=> Unit_Declaration_Node
(Pack_Spec
),
2139 Body_List
=> Dummy_1
,
2140 Call_List
=> Dummy_2
,
2141 Spec_List
=> Spec_List
);
2143 -- The initial condition procedure body is added to the declarations
2144 -- of the package body.
2146 Body_List
:= Declarations
(Pack_Body
);
2148 if No
(Body_List
) then
2149 Body_List
:= New_List
;
2150 Set_Declarations
(Pack_Body
, Body_List
);
2153 -- The call to the initial condition procedure is inserted in the
2154 -- statements of the package body.
2156 HSS
:= Handled_Statement_Sequence
(Pack_Body
);
2160 Make_Handled_Sequence_Of_Statements
(Sloc
(Pack_Body
),
2161 Statements
=> New_List
);
2162 Set_Handled_Statement_Sequence
(Pack_Body
, HSS
);
2165 Call_List
:= Statements
(HSS
);
2166 end Extract_Package_Body_Lists
;
2168 ---------------------------------------
2169 -- Extract_Package_Declaration_Lists --
2170 ---------------------------------------
2172 procedure Extract_Package_Declaration_Lists
2173 (Pack_Decl
: Node_Id
;
2174 Body_List
: out List_Id
;
2175 Call_List
: out List_Id
;
2176 Spec_List
: out List_Id
)
2178 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
2181 -- The different parts of the invariant procedure are inserted as
2191 -- The initial condition procedure spec and body are inserted in the
2192 -- visible declarations of the package spec.
2194 Body_List
:= Visible_Declarations
(Pack_Spec
);
2196 if No
(Body_List
) then
2197 Body_List
:= New_List
;
2198 Set_Visible_Declarations
(Pack_Spec
, Body_List
);
2201 Spec_List
:= Body_List
;
2203 -- The call to the initial procedure is inserted in the private
2204 -- declarations of the package spec.
2206 Call_List
:= Private_Declarations
(Pack_Spec
);
2208 if No
(Call_List
) then
2209 Call_List
:= New_List
;
2210 Set_Private_Declarations
(Pack_Spec
, Call_List
);
2212 end Extract_Package_Declaration_Lists
;
2216 IC_Prag
: constant Node_Id
:=
2217 Get_Pragma
(Pack_Id
, Pragma_Initial_Condition
);
2219 Body_List
: List_Id
;
2221 Call_List
: List_Id
;
2222 Call_Loc
: Source_Ptr
;
2225 Proc_Body
: Node_Id
;
2226 Proc_Body_Id
: Entity_Id
;
2227 Proc_Decl
: Node_Id
;
2228 Proc_Id
: Entity_Id
;
2229 Spec_List
: List_Id
;
2231 -- Start of processing for Expand_Pragma_Initial_Condition
2234 -- Nothing to do when the package is not subject to an Initial_Condition
2237 if No
(IC_Prag
) then
2241 Expr
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(IC_Prag
)));
2242 Loc
:= Sloc
(IC_Prag
);
2244 -- Nothing to do when the pragma is ignored because its semantics are
2247 if Is_Ignored
(IC_Prag
) then
2250 -- Nothing to do when the pragma or its argument are illegal because
2251 -- there is no valid expression to check.
2253 elsif Error_Posted
(IC_Prag
) or else Error_Posted
(Expr
) then
2257 -- Obtain the various lists of the context where the individual pieces
2258 -- of the initial condition procedure are to be inserted.
2260 if Nkind
(N
) = N_Package_Body
then
2261 Extract_Package_Body_Lists
2263 Body_List
=> Body_List
,
2264 Call_List
=> Call_List
,
2265 Spec_List
=> Spec_List
);
2267 elsif Nkind
(N
) = N_Package_Declaration
then
2268 Extract_Package_Declaration_Lists
2270 Body_List
=> Body_List
,
2271 Call_List
=> Call_List
,
2272 Spec_List
=> Spec_List
);
2274 -- This routine should not be used on anything other than packages
2277 pragma Assert
(False);
2282 Make_Defining_Identifier
(Loc
,
2283 Chars
=> New_External_Name
(Chars
(Pack_Id
), "Initial_Condition"));
2285 Mutate_Ekind
(Proc_Id
, E_Procedure
);
2286 Set_Is_Initial_Condition_Procedure
(Proc_Id
);
2289 -- procedure <Pack_Id>Initial_Condition;
2292 Make_Subprogram_Declaration
(Loc
,
2293 Make_Procedure_Specification
(Loc
,
2294 Defining_Unit_Name
=> Proc_Id
));
2296 Append_To
(Spec_List
, Proc_Decl
);
2298 -- The initial condition procedure requires debug info when initial
2299 -- condition is subject to Source Coverage Obligations.
2301 if Generate_SCO
then
2302 Set_Debug_Info_Needed
(Proc_Id
);
2306 -- procedure <Pack_Id>Initial_Condition is
2308 -- pragma Check (Initial_Condition, <Expr>);
2309 -- end <Pack_Id>Initial_Condition;
2312 Make_Subprogram_Body
(Loc
,
2314 Copy_Subprogram_Spec
(Specification
(Proc_Decl
)),
2315 Declarations
=> Empty_List
,
2316 Handled_Statement_Sequence
=>
2317 Make_Handled_Sequence_Of_Statements
(Loc
,
2318 Statements
=> New_List
(
2320 Chars
=> Name_Check
,
2321 Pragma_Argument_Associations
=> New_List
(
2322 Make_Pragma_Argument_Association
(Loc
,
2324 Make_Identifier
(Loc
, Name_Initial_Condition
)),
2325 Make_Pragma_Argument_Association
(Loc
,
2326 Expression
=> New_Copy_Tree
(Expr
)))))));
2328 Append_To
(Body_List
, Proc_Body
);
2330 -- The initial condition procedure requires debug info when initial
2331 -- condition is subject to Source Coverage Obligations.
2333 Proc_Body_Id
:= Defining_Entity
(Proc_Body
);
2335 if Generate_SCO
then
2336 Set_Debug_Info_Needed
(Proc_Body_Id
);
2339 -- The location of the initial condition procedure call must be as close
2340 -- as possible to the intended semantic location of the check because
2341 -- the ABE mechanism relies heavily on accurate locations.
2343 Call_Loc
:= End_Keyword_Location
(N
);
2346 -- <Pack_Id>Initial_Condition;
2349 Make_Procedure_Call_Statement
(Call_Loc
,
2350 Name
=> New_Occurrence_Of
(Proc_Id
, Call_Loc
));
2352 Append_To
(Call_List
, Call
);
2354 Analyze
(Proc_Decl
);
2355 Analyze
(Proc_Body
);
2357 end Expand_Pragma_Initial_Condition
;
2359 ------------------------------------
2360 -- Expand_Pragma_Inspection_Point --
2361 ------------------------------------
2363 -- If no argument is given, then we supply a default argument list that
2364 -- includes all objects declared at the source level in all subprograms
2365 -- that enclose the inspection point pragma.
2367 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
) is
2368 Loc
: constant Source_Ptr
:= Sloc
(N
);
2377 if No
(Pragma_Argument_Associations
(N
)) then
2381 while S
/= Standard_Standard
loop
2382 E
:= First_Entity
(S
);
2383 while Present
(E
) loop
2384 if Comes_From_Source
(E
)
2385 and then Is_Object
(E
)
2386 and then not Is_Entry_Formal
(E
)
2387 and then not Is_Formal_Object
(E
)
2388 and then Ekind
(E
) /= E_Component
2389 and then Ekind
(E
) /= E_Discriminant
2392 Make_Pragma_Argument_Association
(Loc
,
2393 Expression
=> New_Occurrence_Of
(E
, Loc
)));
2402 Set_Pragma_Argument_Associations
(N
, A
);
2405 -- Process the arguments of the pragma
2408 Assoc
:= First
(Pragma_Argument_Associations
(N
));
2409 while Present
(Assoc
) loop
2410 -- The back end may need to take the address of the object
2412 Set_Address_Taken
(Entity
(Expression
(Assoc
)));
2414 -- If any of the objects have a freeze node, it must appear before
2415 -- pragma Inspection_Point, otherwise the entity won't be elaborated
2416 -- when Gigi processes the pragma.
2418 if Has_Delayed_Freeze
(Entity
(Expression
(Assoc
)))
2419 and then not Is_Frozen
(Entity
(Expression
(Assoc
)))
2422 ("??inspection point references unfrozen object &",
2424 Entity
(Expression
(Assoc
)));
2431 -- When the above requirement isn't met, turn the pragma into a no-op
2434 Error_Msg_N
("\pragma will be ignored", N
);
2436 -- We can't just remove the pragma from the tree as it might be
2437 -- iterated over by the caller. Turn it into a null statement
2440 Rewrite
(N
, Make_Null_Statement
(Loc
));
2442 end Expand_Pragma_Inspection_Point
;
2444 --------------------------------------
2445 -- Expand_Pragma_Interrupt_Priority --
2446 --------------------------------------
2448 -- Supply default argument if none exists (System.Interrupt_Priority'Last)
2450 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
) is
2451 Loc
: constant Source_Ptr
:= Sloc
(N
);
2453 if No
(Pragma_Argument_Associations
(N
)) then
2454 Set_Pragma_Argument_Associations
(N
, New_List
(
2455 Make_Pragma_Argument_Association
(Loc
,
2457 Make_Attribute_Reference
(Loc
,
2459 New_Occurrence_Of
(RTE
(RE_Interrupt_Priority
), Loc
),
2460 Attribute_Name
=> Name_Last
))));
2462 end Expand_Pragma_Interrupt_Priority
;
2464 --------------------------------
2465 -- Expand_Pragma_Loop_Variant --
2466 --------------------------------
2468 -- Pragma Loop_Variant is expanded in the following manner:
2472 -- for | while ... loop
2473 -- <preceding source statements>
2474 -- pragma Loop_Variant
2475 -- (Increases => Incr_Expr,
2476 -- Decreases => Decr_Expr);
2477 -- <succeeding source statements>
2482 -- Curr_1 : <type of Incr_Expr>;
2483 -- Curr_2 : <type of Decr_Expr>;
2484 -- Old_1 : <type of Incr_Expr>;
2485 -- Old_2 : <type of Decr_Expr>;
2486 -- Flag : Boolean := False;
2488 -- for | while ... loop
2489 -- <preceding source statements>
2496 -- Curr_1 := <Incr_Expr>;
2497 -- Curr_2 := <Decr_Expr>;
2500 -- if Curr_1 /= Old_1 then
2501 -- pragma Check (Loop_Variant, Curr_1 > Old_1);
2503 -- pragma Check (Loop_Variant, Curr_2 < Old_2);
2509 -- <succeeding source statements>
2512 procedure Expand_Pragma_Loop_Variant
(N
: Node_Id
) is
2513 Loc
: constant Source_Ptr
:= Sloc
(N
);
2514 Last_Var
: constant Node_Id
:=
2515 Last
(Pragma_Argument_Associations
(N
));
2517 Curr_Assign
: List_Id
:= No_List
;
2518 Flag_Id
: Entity_Id
:= Empty
;
2519 If_Stmt
: Node_Id
:= Empty
;
2520 Old_Assign
: List_Id
:= No_List
;
2521 Loop_Scop
: Entity_Id
;
2522 Loop_Stmt
: Node_Id
;
2525 procedure Process_Variant
(Variant
: Node_Id
; Is_Last
: Boolean);
2526 -- Process a single increasing / decreasing termination variant. Flag
2527 -- Is_Last should be set when processing the last variant.
2529 ---------------------
2530 -- Process_Variant --
2531 ---------------------
2533 procedure Process_Variant
(Variant
: Node_Id
; Is_Last
: Boolean) is
2534 Expr
: constant Node_Id
:= Expression
(Variant
);
2535 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
2536 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2537 Loop_Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
2538 Curr_Id
: Entity_Id
;
2543 -- All temporaries generated in this routine must be inserted before
2544 -- the related loop statement. Ensure that the proper scope is on the
2545 -- stack when analyzing the temporaries. Note that we also use the
2546 -- Sloc of the related loop.
2548 Push_Scope
(Scope
(Loop_Scop
));
2550 -- Step 1: Create the declaration of the flag which controls the
2551 -- behavior of the assertion on the first iteration of the loop.
2553 if No
(Flag_Id
) then
2556 -- Flag : Boolean := False;
2558 Flag_Id
:= Make_Temporary
(Loop_Loc
, 'F');
2560 Insert_Action
(Loop_Stmt
,
2561 Make_Object_Declaration
(Loop_Loc
,
2562 Defining_Identifier
=> Flag_Id
,
2563 Object_Definition
=>
2564 New_Occurrence_Of
(Standard_Boolean
, Loop_Loc
),
2566 New_Occurrence_Of
(Standard_False
, Loop_Loc
)));
2568 -- Prevent an unwanted optimization where the Current_Value of
2569 -- the flag eliminates the if statement which stores the variant
2570 -- values coming from the previous iteration.
2572 -- Flag : Boolean := False;
2574 -- if Flag then -- condition rewritten to False
2575 -- Old_N := Curr_N; -- and if statement eliminated
2581 Set_Current_Value
(Flag_Id
, Empty
);
2584 -- Step 2: Create the temporaries which store the old and current
2585 -- values of the associated expression.
2588 -- Curr : <type of Expr>;
2590 Curr_Id
:= Make_Temporary
(Loc
, 'C');
2592 Insert_Action
(Loop_Stmt
,
2593 Make_Object_Declaration
(Loop_Loc
,
2594 Defining_Identifier
=> Curr_Id
,
2595 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loop_Loc
)));
2598 -- Old : <type of Expr>;
2600 Old_Id
:= Make_Temporary
(Loc
, 'P');
2602 Insert_Action
(Loop_Stmt
,
2603 Make_Object_Declaration
(Loop_Loc
,
2604 Defining_Identifier
=> Old_Id
,
2605 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loop_Loc
)));
2607 -- Restore original scope after all temporaries have been analyzed
2611 -- Step 3: Store value of the expression from the previous iteration
2616 Append_New_To
(Old_Assign
,
2617 Make_Assignment_Statement
(Loc
,
2618 Name
=> New_Occurrence_Of
(Old_Id
, Loc
),
2619 Expression
=> New_Occurrence_Of
(Curr_Id
, Loc
)));
2621 -- Step 4: Store the current value of the expression
2626 Append_New_To
(Curr_Assign
,
2627 Make_Assignment_Statement
(Loc
,
2628 Name
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2629 Expression
=> Relocate_Node
(Expr
)));
2631 -- Step 5: Create corresponding assertion to verify change of value
2634 -- pragma Check (Loop_Variant, Curr <|> Old);
2638 Chars
=> Name_Check
,
2639 Pragma_Argument_Associations
=> New_List
(
2640 Make_Pragma_Argument_Association
(Loc
,
2641 Expression
=> Make_Identifier
(Loc
, Name_Loop_Variant
)),
2642 Make_Pragma_Argument_Association
(Loc
,
2644 Make_Variant_Comparison
(Loc
,
2645 Mode
=> Chars
(Variant
),
2647 Curr_Val
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2648 Old_Val
=> New_Occurrence_Of
(Old_Id
, Loc
)))));
2651 -- if Curr /= Old then
2654 if No
(If_Stmt
) then
2656 -- When there is just one termination variant, do not compare the
2657 -- old and current value for equality, just check the pragma.
2663 Make_If_Statement
(Loc
,
2666 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2667 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
2668 Then_Statements
=> New_List
(Prag
));
2677 Set_Else_Statements
(If_Stmt
, New_List
(Prag
));
2680 -- elsif Curr /= Old then
2684 if Elsif_Parts
(If_Stmt
) = No_List
then
2685 Set_Elsif_Parts
(If_Stmt
, New_List
);
2688 Append_To
(Elsif_Parts
(If_Stmt
),
2689 Make_Elsif_Part
(Loc
,
2692 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2693 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
2694 Then_Statements
=> New_List
(Prag
)));
2696 end Process_Variant
;
2698 -- Start of processing for Expand_Pragma_Loop_Variant
2701 -- If pragma is not enabled, rewrite as Null statement. If pragma is
2702 -- disabled, it has already been rewritten as a Null statement.
2704 -- Likewise, ignore structural variants for execution.
2706 -- Also do this in CodePeer mode, because the expanded code is too
2707 -- complicated for CodePeer to analyse.
2710 or else Chars
(Last_Var
) = Name_Structural
2711 or else CodePeer_Mode
2713 Rewrite
(N
, Make_Null_Statement
(Loc
));
2718 -- The expansion of Loop_Variant is quite distributed as it produces
2719 -- various statements to capture and compare the arguments. To preserve
2720 -- the original context, set the Is_Assertion_Expr flag. This aids the
2721 -- Ghost legality checks when verifying the placement of a reference to
2724 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
2726 -- Locate the enclosing loop for which this assertion applies. In the
2727 -- case of Ada 2012 array iteration, we might be dealing with nested
2728 -- loops. Only the outermost loop has an identifier.
2731 while Present
(Loop_Stmt
) loop
2732 if Nkind
(Loop_Stmt
) = N_Loop_Statement
2733 and then Present
(Identifier
(Loop_Stmt
))
2738 Loop_Stmt
:= Parent
(Loop_Stmt
);
2741 Loop_Scop
:= Entity
(Identifier
(Loop_Stmt
));
2743 -- Create the circuitry which verifies individual variants
2745 Variant
:= First
(Pragma_Argument_Associations
(N
));
2746 while Present
(Variant
) loop
2747 Process_Variant
(Variant
, Is_Last
=> Variant
= Last_Var
);
2751 -- Construct the segment which stores the old values of all expressions.
2758 Make_If_Statement
(Loc
,
2759 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
2760 Then_Statements
=> Old_Assign
));
2762 -- Update the values of all expressions
2764 Insert_Actions
(N
, Curr_Assign
);
2766 -- Add the assertion circuitry to test all changes in expressions.
2775 Make_If_Statement
(Loc
,
2776 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
2777 Then_Statements
=> New_List
(If_Stmt
),
2778 Else_Statements
=> New_List
(
2779 Make_Assignment_Statement
(Loc
,
2780 Name
=> New_Occurrence_Of
(Flag_Id
, Loc
),
2781 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
2783 -- Note: the pragma has been completely transformed into a sequence of
2784 -- corresponding declarations and statements. We leave it in the tree
2785 -- for documentation purposes. It will be ignored by the backend.
2787 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
2788 end Expand_Pragma_Loop_Variant
;
2790 --------------------------------
2791 -- Expand_Pragma_Psect_Object --
2792 --------------------------------
2794 -- Convert to Common_Object, and expand the resulting pragma
2796 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
)
2797 renames Expand_Pragma_Common_Object
;
2799 -------------------------------------
2800 -- Expand_Pragma_Relative_Deadline --
2801 -------------------------------------
2803 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
) is
2804 P
: constant Node_Id
:= Parent
(N
);
2805 Loc
: constant Source_Ptr
:= Sloc
(N
);
2808 -- Expand the pragma only in the case of the main subprogram. For tasks
2809 -- the expansion is done in exp_ch9. Generate a call to Set_Deadline
2810 -- at Clock plus the relative deadline specified in the pragma. Time
2811 -- values are translated into Duration to allow for non-private
2812 -- addition operation.
2814 if Nkind
(P
) = N_Subprogram_Body
then
2817 Make_Procedure_Call_Statement
(Loc
,
2818 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Deadline
), Loc
),
2819 Parameter_Associations
=> New_List
(
2820 Unchecked_Convert_To
(RTE
(RO_RT_Time
),
2823 Make_Function_Call
(Loc
,
2824 New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
2827 (Loc
, New_Occurrence_Of
(RTE
(RE_Clock
), Loc
)))),
2829 Unchecked_Convert_To
(
2835 end Expand_Pragma_Relative_Deadline
;
2837 --------------------------------------
2838 -- Expand_Pragma_Subprogram_Variant --
2839 --------------------------------------
2841 -- Aspect Subprogram_Variant is expanded in the following manner:
2845 -- procedure Proc (Param : T) with
2846 -- with Variant (Increases => Incr_Expr,
2847 -- Decreases => Decr_Expr)
2850 -- <source statements>
2851 -- Proc (New_Param_Value);
2856 -- procedure Proc (Param : T) is
2857 -- Old_Incr : constant <type of Incr_Expr> := <Incr_Expr>;
2858 -- Old_Decr : constant <type of Decr_Expr> := <Decr_Expr> ;
2860 -- procedure Variants (Param : T);
2862 -- procedure Variants (Param : T) is
2863 -- Curr_Incr : constant <type of Incr_Expr> := <Incr_Expr>;
2864 -- Curr_Decr : constant <type of Decr_Expr> := <Decr_Expr>;
2866 -- if Curr_Incr /= Old_Incr then
2867 -- pragma Check (Variant, Curr_Incr > Old_Incr);
2869 -- pragma Check (Variant, Curr_Decr < Old_Decr);
2875 -- <source statements>
2876 -- Variants (New_Param_Value);
2877 -- Proc (New_Param_Value);
2880 procedure Expand_Pragma_Subprogram_Variant
2882 Subp_Id
: Entity_Id
;
2883 Body_Decls
: List_Id
)
2885 Curr_Decls
: List_Id
;
2886 If_Stmt
: Node_Id
:= Empty
;
2888 function Formal_Param_Map
2889 (Old_Subp
: Entity_Id
;
2890 New_Subp
: Entity_Id
) return Elist_Id
;
2891 -- Given two subprogram entities Old_Subp and New_Subp with the same
2892 -- number of formal parameters return a list of the form:
2900 -- as required by New_Copy_Tree to replace references to formal
2901 -- parameters of Old_Subp with references to formal parameters of
2904 procedure Process_Variant
2906 Formal_Map
: Elist_Id
;
2907 Prev_Decl
: in out Node_Id
;
2909 -- Process a single increasing / decreasing termination variant given by
2910 -- a component association Variant. Formal_Map is a list of formal
2911 -- parameters of the annotated subprogram and of the internal procedure
2912 -- that verifies the variant in the format required by New_Copy_Tree.
2913 -- The Old_... object created by this routine will be appended after
2914 -- Prev_Decl and is stored in this parameter for a next call to this
2915 -- routine. Is_Last is True when there are no more variants to process.
2917 ----------------------
2918 -- Formal_Param_Map --
2919 ----------------------
2921 function Formal_Param_Map
2922 (Old_Subp
: Entity_Id
;
2923 New_Subp
: Entity_Id
) return Elist_Id
2925 Old_Formal
: Entity_Id
:= First_Formal
(Old_Subp
);
2926 New_Formal
: Entity_Id
:= First_Formal
(New_Subp
);
2928 Param_Map
: Elist_Id
;
2930 if Present
(Old_Formal
) then
2931 Param_Map
:= New_Elmt_List
;
2932 while Present
(Old_Formal
) and then Present
(New_Formal
) loop
2933 Append_Elmt
(Old_Formal
, Param_Map
);
2934 Append_Elmt
(New_Formal
, Param_Map
);
2936 Next_Formal
(Old_Formal
);
2937 Next_Formal
(New_Formal
);
2944 end Formal_Param_Map
;
2946 ---------------------
2947 -- Process_Variant --
2948 ---------------------
2950 procedure Process_Variant
2952 Formal_Map
: Elist_Id
;
2953 Prev_Decl
: in out Node_Id
;
2956 Expr
: constant Node_Id
:= Expression
(Variant
);
2957 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
2958 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2962 Curr_Id
: Entity_Id
;
2963 Curr_Decl
: Node_Id
;
2967 -- Create temporaries that store the old values of the associated
2971 -- Old : constant <type of Expr> := <Expr>;
2973 Old_Id
:= Make_Temporary
(Loc
, 'P');
2976 Make_Object_Declaration
(Loc
,
2977 Defining_Identifier
=> Old_Id
,
2978 Constant_Present
=> True,
2979 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loc
),
2980 Expression
=> New_Copy_Tree
(Expr
));
2982 Insert_After_And_Analyze
(Prev_Decl
, Old_Decl
);
2984 Prev_Decl
:= Old_Decl
;
2987 -- Curr : constant <type of Expr> := <Expr>;
2989 Curr_Id
:= Make_Temporary
(Loc
, 'C');
2992 Make_Object_Declaration
(Loc
,
2993 Defining_Identifier
=> Curr_Id
,
2994 Constant_Present
=> True,
2995 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loc
),
2997 New_Copy_Tree
(Expr
, Map
=> Formal_Map
));
2999 Append
(Curr_Decl
, Curr_Decls
);
3002 -- pragma Check (Variant, Curr <|> Old);
3006 Chars
=> Name_Check
,
3007 Pragma_Argument_Associations
=> New_List
(
3008 Make_Pragma_Argument_Association
(Loc
,
3010 Make_Identifier
(Loc
,
3011 Name_Subprogram_Variant
)),
3012 Make_Pragma_Argument_Association
(Loc
,
3014 Make_Variant_Comparison
(Loc
,
3015 Mode
=> Chars
(First
(Choices
(Variant
))),
3017 Curr_Val
=> New_Occurrence_Of
(Curr_Id
, Loc
),
3018 Old_Val
=> New_Occurrence_Of
(Old_Id
, Loc
)))));
3021 -- if Curr /= Old then
3024 if No
(If_Stmt
) then
3026 -- When there is just one termination variant, do not compare
3027 -- the old and current value for equality, just check the
3034 Make_If_Statement
(Loc
,
3037 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
3038 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
3039 Then_Statements
=> New_List
(Prag
));
3048 Set_Else_Statements
(If_Stmt
, New_List
(Prag
));
3051 -- elsif Curr /= Old then
3055 if Elsif_Parts
(If_Stmt
) = No_List
then
3056 Set_Elsif_Parts
(If_Stmt
, New_List
);
3059 Append_To
(Elsif_Parts
(If_Stmt
),
3060 Make_Elsif_Part
(Loc
,
3063 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
3064 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
3065 Then_Statements
=> New_List
(Prag
)));
3067 end Process_Variant
;
3071 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
3073 Aggr
: constant Node_Id
:=
3074 Expression
(First
(Pragma_Argument_Associations
(Prag
)));
3075 Formal_Map
: Elist_Id
;
3077 Last_Variant
: constant Node_Id
:=
3078 Nlists
.Last
(Component_Associations
(Aggr
));
3080 Proc_Decl
: Node_Id
;
3081 Proc_Id
: Entity_Id
;
3082 Proc_Spec
: Node_Id
;
3086 -- Do nothing if pragma is not present or is disabled.
3087 -- Also ignore structural variants for execution.
3089 if Is_Ignored
(Prag
)
3090 or else Chars
(Nlists
.Last
(Choices
(Last_Variant
))) = Name_Structural
3095 -- The expansion of Subprogram Variant is quite distributed as it
3096 -- produces various statements to capture and compare the arguments.
3097 -- To preserve the original context, set the Is_Assertion_Expr flag.
3098 -- This aids the Ghost legality checks when verifying the placement
3099 -- of a reference to a Ghost entity.
3101 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
3103 -- Create declaration of the procedure that compares values of the
3104 -- variant expressions captured at the start of subprogram with their
3105 -- values at the recursive call of the subprogram.
3107 Proc_Id
:= Make_Defining_Identifier
(Loc
, Name_uVariants
);
3110 Make_Procedure_Specification
3112 Defining_Unit_Name
=> Proc_Id
,
3113 Parameter_Specifications
=> Copy_Parameter_List
(Subp_Id
));
3116 Make_Subprogram_Declaration
(Loc
, Proc_Spec
);
3118 Insert_Before_First_Source_Declaration
(Proc_Decl
, Body_Decls
);
3119 Analyze
(Proc_Decl
);
3121 -- Create a mapping between formals of the annotated subprogram (which
3122 -- are used to compute values of the variant expression at the start of
3123 -- subprogram) and formals of the internal procedure (which are used to
3124 -- compute values of of the variant expression at the recursive call).
3127 Formal_Param_Map
(Old_Subp
=> Subp_Id
, New_Subp
=> Proc_Id
);
3129 -- Process invidual increasing / decreasing variants
3132 Curr_Decls
:= New_List
;
3134 Variant
:= First
(Component_Associations
(Aggr
));
3135 while Present
(Variant
) loop
3137 (Variant
=> Variant
,
3138 Formal_Map
=> Formal_Map
,
3140 Is_Last
=> Variant
= Last_Variant
);
3144 -- Create a subprogram body with declarations of objects that capture
3145 -- the current values of variant expressions at a recursive call and an
3146 -- if-then-else statement that compares current with old values.
3149 Make_Subprogram_Body
(Loc
,
3151 Copy_Subprogram_Spec
(Proc_Spec
),
3152 Declarations
=> Curr_Decls
,
3153 Handled_Statement_Sequence
=>
3154 Make_Handled_Sequence_Of_Statements
(Loc
,
3155 Statements
=> New_List
(If_Stmt
),
3156 End_Label
=> Make_Identifier
(Loc
, Chars
(Proc_Id
))));
3158 Insert_After_And_Analyze
(Last
, Proc_Bod
);
3160 -- Restore assertion context
3162 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
3164 -- Rewrite the aspect expression, which is no longer needed, with
3165 -- a reference to the procedure that has just been created. We will
3166 -- generate a call to this procedure at each recursive call of the
3167 -- subprogram that has been annotated with Subprogram_Variant.
3169 Rewrite
(Aggr
, New_Occurrence_Of
(Proc_Id
, Loc
));
3170 end Expand_Pragma_Subprogram_Variant
;
3172 -------------------------------------------
3173 -- Expand_Pragma_Suppress_Initialization --
3174 -------------------------------------------
3176 procedure Expand_Pragma_Suppress_Initialization
(N
: Node_Id
) is
3177 Def_Id
: constant Entity_Id
:= Entity
(Arg_N
(N
, 1));
3180 -- Variable case (we have to undo any initialization already done)
3182 if Ekind
(Def_Id
) = E_Variable
then
3183 Undo_Initialization
(Def_Id
, N
);
3185 end Expand_Pragma_Suppress_Initialization
;
3187 -------------------------
3188 -- Undo_Initialization --
3189 -------------------------
3191 procedure Undo_Initialization
(Def_Id
: Entity_Id
; N
: Node_Id
) is
3192 Init_Call
: Node_Id
;
3195 -- When applied to a variable, the default initialization must not be
3196 -- done. As it is already done when the pragma is found, we just get rid
3197 -- of the call to the initialization procedure which followed the object
3198 -- declaration. The call is inserted after the declaration, but validity
3199 -- checks may also have been inserted and thus the initialization call
3200 -- does not necessarily appear immediately after the object declaration.
3202 -- We can't use the freezing mechanism for this purpose, since we have
3203 -- to elaborate the initialization expression when it is first seen (so
3204 -- this elaboration cannot be deferred to the freeze point).
3206 -- Find and remove generated initialization call for object, if any
3208 Init_Call
:= Remove_Init_Call
(Def_Id
, Rep_Clause
=> N
);
3210 -- Any default initialization expression should be removed (e.g.
3211 -- null defaults for access objects, zero initialization of packed
3212 -- bit arrays). Imported objects aren't allowed to have explicit
3213 -- initialization, so the expression must have been generated by
3216 if No
(Init_Call
) and then Present
(Expression
(Parent
(Def_Id
))) then
3217 Set_Expression
(Parent
(Def_Id
), Empty
);
3220 -- The object may not have any initialization, but in the presence of
3221 -- Initialize_Scalars code is inserted after then declaration, which
3222 -- must now be removed as well. The code carries the same source
3223 -- location as the declaration itself.
3225 if Initialize_Scalars
and then Is_Array_Type
(Etype
(Def_Id
)) then
3230 Init
:= Next
(Parent
(Def_Id
));
3231 while not Comes_From_Source
(Init
)
3232 and then Sloc
(Init
) = Sloc
(Def_Id
)
3240 end Undo_Initialization
;