1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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 Errout
; use Errout
;
32 with Exp_Ch11
; use Exp_Ch11
;
33 with Exp_Util
; use Exp_Util
;
34 with Expander
; use Expander
;
35 with Ghost
; use Ghost
;
36 with Inline
; use Inline
;
37 with Namet
; use Namet
;
38 with Nlists
; use Nlists
;
39 with Nmake
; use Nmake
;
41 with Restrict
; use Restrict
;
42 with Rident
; use Rident
;
43 with Rtsfind
; use Rtsfind
;
45 with Sem_Ch8
; use Sem_Ch8
;
46 with Sem_Util
; use Sem_Util
;
47 with Sinfo
; use Sinfo
;
48 with Sinput
; use Sinput
;
49 with Snames
; use Snames
;
50 with Stringt
; use Stringt
;
51 with Stand
; use Stand
;
52 with Tbuild
; use Tbuild
;
53 with Uintp
; use Uintp
;
54 with Validsw
; use Validsw
;
56 package body Exp_Prag
is
58 -----------------------
59 -- Local Subprograms --
60 -----------------------
62 function Arg1
(N
: Node_Id
) return Node_Id
;
63 function Arg2
(N
: Node_Id
) return Node_Id
;
64 function Arg3
(N
: Node_Id
) return Node_Id
;
65 -- Obtain specified pragma argument expression
67 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
);
68 procedure Expand_Pragma_Check
(N
: Node_Id
);
69 procedure Expand_Pragma_Common_Object
(N
: Node_Id
);
70 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
);
71 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
);
72 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
);
73 procedure Expand_Pragma_Loop_Variant
(N
: Node_Id
);
74 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
);
75 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
);
76 procedure Expand_Pragma_Suppress_Initialization
(N
: Node_Id
);
78 procedure Undo_Initialization
(Def_Id
: Entity_Id
; N
: Node_Id
);
79 -- This procedure is used to undo initialization already done for Def_Id,
80 -- which is always an E_Variable, in response to the occurrence of the
81 -- pragma N, a pragma Interface, Import, or Suppress_Initialization. In all
82 -- these cases we want no initialization to occur, but we have already done
83 -- the initialization by the time we see the pragma, so we have to undo it.
89 function Arg1
(N
: Node_Id
) return Node_Id
is
90 Arg
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
93 and then Nkind
(Arg
) = N_Pragma_Argument_Association
95 return Expression
(Arg
);
105 function Arg2
(N
: Node_Id
) return Node_Id
is
106 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
114 Arg
: constant Node_Id
:= Next
(Arg1
);
117 and then Nkind
(Arg
) = N_Pragma_Argument_Association
119 return Expression
(Arg
);
131 function Arg3
(N
: Node_Id
) return Node_Id
is
132 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
140 Arg
: Node_Id
:= Next
(Arg1
);
149 and then Nkind
(Arg
) = N_Pragma_Argument_Association
151 return Expression
(Arg
);
160 ---------------------
161 -- Expand_N_Pragma --
162 ---------------------
164 procedure Expand_N_Pragma
(N
: Node_Id
) is
165 Pname
: constant Name_Id
:= Pragma_Name
(N
);
168 -- Rewrite pragma ignored by Ignore_Pragma to null statement, so that
169 -- the back end or the expander here does not get overenthusiastic and
170 -- start processing such a pragma!
172 if Get_Name_Table_Boolean3
(Pname
) then
173 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
177 -- Note: we may have a pragma whose Pragma_Identifier field is not a
178 -- recognized pragma, and we must ignore it at this stage.
180 if Is_Pragma_Name
(Pname
) then
181 case Get_Pragma_Id
(Pname
) is
183 -- Pragmas requiring special expander action
185 when Pragma_Abort_Defer
=>
186 Expand_Pragma_Abort_Defer
(N
);
189 Expand_Pragma_Check
(N
);
191 when Pragma_Common_Object
=>
192 Expand_Pragma_Common_Object
(N
);
194 when Pragma_Import
=>
195 Expand_Pragma_Import_Or_Interface
(N
);
197 when Pragma_Inspection_Point
=>
198 Expand_Pragma_Inspection_Point
(N
);
200 when Pragma_Interface
=>
201 Expand_Pragma_Import_Or_Interface
(N
);
203 when Pragma_Interrupt_Priority
=>
204 Expand_Pragma_Interrupt_Priority
(N
);
206 when Pragma_Loop_Variant
=>
207 Expand_Pragma_Loop_Variant
(N
);
209 when Pragma_Psect_Object
=>
210 Expand_Pragma_Psect_Object
(N
);
212 when Pragma_Relative_Deadline
=>
213 Expand_Pragma_Relative_Deadline
(N
);
215 when Pragma_Suppress_Initialization
=>
216 Expand_Pragma_Suppress_Initialization
(N
);
218 -- All other pragmas need no expander action
226 -------------------------------
227 -- Expand_Pragma_Abort_Defer --
228 -------------------------------
230 -- An Abort_Defer pragma appears as the first statement in a handled
231 -- statement sequence (right after the begin). It defers aborts for
232 -- the entire statement sequence, but not for any declarations or
233 -- handlers (if any) associated with this statement sequence.
235 -- The transformation is to transform
237 -- pragma Abort_Defer;
246 -- when all others =>
247 -- Abort_Undefer.all;
250 -- Abort_Undefer_Direct;
253 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
) is
255 -- Abort_Defer has no useful effect if Abort's are not allowed
257 if not Abort_Allowed
then
261 -- Normal case where abort is possible
264 Loc
: constant Source_Ptr
:= Sloc
(N
);
268 Blk
: constant Entity_Id
:=
269 New_Internal_Entity
(E_Block
, Current_Scope
, Sloc
(N
), 'B');
270 AUD
: constant Entity_Id
:= RTE
(RE_Abort_Undefer_Direct
);
273 Stms
:= New_List
(Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
275 Stm
:= Remove_Next
(N
);
281 Make_Handled_Sequence_Of_Statements
(Loc
,
283 At_End_Proc
=> New_Occurrence_Of
(AUD
, Loc
));
285 -- Present the Abort_Undefer_Direct function to the backend so that
286 -- it can inline the call to the function.
288 Add_Inlined_Body
(AUD
, N
);
291 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
));
293 Set_Scope
(Blk
, Current_Scope
);
294 Set_Etype
(Blk
, Standard_Void_Type
);
295 Set_Identifier
(N
, New_Occurrence_Of
(Blk
, Sloc
(N
)));
296 Expand_At_End_Handler
(HSS
, Blk
);
299 end Expand_Pragma_Abort_Defer
;
301 --------------------------
302 -- Expand_Pragma_Check --
303 --------------------------
305 procedure Expand_Pragma_Check
(N
: Node_Id
) is
306 Cond
: constant Node_Id
:= Arg2
(N
);
307 Nam
: constant Name_Id
:= Chars
(Arg1
(N
));
310 Loc
: constant Source_Ptr
:= Sloc
(First_Node
(Cond
));
311 -- Source location used in the case of a failed assertion: point to the
312 -- failing condition, not Loc. Note that the source location of the
313 -- expression is not usually the best choice here, because it points to
314 -- the location of the topmost tree node, which may be an operator in
315 -- the middle of the source text of the expression. For example, it gets
316 -- located on the last AND keyword in a chain of boolean expressiond
317 -- AND'ed together. It is best to put the message on the first character
318 -- of the condition, which is the effect of the First_Node call here.
319 -- This source location is used to build the default exception message,
320 -- and also as the sloc of the call to the runtime subprogram raising
321 -- Assert_Failure, so that coverage analysis tools can relate the
322 -- call to the failed check.
324 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
327 -- Nothing to do if pragma is ignored
329 if Is_Ignored
(N
) then
333 -- Pragmas Assert, Assert_And_Cut, Assume, Check and Loop_Invariant are
334 -- Ghost when they apply to a Ghost entity. Set the mode now to ensure
335 -- that any nodes generated during expansion are properly flagged as
340 -- Since this check is active, we rewrite the pragma into a
341 -- corresponding if statement, and then analyze the statement.
343 -- The normal case expansion transforms:
345 -- pragma Check (name, condition [,message]);
349 -- if not condition then
350 -- System.Assertions.Raise_Assert_Failure (Str);
353 -- where Str is the message if one is present, or the default of
354 -- name failed at file:line if no message is given (the "name failed
355 -- at" is omitted for name = Assertion, since it is redundant, given
356 -- that the name of the exception is Assert_Failure.)
358 -- Also, instead of "XXX failed at", we generate slightly
359 -- different messages for some of the contract assertions (see
360 -- code below for details).
362 -- An alternative expansion is used when the No_Exception_Propagation
363 -- restriction is active and there is a local Assert_Failure handler.
364 -- This is not a common combination of circumstances, but it occurs in
365 -- the context of Aunit and the zero footprint profile. In this case we
368 -- if not condition then
369 -- raise Assert_Failure;
372 -- This will then be transformed into a goto, and the local handler will
373 -- be able to handle the assert error (which would not be the case if a
374 -- call is made to the Raise_Assert_Failure procedure).
376 -- We also generate the direct raise if the Suppress_Exception_Locations
377 -- is active, since we don't want to generate messages in this case.
379 -- Note that the reason we do not always generate a direct raise is that
380 -- the form in which the procedure is called allows for more efficient
381 -- breakpointing of assertion errors.
383 -- Generate the appropriate if statement. Note that we consider this to
384 -- be an explicit conditional in the source, not an implicit if, so we
385 -- do not call Make_Implicit_If_Statement.
387 -- Case where we generate a direct raise
389 if ((Debug_Flag_Dot_G
390 or else Restriction_Active
(No_Exception_Propagation
))
391 and then Present
(Find_Local_Handler
(RTE
(RE_Assert_Failure
), N
)))
392 or else (Opt
.Exception_Locations_Suppressed
and then No
(Arg3
(N
)))
395 Make_If_Statement
(Loc
,
396 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Cond
),
397 Then_Statements
=> New_List
(
398 Make_Raise_Statement
(Loc
,
399 Name
=> New_Occurrence_Of
(RTE
(RE_Assert_Failure
), Loc
)))));
401 -- Case where we call the procedure
404 -- If we have a message given, use it
406 if Present
(Arg3
(N
)) then
407 Msg
:= Get_Pragma_Arg
(Arg3
(N
));
409 -- Here we have no string, so prepare one
413 Loc_Str
: constant String := Build_Location_String
(Loc
);
418 -- For Assert, we just use the location
420 if Nam
= Name_Assert
then
423 -- For predicate, we generate the string "predicate failed at
424 -- yyy". We prefer all lower case for predicate.
426 elsif Nam
= Name_Predicate
then
427 Add_Str_To_Name_Buffer
("predicate failed at ");
429 -- For special case of Precondition/Postcondition the string is
430 -- "failed xx from yy" where xx is precondition/postcondition
431 -- in all lower case. The reason for this different wording is
432 -- that the failure is not at the point of occurrence of the
433 -- pragma, unlike the other Check cases.
435 elsif Nam_In
(Nam
, Name_Precondition
, Name_Postcondition
) then
436 Get_Name_String
(Nam
);
437 Insert_Str_In_Name_Buffer
("failed ", 1);
438 Add_Str_To_Name_Buffer
(" from ");
440 -- For special case of Invariant, the string is "failed
441 -- invariant from yy", to be consistent with the string that is
442 -- generated for the aspect case (the code later on checks for
443 -- this specific string to modify it in some cases, so this is
444 -- functionally important).
446 elsif Nam
= Name_Invariant
then
447 Add_Str_To_Name_Buffer
("failed invariant from ");
449 -- For all other checks, the string is "xxx failed at yyy"
450 -- where xxx is the check name with current source file casing.
453 Get_Name_String
(Nam
);
454 Set_Casing
(Identifier_Casing
(Current_Source_File
));
455 Add_Str_To_Name_Buffer
(" failed at ");
458 -- In all cases, add location string
460 Add_Str_To_Name_Buffer
(Loc_Str
);
464 Msg
:= Make_String_Literal
(Loc
, Name_Buffer
(1 .. Name_Len
));
468 -- Now rewrite as an if statement
471 Make_If_Statement
(Loc
,
472 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Cond
),
473 Then_Statements
=> New_List
(
474 Make_Procedure_Call_Statement
(Loc
,
476 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
477 Parameter_Associations
=> New_List
(Relocate_Node
(Msg
))))));
482 -- If new condition is always false, give a warning
484 if Warn_On_Assertion_Failure
485 and then Nkind
(N
) = N_Procedure_Call_Statement
486 and then Is_RTE
(Entity
(Name
(N
)), RE_Raise_Assert_Failure
)
488 -- If original condition was a Standard.False, we assume that this is
489 -- indeed intended to raise assert error and no warning is required.
491 if Is_Entity_Name
(Original_Node
(Cond
))
492 and then Entity
(Original_Node
(Cond
)) = Standard_False
496 elsif Nam
= Name_Assert
then
497 Error_Msg_N
("?A?assertion will fail at run time", N
);
500 Error_Msg_N
("?A?check will fail at run time", N
);
504 Ghost_Mode
:= Save_Ghost_Mode
;
505 end Expand_Pragma_Check
;
507 ---------------------------------
508 -- Expand_Pragma_Common_Object --
509 ---------------------------------
511 -- Use a machine attribute to replicate semantic effect in DEC Ada
513 -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
515 -- For now we do nothing with the size attribute ???
517 -- Note: Psect_Object shares this processing
519 procedure Expand_Pragma_Common_Object
(N
: Node_Id
) is
520 Loc
: constant Source_Ptr
:= Sloc
(N
);
522 Internal
: constant Node_Id
:= Arg1
(N
);
523 External
: constant Node_Id
:= Arg2
(N
);
526 -- Psect value upper cased as string literal
528 Iloc
: constant Source_Ptr
:= Sloc
(Internal
);
529 Eloc
: constant Source_Ptr
:= Sloc
(External
);
533 -- Acquire Psect value and fold to upper case
535 if Present
(External
) then
536 if Nkind
(External
) = N_String_Literal
then
537 String_To_Name_Buffer
(Strval
(External
));
539 Get_Name_String
(Chars
(External
));
545 Make_String_Literal
(Eloc
, Strval
=> String_From_Name_Buffer
);
548 Get_Name_String
(Chars
(Internal
));
551 Make_String_Literal
(Iloc
, Strval
=> String_From_Name_Buffer
);
554 Ploc
:= Sloc
(Psect
);
558 Insert_After_And_Analyze
(N
,
560 Chars
=> Name_Machine_Attribute
,
561 Pragma_Argument_Associations
=> New_List
(
562 Make_Pragma_Argument_Association
(Iloc
,
563 Expression
=> New_Copy_Tree
(Internal
)),
564 Make_Pragma_Argument_Association
(Eloc
,
566 Make_String_Literal
(Sloc
=> Ploc
, Strval
=> "common_object")),
567 Make_Pragma_Argument_Association
(Ploc
,
568 Expression
=> New_Copy_Tree
(Psect
)))));
569 end Expand_Pragma_Common_Object
;
571 ----------------------------------
572 -- Expand_Pragma_Contract_Cases --
573 ----------------------------------
575 -- Pragma Contract_Cases is expanded in the following manner:
578 -- Count : Natural := 0;
579 -- Flag_1 : Boolean := False;
581 -- Flag_N : Boolean := False;
582 -- Flag_N+1 : Boolean := False; -- when "others" present
587 -- <preconditions (if any)>
589 -- -- Evaluate all case guards
591 -- if Case_Guard_1 then
593 -- Count := Count + 1;
596 -- if Case_Guard_N then
598 -- Count := Count + 1;
601 -- -- Emit errors depending on the number of case guards that
602 -- -- evaluated to True.
605 -- raise Assertion_Error with "xxx contract cases incomplete";
607 -- Flag_N+1 := True; -- when "others" present
609 -- elsif Count > 1 then
611 -- Str0 : constant String :=
612 -- "contract cases overlap for subprogram ABC";
613 -- Str1 : constant String :=
615 -- Str0 & "case guard at xxx evaluates to True"
617 -- StrN : constant String :=
619 -- StrN-1 & "case guard at xxx evaluates to True"
622 -- raise Assertion_Error with StrN;
626 -- -- Evaluate all attribute 'Old prefixes found in the selected
630 -- Pref_1 := <prefix of 'Old found in Consequence_1>
633 -- Pref_M := <prefix of 'Old found in Consequence_N>
636 -- procedure _Postconditions is
638 -- <postconditions (if any)>
640 -- if Flag_1 and then not Consequence_1 then
641 -- raise Assertion_Error with "failed contract case at xxx";
644 -- if Flag_N[+1] and then not Consequence_N[+1] then
645 -- raise Assertion_Error with "failed contract case at xxx";
647 -- end _Postconditions;
652 procedure Expand_Pragma_Contract_Cases
656 Stmts
: in out List_Id
)
658 Loc
: constant Source_Ptr
:= Sloc
(CCs
);
660 procedure Case_Guard_Error
663 Error_Loc
: Source_Ptr
;
664 Msg
: in out Entity_Id
);
665 -- Given a declarative list Decls, status flag Flag, the location of the
666 -- error and a string Msg, construct the following check:
667 -- Msg : constant String :=
669 -- Msg & "case guard at Error_Loc evaluates to True"
671 -- The resulting code is added to Decls
673 procedure Consequence_Error
674 (Checks
: in out Node_Id
;
677 -- Given an if statement Checks, status flag Flag and a consequence
678 -- Conseq, construct the following check:
679 -- [els]if Flag and then not Conseq then
680 -- raise Assertion_Error
681 -- with "failed contract case at Sloc (Conseq)";
683 -- The resulting code is added to Checks
685 function Declaration_Of
(Id
: Entity_Id
) return Node_Id
;
686 -- Given the entity Id of a boolean flag, generate:
687 -- Id : Boolean := False;
689 procedure Expand_Attributes_In_Consequence
691 Evals
: in out Node_Id
;
694 -- Perform specialized expansion of all attribute 'Old references found
695 -- in consequence Conseq such that at runtime only prefixes coming from
696 -- the selected consequence are evaluated. Similarly expand attribute
697 -- 'Result references by replacing them with identifier _result which
698 -- resolves to the sole formal parameter of procedure _Postconditions.
699 -- Any temporaries generated in the process are added to declarations
700 -- Decls. Evals is a complex if statement tasked with the evaluation of
701 -- all prefixes coming from a single selected consequence. Flag is the
702 -- corresponding case guard flag. Conseq is the consequence expression.
704 function Increment
(Id
: Entity_Id
) return Node_Id
;
705 -- Given the entity Id of a numerical variable, generate:
708 function Set
(Id
: Entity_Id
) return Node_Id
;
709 -- Given the entity Id of a boolean variable, generate:
712 ----------------------
713 -- Case_Guard_Error --
714 ----------------------
716 procedure Case_Guard_Error
719 Error_Loc
: Source_Ptr
;
720 Msg
: in out Entity_Id
)
722 New_Line
: constant Character := Character'Val (10);
723 New_Msg
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
727 Store_String_Char
(New_Line
);
728 Store_String_Chars
(" case guard at ");
729 Store_String_Chars
(Build_Location_String
(Error_Loc
));
730 Store_String_Chars
(" evaluates to True");
733 -- New_Msg : constant String :=
735 -- Msg & "case guard at Error_Loc evaluates to True"
739 Make_Object_Declaration
(Loc
,
740 Defining_Identifier
=> New_Msg
,
741 Constant_Present
=> True,
742 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
744 Make_If_Expression
(Loc
,
745 Expressions
=> New_List
(
746 New_Occurrence_Of
(Flag
, Loc
),
749 Left_Opnd
=> New_Occurrence_Of
(Msg
, Loc
),
750 Right_Opnd
=> Make_String_Literal
(Loc
, End_String
)),
752 New_Occurrence_Of
(Msg
, Loc
)))));
755 end Case_Guard_Error
;
757 -----------------------
758 -- Consequence_Error --
759 -----------------------
761 procedure Consequence_Error
762 (Checks
: in out Node_Id
;
771 -- Flag and then not Conseq
775 Left_Opnd
=> New_Occurrence_Of
(Flag
, Loc
),
778 Right_Opnd
=> Relocate_Node
(Conseq
)));
781 -- raise Assertion_Error
782 -- with "failed contract case at Sloc (Conseq)";
785 Store_String_Chars
("failed contract case at ");
786 Store_String_Chars
(Build_Location_String
(Sloc
(Conseq
)));
789 Make_Procedure_Call_Statement
(Loc
,
791 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
792 Parameter_Associations
=> New_List
(
793 Make_String_Literal
(Loc
, End_String
)));
797 Make_Implicit_If_Statement
(CCs
,
799 Then_Statements
=> New_List
(Error
));
802 if No
(Elsif_Parts
(Checks
)) then
803 Set_Elsif_Parts
(Checks
, New_List
);
806 Append_To
(Elsif_Parts
(Checks
),
807 Make_Elsif_Part
(Loc
,
809 Then_Statements
=> New_List
(Error
)));
811 end Consequence_Error
;
817 function Declaration_Of
(Id
: Entity_Id
) return Node_Id
is
820 Make_Object_Declaration
(Loc
,
821 Defining_Identifier
=> Id
,
822 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
823 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
));
826 --------------------------------------
827 -- Expand_Attributes_In_Consequence --
828 --------------------------------------
830 procedure Expand_Attributes_In_Consequence
832 Evals
: in out Node_Id
;
836 Eval_Stmts
: List_Id
:= No_List
;
837 -- The evaluation sequence expressed as assignment statements of all
838 -- prefixes of attribute 'Old found in the current consequence.
840 function Expand_Attributes
(N
: Node_Id
) return Traverse_Result
;
841 -- Determine whether an arbitrary node denotes attribute 'Old or
842 -- 'Result and if it does, perform all expansion-related actions.
844 -----------------------
845 -- Expand_Attributes --
846 -----------------------
848 function Expand_Attributes
(N
: Node_Id
) return Traverse_Result
is
856 if Nkind
(N
) = N_Attribute_Reference
857 and then Attribute_Name
(N
) = Name_Old
860 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
861 Set_Etype
(Temp
, Etype
(Pref
));
863 -- Generate a temporary to capture the value of the prefix:
864 -- Temp : <Pref type>;
867 Make_Object_Declaration
(Loc
,
868 Defining_Identifier
=> Temp
,
870 New_Occurrence_Of
(Etype
(Pref
), Loc
));
872 -- Place that temporary at the beginning of declarations, to
873 -- prevent anomalies in the GNATprove flow-analysis pass in
874 -- the precondition procedure that follows.
876 Prepend_To
(Decls
, Decl
);
878 -- If the type is unconstrained, the prefix provides its
879 -- value and constraint, so add it to declaration.
881 if not Is_Constrained
(Etype
(Pref
))
882 and then Is_Entity_Name
(Pref
)
884 Set_Expression
(Decl
, Pref
);
887 -- Otherwise add an assignment statement to temporary using
893 if No
(Eval_Stmts
) then
894 Eval_Stmts
:= New_List
;
897 Append_To
(Eval_Stmts
,
898 Make_Assignment_Statement
(Loc
,
899 Name
=> New_Occurrence_Of
(Temp
, Loc
),
900 Expression
=> Pref
));
904 -- Ensure that the prefix is valid
906 if Validity_Checks_On
and then Validity_Check_Operands
then
910 -- Replace the original attribute 'Old by a reference to the
911 -- generated temporary.
913 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
917 elsif Is_Attribute_Result
(N
) then
918 Rewrite
(N
, Make_Identifier
(Loc
, Name_uResult
));
922 end Expand_Attributes
;
924 procedure Expand_Attributes_In
is
925 new Traverse_Proc
(Expand_Attributes
);
927 -- Start of processing for Expand_Attributes_In_Consequence
930 -- Inspect the consequence and expand any attribute 'Old and 'Result
931 -- references found within.
933 Expand_Attributes_In
(Conseq
);
935 -- The consequence does not contain any attribute 'Old references
937 if No
(Eval_Stmts
) then
941 -- Augment the machinery to trigger the evaluation of all prefixes
942 -- found in the step above. If Eval is empty, then this is the first
943 -- consequence to yield expansion of 'Old. Generate:
946 -- <evaluation statements>
951 Make_Implicit_If_Statement
(CCs
,
952 Condition
=> New_Occurrence_Of
(Flag
, Loc
),
953 Then_Statements
=> Eval_Stmts
);
955 -- Otherwise generate:
957 -- <evaluation statements>
961 if No
(Elsif_Parts
(Evals
)) then
962 Set_Elsif_Parts
(Evals
, New_List
);
965 Append_To
(Elsif_Parts
(Evals
),
966 Make_Elsif_Part
(Loc
,
967 Condition
=> New_Occurrence_Of
(Flag
, Loc
),
968 Then_Statements
=> Eval_Stmts
));
970 end Expand_Attributes_In_Consequence
;
976 function Increment
(Id
: Entity_Id
) return Node_Id
is
979 Make_Assignment_Statement
(Loc
,
980 Name
=> New_Occurrence_Of
(Id
, Loc
),
983 Left_Opnd
=> New_Occurrence_Of
(Id
, Loc
),
984 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
991 function Set
(Id
: Entity_Id
) return Node_Id
is
994 Make_Assignment_Statement
(Loc
,
995 Name
=> New_Occurrence_Of
(Id
, Loc
),
996 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
1001 Aggr
: constant Node_Id
:=
1002 Expression
(First
(Pragma_Argument_Associations
(CCs
)));
1004 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
1006 Case_Guard
: Node_Id
;
1007 CG_Checks
: Node_Id
;
1010 Conseq_Checks
: Node_Id
:= Empty
;
1012 Count_Decl
: Node_Id
;
1013 Error_Decls
: List_Id
;
1015 Flag_Decl
: Node_Id
;
1017 Msg_Str
: Entity_Id
;
1018 Multiple_PCs
: Boolean;
1019 Old_Evals
: Node_Id
:= Empty
;
1020 Others_Decl
: Node_Id
;
1021 Others_Flag
: Entity_Id
:= Empty
;
1022 Post_Case
: Node_Id
;
1024 -- Start of processing for Expand_Pragma_Contract_Cases
1027 -- Do nothing if pragma is not enabled. If pragma is disabled, it has
1028 -- already been rewritten as a Null statement.
1030 if Is_Ignored
(CCs
) then
1033 -- Guard against malformed contract cases
1035 elsif Nkind
(Aggr
) /= N_Aggregate
then
1039 -- The contract cases is Ghost when it applies to a Ghost entity. Set
1040 -- the mode now to ensure that any nodes generated during expansion are
1041 -- properly flagged as Ghost.
1043 Set_Ghost_Mode
(CCs
);
1045 -- The expansion of contract cases is quite distributed as it produces
1046 -- various statements to evaluate the case guards and consequences. To
1047 -- preserve the original context, set the Is_Assertion_Expr flag. This
1048 -- aids the Ghost legality checks when verifying the placement of a
1049 -- reference to a Ghost entity.
1051 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
1053 Multiple_PCs
:= List_Length
(Component_Associations
(Aggr
)) > 1;
1055 -- Create the counter which tracks the number of case guards that
1056 -- evaluate to True.
1058 -- Count : Natural := 0;
1060 Count
:= Make_Temporary
(Loc
, 'C');
1062 Make_Object_Declaration
(Loc
,
1063 Defining_Identifier
=> Count
,
1064 Object_Definition
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1065 Expression
=> Make_Integer_Literal
(Loc
, 0));
1067 Prepend_To
(Decls
, Count_Decl
);
1068 Analyze
(Count_Decl
);
1070 -- Create the base error message for multiple overlapping case guards
1072 -- Msg_Str : constant String :=
1073 -- "contract cases overlap for subprogram Subp_Id";
1075 if Multiple_PCs
then
1076 Msg_Str
:= Make_Temporary
(Loc
, 'S');
1079 Store_String_Chars
("contract cases overlap for subprogram ");
1080 Store_String_Chars
(Get_Name_String
(Chars
(Subp_Id
)));
1082 Error_Decls
:= New_List
(
1083 Make_Object_Declaration
(Loc
,
1084 Defining_Identifier
=> Msg_Str
,
1085 Constant_Present
=> True,
1086 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
1087 Expression
=> Make_String_Literal
(Loc
, End_String
)));
1090 -- Process individual post cases
1092 Post_Case
:= First
(Component_Associations
(Aggr
));
1093 while Present
(Post_Case
) loop
1094 Case_Guard
:= First
(Choices
(Post_Case
));
1095 Conseq
:= Expression
(Post_Case
);
1097 -- The "others" choice requires special processing
1099 if Nkind
(Case_Guard
) = N_Others_Choice
then
1100 Others_Flag
:= Make_Temporary
(Loc
, 'F');
1101 Others_Decl
:= Declaration_Of
(Others_Flag
);
1103 Prepend_To
(Decls
, Others_Decl
);
1104 Analyze
(Others_Decl
);
1106 -- Check possible overlap between a case guard and "others"
1108 if Multiple_PCs
and Exception_Extra_Info
then
1110 (Decls
=> Error_Decls
,
1111 Flag
=> Others_Flag
,
1112 Error_Loc
=> Sloc
(Case_Guard
),
1116 -- Inspect the consequence and perform special expansion of any
1117 -- attribute 'Old and 'Result references found within.
1119 Expand_Attributes_In_Consequence
1122 Flag
=> Others_Flag
,
1125 -- Check the corresponding consequence of "others"
1128 (Checks
=> Conseq_Checks
,
1129 Flag
=> Others_Flag
,
1132 -- Regular post case
1135 -- Create the flag which tracks the state of its associated case
1138 Flag
:= Make_Temporary
(Loc
, 'F');
1139 Flag_Decl
:= Declaration_Of
(Flag
);
1141 Prepend_To
(Decls
, Flag_Decl
);
1142 Analyze
(Flag_Decl
);
1144 -- The flag is set when the case guard is evaluated to True
1145 -- if Case_Guard then
1147 -- Count := Count + 1;
1151 Make_Implicit_If_Statement
(CCs
,
1152 Condition
=> Relocate_Node
(Case_Guard
),
1153 Then_Statements
=> New_List
(
1155 Increment
(Count
)));
1157 Append_To
(Decls
, If_Stmt
);
1160 -- Check whether this case guard overlaps with another one
1162 if Multiple_PCs
and Exception_Extra_Info
then
1164 (Decls
=> Error_Decls
,
1166 Error_Loc
=> Sloc
(Case_Guard
),
1170 -- Inspect the consequence and perform special expansion of any
1171 -- attribute 'Old and 'Result references found within.
1173 Expand_Attributes_In_Consequence
1179 -- The corresponding consequence of the case guard which evaluated
1180 -- to True must hold on exit from the subprogram.
1183 (Checks
=> Conseq_Checks
,
1191 -- Raise Assertion_Error when none of the case guards evaluate to True.
1192 -- The only exception is when we have "others", in which case there is
1193 -- no error because "others" acts as a default True.
1198 if Present
(Others_Flag
) then
1199 CG_Stmts
:= New_List
(Set
(Others_Flag
));
1202 -- raise Assertion_Error with "xxx contract cases incomplete";
1206 Store_String_Chars
(Build_Location_String
(Loc
));
1207 Store_String_Chars
(" contract cases incomplete");
1209 CG_Stmts
:= New_List
(
1210 Make_Procedure_Call_Statement
(Loc
,
1212 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
1213 Parameter_Associations
=> New_List
(
1214 Make_String_Literal
(Loc
, End_String
))));
1218 Make_Implicit_If_Statement
(CCs
,
1221 Left_Opnd
=> New_Occurrence_Of
(Count
, Loc
),
1222 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1223 Then_Statements
=> CG_Stmts
);
1225 -- Detect a possible failure due to several case guards evaluating to
1229 -- elsif Count > 0 then
1233 -- raise Assertion_Error with <Msg_Str>;
1236 if Multiple_PCs
then
1237 Set_Elsif_Parts
(CG_Checks
, New_List
(
1238 Make_Elsif_Part
(Loc
,
1241 Left_Opnd
=> New_Occurrence_Of
(Count
, Loc
),
1242 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)),
1244 Then_Statements
=> New_List
(
1245 Make_Block_Statement
(Loc
,
1246 Declarations
=> Error_Decls
,
1247 Handled_Statement_Sequence
=>
1248 Make_Handled_Sequence_Of_Statements
(Loc
,
1249 Statements
=> New_List
(
1250 Make_Procedure_Call_Statement
(Loc
,
1253 (RTE
(RE_Raise_Assert_Failure
), Loc
),
1254 Parameter_Associations
=> New_List
(
1255 New_Occurrence_Of
(Msg_Str
, Loc
))))))))));
1258 Append_To
(Decls
, CG_Checks
);
1259 Analyze
(CG_Checks
);
1261 -- Once all case guards are evaluated and checked, evaluate any prefixes
1262 -- of attribute 'Old founds in the selected consequence.
1264 if Present
(Old_Evals
) then
1265 Append_To
(Decls
, Old_Evals
);
1266 Analyze
(Old_Evals
);
1269 -- Raise Assertion_Error when the corresponding consequence of a case
1270 -- guard that evaluated to True fails.
1276 Append_To
(Stmts
, Conseq_Checks
);
1278 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
1279 Ghost_Mode
:= Save_Ghost_Mode
;
1280 end Expand_Pragma_Contract_Cases
;
1282 ---------------------------------------
1283 -- Expand_Pragma_Import_Or_Interface --
1284 ---------------------------------------
1286 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
) is
1290 -- In Relaxed_RM_Semantics, support old Ada 83 style:
1291 -- pragma Import (Entity, "external name");
1293 if Relaxed_RM_Semantics
1294 and then List_Length
(Pragma_Argument_Associations
(N
)) = 2
1295 and then Chars
(Pragma_Identifier
(N
)) = Name_Import
1296 and then Nkind
(Arg2
(N
)) = N_String_Literal
1298 Def_Id
:= Entity
(Arg1
(N
));
1300 Def_Id
:= Entity
(Arg2
(N
));
1303 -- Variable case (we have to undo any initialization already done)
1305 if Ekind
(Def_Id
) = E_Variable
then
1306 Undo_Initialization
(Def_Id
, N
);
1308 -- Case of exception with convention C++
1310 elsif Ekind
(Def_Id
) = E_Exception
1311 and then Convention
(Def_Id
) = Convention_CPP
1313 -- Import a C++ convention
1316 Loc
: constant Source_Ptr
:= Sloc
(N
);
1317 Rtti_Name
: constant Node_Id
:= Arg3
(N
);
1318 Dum
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
1320 Lang_Char
: Node_Id
;
1321 Foreign_Data
: Node_Id
;
1324 Exdata
:= Component_Associations
(Expression
(Parent
(Def_Id
)));
1326 Lang_Char
:= Next
(First
(Exdata
));
1328 -- Change the one-character language designator to 'C'
1330 Rewrite
(Expression
(Lang_Char
),
1331 Make_Character_Literal
(Loc
,
1333 Char_Literal_Value
=> UI_From_Int
(Character'Pos ('C'))));
1334 Analyze
(Expression
(Lang_Char
));
1336 -- Change the value of Foreign_Data
1338 Foreign_Data
:= Next
(Next
(Next
(Next
(Lang_Char
))));
1340 Insert_Actions
(Def_Id
, New_List
(
1341 Make_Object_Declaration
(Loc
,
1342 Defining_Identifier
=> Dum
,
1343 Object_Definition
=>
1344 New_Occurrence_Of
(Standard_Character
, Loc
)),
1347 Chars
=> Name_Import
,
1348 Pragma_Argument_Associations
=> New_List
(
1349 Make_Pragma_Argument_Association
(Loc
,
1350 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
1352 Make_Pragma_Argument_Association
(Loc
,
1353 Expression
=> Make_Identifier
(Loc
, Chars
(Dum
))),
1355 Make_Pragma_Argument_Association
(Loc
,
1356 Chars
=> Name_External_Name
,
1357 Expression
=> Relocate_Node
(Rtti_Name
))))));
1359 Rewrite
(Expression
(Foreign_Data
),
1360 Unchecked_Convert_To
(Standard_A_Char
,
1361 Make_Attribute_Reference
(Loc
,
1362 Prefix
=> Make_Identifier
(Loc
, Chars
(Dum
)),
1363 Attribute_Name
=> Name_Address
)));
1364 Analyze
(Expression
(Foreign_Data
));
1367 -- No special expansion required for any other case
1372 end Expand_Pragma_Import_Or_Interface
;
1374 -------------------------------------
1375 -- Expand_Pragma_Initial_Condition --
1376 -------------------------------------
1378 procedure Expand_Pragma_Initial_Condition
(Spec_Or_Body
: Node_Id
) is
1379 Loc
: constant Source_Ptr
:= Sloc
(Spec_Or_Body
);
1382 Init_Cond
: Node_Id
;
1384 Pack_Id
: Entity_Id
;
1386 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
1389 if Nkind
(Spec_Or_Body
) = N_Package_Body
then
1390 Pack_Id
:= Corresponding_Spec
(Spec_Or_Body
);
1392 if Present
(Handled_Statement_Sequence
(Spec_Or_Body
)) then
1393 List
:= Statements
(Handled_Statement_Sequence
(Spec_Or_Body
));
1395 -- The package body lacks statements, create an empty list
1400 Set_Handled_Statement_Sequence
(Spec_Or_Body
,
1401 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> List
));
1404 elsif Nkind
(Spec_Or_Body
) = N_Package_Declaration
then
1405 Pack_Id
:= Defining_Entity
(Spec_Or_Body
);
1407 if Present
(Visible_Declarations
(Specification
(Spec_Or_Body
))) then
1408 List
:= Visible_Declarations
(Specification
(Spec_Or_Body
));
1410 -- The package lacks visible declarations, create an empty list
1415 Set_Visible_Declarations
(Specification
(Spec_Or_Body
), List
);
1418 -- This routine should not be used on anything other than packages
1421 raise Program_Error
;
1424 Init_Cond
:= Get_Pragma
(Pack_Id
, Pragma_Initial_Condition
);
1426 -- The initial condition is Ghost when it applies to a Ghost entity. Set
1427 -- the mode now to ensure that any nodes generated during expansion are
1428 -- properly flagged as Ghost.
1430 Set_Ghost_Mode
(Init_Cond
);
1432 -- The caller should check whether the package is subject to pragma
1433 -- Initial_Condition.
1435 pragma Assert
(Present
(Init_Cond
));
1438 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Init_Cond
)));
1440 -- The assertion expression was found to be illegal, do not generate the
1441 -- runtime check as it will repeat the illegality.
1443 if Error_Posted
(Init_Cond
) or else Error_Posted
(Expr
) then
1444 Ghost_Mode
:= Save_Ghost_Mode
;
1449 -- pragma Check (Initial_Condition, <Expr>);
1453 Chars
=> Name_Check
,
1454 Pragma_Argument_Associations
=> New_List
(
1455 Make_Pragma_Argument_Association
(Loc
,
1456 Expression
=> Make_Identifier
(Loc
, Name_Initial_Condition
)),
1457 Make_Pragma_Argument_Association
(Loc
,
1458 Expression
=> New_Copy_Tree
(Expr
))));
1460 Append_To
(List
, Check
);
1463 Ghost_Mode
:= Save_Ghost_Mode
;
1464 end Expand_Pragma_Initial_Condition
;
1466 ------------------------------------
1467 -- Expand_Pragma_Inspection_Point --
1468 ------------------------------------
1470 -- If no argument is given, then we supply a default argument list that
1471 -- includes all objects declared at the source level in all subprograms
1472 -- that enclose the inspection point pragma.
1474 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
) is
1475 Loc
: constant Source_Ptr
:= Sloc
(N
);
1482 if No
(Pragma_Argument_Associations
(N
)) then
1486 while S
/= Standard_Standard
loop
1487 E
:= First_Entity
(S
);
1488 while Present
(E
) loop
1489 if Comes_From_Source
(E
)
1490 and then Is_Object
(E
)
1491 and then not Is_Entry_Formal
(E
)
1492 and then Ekind
(E
) /= E_Component
1493 and then Ekind
(E
) /= E_Discriminant
1494 and then Ekind
(E
) /= E_Generic_In_Parameter
1495 and then Ekind
(E
) /= E_Generic_In_Out_Parameter
1498 Make_Pragma_Argument_Association
(Loc
,
1499 Expression
=> New_Occurrence_Of
(E
, Loc
)));
1508 Set_Pragma_Argument_Associations
(N
, A
);
1511 -- Expand the arguments of the pragma. Expanding an entity reference
1512 -- is a noop, except in a protected operation, where a reference may
1513 -- have to be transformed into a reference to the corresponding prival.
1514 -- Are there other pragmas that may require this ???
1516 Assoc
:= First
(Pragma_Argument_Associations
(N
));
1517 while Present
(Assoc
) loop
1518 Expand
(Expression
(Assoc
));
1521 end Expand_Pragma_Inspection_Point
;
1523 --------------------------------------
1524 -- Expand_Pragma_Interrupt_Priority --
1525 --------------------------------------
1527 -- Supply default argument if none exists (System.Interrupt_Priority'Last)
1529 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
) is
1530 Loc
: constant Source_Ptr
:= Sloc
(N
);
1532 if No
(Pragma_Argument_Associations
(N
)) then
1533 Set_Pragma_Argument_Associations
(N
, New_List
(
1534 Make_Pragma_Argument_Association
(Loc
,
1536 Make_Attribute_Reference
(Loc
,
1538 New_Occurrence_Of
(RTE
(RE_Interrupt_Priority
), Loc
),
1539 Attribute_Name
=> Name_Last
))));
1541 end Expand_Pragma_Interrupt_Priority
;
1543 --------------------------------
1544 -- Expand_Pragma_Loop_Variant --
1545 --------------------------------
1547 -- Pragma Loop_Variant is expanded in the following manner:
1551 -- for | while ... loop
1552 -- <preceding source statements>
1553 -- pragma Loop_Variant
1554 -- (Increases => Incr_Expr,
1555 -- Decreases => Decr_Expr);
1556 -- <succeeding source statements>
1561 -- Curr_1 : <type of Incr_Expr>;
1562 -- Curr_2 : <type of Decr_Expr>;
1563 -- Old_1 : <type of Incr_Expr>;
1564 -- Old_2 : <type of Decr_Expr>;
1565 -- Flag : Boolean := False;
1567 -- for | while ... loop
1568 -- <preceding source statements>
1575 -- Curr_1 := <Incr_Expr>;
1576 -- Curr_2 := <Decr_Expr>;
1579 -- if Curr_1 /= Old_1 then
1580 -- pragma Check (Loop_Variant, Curr_1 > Old_1);
1582 -- pragma Check (Loop_Variant, Curr_2 < Old_2);
1588 -- <succeeding source statements>
1591 procedure Expand_Pragma_Loop_Variant
(N
: Node_Id
) is
1592 Loc
: constant Source_Ptr
:= Sloc
(N
);
1593 Last_Var
: constant Node_Id
:=
1594 Last
(Pragma_Argument_Associations
(N
));
1596 Curr_Assign
: List_Id
:= No_List
;
1597 Flag_Id
: Entity_Id
:= Empty
;
1598 If_Stmt
: Node_Id
:= Empty
;
1599 Old_Assign
: List_Id
:= No_List
;
1600 Loop_Scop
: Entity_Id
;
1601 Loop_Stmt
: Node_Id
;
1604 procedure Process_Variant
(Variant
: Node_Id
; Is_Last
: Boolean);
1605 -- Process a single increasing / decreasing termination variant. Flag
1606 -- Is_Last should be set when processing the last variant.
1608 ---------------------
1609 -- Process_Variant --
1610 ---------------------
1612 procedure Process_Variant
(Variant
: Node_Id
; Is_Last
: Boolean) is
1616 Old_Val
: Node_Id
) return Node_Id
;
1617 -- Generate a comparison between Curr_Val and Old_Val depending on
1618 -- the change mode (Increases / Decreases) of the variant.
1627 Old_Val
: Node_Id
) return Node_Id
1630 if Chars
(Variant
) = Name_Increases
then
1631 return Make_Op_Gt
(Loc
, Curr_Val
, Old_Val
);
1632 else pragma Assert
(Chars
(Variant
) = Name_Decreases
);
1633 return Make_Op_Lt
(Loc
, Curr_Val
, Old_Val
);
1639 Expr
: constant Node_Id
:= Expression
(Variant
);
1640 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
1641 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1642 Loop_Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
1643 Curr_Id
: Entity_Id
;
1647 -- Start of processing for Process_Variant
1650 -- All temporaries generated in this routine must be inserted before
1651 -- the related loop statement. Ensure that the proper scope is on the
1652 -- stack when analyzing the temporaries. Note that we also use the
1653 -- Sloc of the related loop.
1655 Push_Scope
(Scope
(Loop_Scop
));
1657 -- Step 1: Create the declaration of the flag which controls the
1658 -- behavior of the assertion on the first iteration of the loop.
1660 if No
(Flag_Id
) then
1663 -- Flag : Boolean := False;
1665 Flag_Id
:= Make_Temporary
(Loop_Loc
, 'F');
1667 Insert_Action
(Loop_Stmt
,
1668 Make_Object_Declaration
(Loop_Loc
,
1669 Defining_Identifier
=> Flag_Id
,
1670 Object_Definition
=>
1671 New_Occurrence_Of
(Standard_Boolean
, Loop_Loc
),
1673 New_Occurrence_Of
(Standard_False
, Loop_Loc
)));
1675 -- Prevent an unwanted optimization where the Current_Value of
1676 -- the flag eliminates the if statement which stores the variant
1677 -- values coming from the previous iteration.
1679 -- Flag : Boolean := False;
1681 -- if Flag then -- condition rewritten to False
1682 -- Old_N := Curr_N; -- and if statement eliminated
1688 Set_Current_Value
(Flag_Id
, Empty
);
1691 -- Step 2: Create the temporaries which store the old and current
1692 -- values of the associated expression.
1695 -- Curr : <type of Expr>;
1697 Curr_Id
:= Make_Temporary
(Loc
, 'C');
1699 Insert_Action
(Loop_Stmt
,
1700 Make_Object_Declaration
(Loop_Loc
,
1701 Defining_Identifier
=> Curr_Id
,
1702 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loop_Loc
)));
1705 -- Old : <type of Expr>;
1707 Old_Id
:= Make_Temporary
(Loc
, 'P');
1709 Insert_Action
(Loop_Stmt
,
1710 Make_Object_Declaration
(Loop_Loc
,
1711 Defining_Identifier
=> Old_Id
,
1712 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loop_Loc
)));
1714 -- Restore original scope after all temporaries have been analyzed
1718 -- Step 3: Store value of the expression from the previous iteration
1720 if No
(Old_Assign
) then
1721 Old_Assign
:= New_List
;
1727 Append_To
(Old_Assign
,
1728 Make_Assignment_Statement
(Loc
,
1729 Name
=> New_Occurrence_Of
(Old_Id
, Loc
),
1730 Expression
=> New_Occurrence_Of
(Curr_Id
, Loc
)));
1732 -- Step 4: Store the current value of the expression
1734 if No
(Curr_Assign
) then
1735 Curr_Assign
:= New_List
;
1741 Append_To
(Curr_Assign
,
1742 Make_Assignment_Statement
(Loc
,
1743 Name
=> New_Occurrence_Of
(Curr_Id
, Loc
),
1744 Expression
=> Relocate_Node
(Expr
)));
1746 -- Step 5: Create corresponding assertion to verify change of value
1749 -- pragma Check (Loop_Variant, Curr <|> Old);
1753 Chars
=> Name_Check
,
1754 Pragma_Argument_Associations
=> New_List
(
1755 Make_Pragma_Argument_Association
(Loc
,
1756 Expression
=> Make_Identifier
(Loc
, Name_Loop_Variant
)),
1757 Make_Pragma_Argument_Association
(Loc
,
1760 Curr_Val
=> New_Occurrence_Of
(Curr_Id
, Loc
),
1761 Old_Val
=> New_Occurrence_Of
(Old_Id
, Loc
)))));
1764 -- if Curr /= Old then
1767 if No
(If_Stmt
) then
1769 -- When there is just one termination variant, do not compare the
1770 -- old and current value for equality, just check the pragma.
1776 Make_If_Statement
(Loc
,
1779 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
1780 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
1781 Then_Statements
=> New_List
(Prag
));
1790 Set_Else_Statements
(If_Stmt
, New_List
(Prag
));
1793 -- elsif Curr /= Old then
1797 if Elsif_Parts
(If_Stmt
) = No_List
then
1798 Set_Elsif_Parts
(If_Stmt
, New_List
);
1801 Append_To
(Elsif_Parts
(If_Stmt
),
1802 Make_Elsif_Part
(Loc
,
1805 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
1806 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
1807 Then_Statements
=> New_List
(Prag
)));
1809 end Process_Variant
;
1813 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
1815 -- Start of processing for Expand_Pragma_Loop_Variant
1818 -- If pragma is not enabled, rewrite as Null statement. If pragma is
1819 -- disabled, it has already been rewritten as a Null statement.
1821 if Is_Ignored
(N
) then
1822 Rewrite
(N
, Make_Null_Statement
(Loc
));
1827 -- The loop variant is Ghost when it applies to a Ghost entity. Set
1828 -- the mode now to ensure that any nodes generated during expansion
1829 -- are properly flagged as Ghost.
1833 -- The expansion of Loop_Variant is quite distributed as it produces
1834 -- various statements to capture and compare the arguments. To preserve
1835 -- the original context, set the Is_Assertion_Expr flag. This aids the
1836 -- Ghost legality checks when verifying the placement of a reference to
1839 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
1841 -- Locate the enclosing loop for which this assertion applies. In the
1842 -- case of Ada 2012 array iteration, we might be dealing with nested
1843 -- loops. Only the outermost loop has an identifier.
1846 while Present
(Loop_Stmt
) loop
1847 if Nkind
(Loop_Stmt
) = N_Loop_Statement
1848 and then Present
(Identifier
(Loop_Stmt
))
1853 Loop_Stmt
:= Parent
(Loop_Stmt
);
1856 Loop_Scop
:= Entity
(Identifier
(Loop_Stmt
));
1858 -- Create the circuitry which verifies individual variants
1860 Variant
:= First
(Pragma_Argument_Associations
(N
));
1861 while Present
(Variant
) loop
1862 Process_Variant
(Variant
, Is_Last
=> Variant
= Last_Var
);
1866 -- Construct the segment which stores the old values of all expressions.
1873 Make_If_Statement
(Loc
,
1874 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
1875 Then_Statements
=> Old_Assign
));
1877 -- Update the values of all expressions
1879 Insert_Actions
(N
, Curr_Assign
);
1881 -- Add the assertion circuitry to test all changes in expressions.
1890 Make_If_Statement
(Loc
,
1891 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
1892 Then_Statements
=> New_List
(If_Stmt
),
1893 Else_Statements
=> New_List
(
1894 Make_Assignment_Statement
(Loc
,
1895 Name
=> New_Occurrence_Of
(Flag_Id
, Loc
),
1896 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
1898 -- Note: the pragma has been completely transformed into a sequence of
1899 -- corresponding declarations and statements. We leave it in the tree
1900 -- for documentation purposes. It will be ignored by the backend.
1902 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
1903 Ghost_Mode
:= Save_Ghost_Mode
;
1904 end Expand_Pragma_Loop_Variant
;
1906 --------------------------------
1907 -- Expand_Pragma_Psect_Object --
1908 --------------------------------
1910 -- Convert to Common_Object, and expand the resulting pragma
1912 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
)
1913 renames Expand_Pragma_Common_Object
;
1915 -------------------------------------
1916 -- Expand_Pragma_Relative_Deadline --
1917 -------------------------------------
1919 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
) is
1920 P
: constant Node_Id
:= Parent
(N
);
1921 Loc
: constant Source_Ptr
:= Sloc
(N
);
1924 -- Expand the pragma only in the case of the main subprogram. For tasks
1925 -- the expansion is done in exp_ch9. Generate a call to Set_Deadline
1926 -- at Clock plus the relative deadline specified in the pragma. Time
1927 -- values are translated into Duration to allow for non-private
1928 -- addition operation.
1930 if Nkind
(P
) = N_Subprogram_Body
then
1933 Make_Procedure_Call_Statement
(Loc
,
1934 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Deadline
), Loc
),
1935 Parameter_Associations
=> New_List
(
1936 Unchecked_Convert_To
(RTE
(RO_RT_Time
),
1939 Make_Function_Call
(Loc
,
1940 New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
1943 (Loc
, New_Occurrence_Of
(RTE
(RE_Clock
), Loc
)))),
1945 Unchecked_Convert_To
(Standard_Duration
, Arg1
(N
)))))));
1949 end Expand_Pragma_Relative_Deadline
;
1951 -------------------------------------------
1952 -- Expand_Pragma_Suppress_Initialization --
1953 -------------------------------------------
1955 procedure Expand_Pragma_Suppress_Initialization
(N
: Node_Id
) is
1956 Def_Id
: constant Entity_Id
:= Entity
(Arg1
(N
));
1959 -- Variable case (we have to undo any initialization already done)
1961 if Ekind
(Def_Id
) = E_Variable
then
1962 Undo_Initialization
(Def_Id
, N
);
1964 end Expand_Pragma_Suppress_Initialization
;
1966 -------------------------
1967 -- Undo_Initialization --
1968 -------------------------
1970 procedure Undo_Initialization
(Def_Id
: Entity_Id
; N
: Node_Id
) is
1971 Init_Call
: Node_Id
;
1974 -- When applied to a variable, the default initialization must not be
1975 -- done. As it is already done when the pragma is found, we just get rid
1976 -- of the call the initialization procedure which followed the object
1977 -- declaration. The call is inserted after the declaration, but validity
1978 -- checks may also have been inserted and thus the initialization call
1979 -- does not necessarily appear immediately after the object declaration.
1981 -- We can't use the freezing mechanism for this purpose, since we have
1982 -- to elaborate the initialization expression when it is first seen (so
1983 -- this elaboration cannot be deferred to the freeze point).
1985 -- Find and remove generated initialization call for object, if any
1987 Init_Call
:= Remove_Init_Call
(Def_Id
, Rep_Clause
=> N
);
1989 -- Any default initialization expression should be removed (e.g.
1990 -- null defaults for access objects, zero initialization of packed
1991 -- bit arrays). Imported objects aren't allowed to have explicit
1992 -- initialization, so the expression must have been generated by
1995 if No
(Init_Call
) and then Present
(Expression
(Parent
(Def_Id
))) then
1996 Set_Expression
(Parent
(Def_Id
), Empty
);
1999 -- The object may not have any initialization, but in the presence of
2000 -- Initialize_Scalars code is inserted after then declaration, which
2001 -- must now be removed as well. The code carries the same source
2002 -- location as the declaration itself.
2004 if Initialize_Scalars
and then Is_Array_Type
(Etype
(Def_Id
)) then
2009 Init
:= Next
(Parent
(Def_Id
));
2010 while not Comes_From_Source
(Init
)
2011 and then Sloc
(Init
) = Sloc
(Def_Id
)
2019 end Undo_Initialization
;