1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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 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_Aux
; use Sem_Aux
;
46 with Sem_Ch8
; use Sem_Ch8
;
47 with Sem_Util
; use Sem_Util
;
48 with Sinfo
; use Sinfo
;
49 with Sinput
; use Sinput
;
50 with Snames
; use Snames
;
51 with Stringt
; use Stringt
;
52 with Stand
; use Stand
;
53 with Tbuild
; use Tbuild
;
54 with Uintp
; use Uintp
;
55 with Validsw
; use Validsw
;
57 package body Exp_Prag
is
59 -----------------------
60 -- Local Subprograms --
61 -----------------------
63 function Arg1
(N
: Node_Id
) return Node_Id
;
64 function Arg2
(N
: Node_Id
) return Node_Id
;
65 function Arg3
(N
: Node_Id
) return Node_Id
;
66 -- Obtain specified pragma argument expression
68 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
);
69 procedure Expand_Pragma_Check
(N
: Node_Id
);
70 procedure Expand_Pragma_Common_Object
(N
: Node_Id
);
71 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
);
72 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
);
73 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
);
74 procedure Expand_Pragma_Loop_Variant
(N
: Node_Id
);
75 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
);
76 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
);
77 procedure Expand_Pragma_Suppress_Initialization
(N
: Node_Id
);
79 procedure Undo_Initialization
(Def_Id
: Entity_Id
; N
: Node_Id
);
80 -- This procedure is used to undo initialization already done for Def_Id,
81 -- which is always an E_Variable, in response to the occurrence of the
82 -- pragma N, a pragma Interface, Import, or Suppress_Initialization. In all
83 -- these cases we want no initialization to occur, but we have already done
84 -- the initialization by the time we see the pragma, so we have to undo it.
90 function Arg1
(N
: Node_Id
) return Node_Id
is
91 Arg
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
94 and then Nkind
(Arg
) = N_Pragma_Argument_Association
96 return Expression
(Arg
);
106 function Arg2
(N
: Node_Id
) return Node_Id
is
107 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
115 Arg
: constant Node_Id
:= Next
(Arg1
);
118 and then Nkind
(Arg
) = N_Pragma_Argument_Association
120 return Expression
(Arg
);
132 function Arg3
(N
: Node_Id
) return Node_Id
is
133 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
141 Arg
: Node_Id
:= Next
(Arg1
);
150 and then Nkind
(Arg
) = N_Pragma_Argument_Association
152 return Expression
(Arg
);
161 ---------------------
162 -- Expand_N_Pragma --
163 ---------------------
165 procedure Expand_N_Pragma
(N
: Node_Id
) is
166 Pname
: constant Name_Id
:= Pragma_Name
(N
);
167 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
170 -- Rewrite pragma ignored by Ignore_Pragma to null statement, so that
171 -- the back end doesn't see it. The same goes for pragma
172 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
174 if Should_Ignore_Pragma_Sem
(N
)
175 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
176 and then Ignore_Rep_Clauses
)
178 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
184 -- Pragmas requiring special expander action
186 when Pragma_Abort_Defer
=>
187 Expand_Pragma_Abort_Defer
(N
);
190 Expand_Pragma_Check
(N
);
192 when Pragma_Common_Object
=>
193 Expand_Pragma_Common_Object
(N
);
195 when Pragma_Import
=>
196 Expand_Pragma_Import_Or_Interface
(N
);
198 when Pragma_Inspection_Point
=>
199 Expand_Pragma_Inspection_Point
(N
);
201 when Pragma_Interface
=>
202 Expand_Pragma_Import_Or_Interface
(N
);
204 when Pragma_Interrupt_Priority
=>
205 Expand_Pragma_Interrupt_Priority
(N
);
207 when Pragma_Loop_Variant
=>
208 Expand_Pragma_Loop_Variant
(N
);
210 when Pragma_Psect_Object
=>
211 Expand_Pragma_Psect_Object
(N
);
213 when Pragma_Relative_Deadline
=>
214 Expand_Pragma_Relative_Deadline
(N
);
216 when Pragma_Suppress_Initialization
=>
217 Expand_Pragma_Suppress_Initialization
(N
);
219 -- All other pragmas need no expander action (includes
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 procedure Replace_Discriminals_Of_Protected_Op
(Expr
: Node_Id
);
325 -- Discriminants of the enclosing protected object may be referenced
326 -- in the expression of a precondition of a protected operation.
327 -- In the body of the operation these references must be replaced by
328 -- the discriminal created for them, which are renamings of the
329 -- discriminants of the object that is the target of the operation.
330 -- This replacement is done by visibility when the references appear
331 -- in the subprogram body, but in the case of a condition which appears
332 -- on the specification of the subprogram it has be done separately
333 -- because the condition has been replaced by a Check pragma and
334 -- analyzed earlier, before the creation of the discriminal renaming
335 -- declarations that are added to the subprogram body.
337 ------------------------------------------
338 -- Replace_Discriminals_Of_Protected_Op --
339 ------------------------------------------
341 procedure Replace_Discriminals_Of_Protected_Op
(Expr
: Node_Id
) is
342 function Find_Corresponding_Discriminal
343 (E
: Entity_Id
) return Entity_Id
;
344 -- Find the local entity that renames a discriminant of the enclosing
345 -- protected type, and has a matching name.
347 function Replace_Discr_Ref
(N
: Node_Id
) return Traverse_Result
;
348 -- Replace a reference to a discriminant of the original protected
349 -- type by the local renaming declaration of the discriminant of
350 -- the target object.
352 ------------------------------------
353 -- Find_Corresponding_Discriminal --
354 ------------------------------------
356 function Find_Corresponding_Discriminal
357 (E
: Entity_Id
) return Entity_Id
362 R
:= First_Entity
(Current_Scope
);
364 while Present
(R
) loop
365 if Nkind
(Parent
(R
)) = N_Object_Renaming_Declaration
366 and then Present
(Discriminal_Link
(R
))
367 and then Chars
(Discriminal_Link
(R
)) = Chars
(E
)
376 end Find_Corresponding_Discriminal
;
378 -----------------------
379 -- Replace_Discr_Ref --
380 -----------------------
382 function Replace_Discr_Ref
(N
: Node_Id
) return Traverse_Result
is
386 if Is_Entity_Name
(N
)
387 and then Present
(Discriminal_Link
(Entity
(N
)))
389 R
:= Find_Corresponding_Discriminal
(Entity
(N
));
390 Rewrite
(N
, New_Occurrence_Of
(R
, Sloc
(N
)));
394 end Replace_Discr_Ref
;
396 procedure Replace_Discriminant_References
is
397 new Traverse_Proc
(Replace_Discr_Ref
);
399 -- Start of processing for Replace_Discriminals_Of_Protected_Op
402 Replace_Discriminant_References
(Expr
);
403 end Replace_Discriminals_Of_Protected_Op
;
405 -- Start of processing for Expand_Pragma_Check
408 -- Nothing to do if pragma is ignored
410 if Is_Ignored
(N
) then
414 -- Since this check is active, rewrite the pragma into a corresponding
415 -- if statement, and then analyze the statement.
417 -- The normal case expansion transforms:
419 -- pragma Check (name, condition [,message]);
423 -- if not condition then
424 -- System.Assertions.Raise_Assert_Failure (Str);
427 -- where Str is the message if one is present, or the default of
428 -- name failed at file:line if no message is given (the "name failed
429 -- at" is omitted for name = Assertion, since it is redundant, given
430 -- that the name of the exception is Assert_Failure.)
432 -- Also, instead of "XXX failed at", we generate slightly
433 -- different messages for some of the contract assertions (see
434 -- code below for details).
436 -- An alternative expansion is used when the No_Exception_Propagation
437 -- restriction is active and there is a local Assert_Failure handler.
438 -- This is not a common combination of circumstances, but it occurs in
439 -- the context of Aunit and the zero footprint profile. In this case we
442 -- if not condition then
443 -- raise Assert_Failure;
446 -- This will then be transformed into a goto, and the local handler will
447 -- be able to handle the assert error (which would not be the case if a
448 -- call is made to the Raise_Assert_Failure procedure).
450 -- We also generate the direct raise if the Suppress_Exception_Locations
451 -- is active, since we don't want to generate messages in this case.
453 -- Note that the reason we do not always generate a direct raise is that
454 -- the form in which the procedure is called allows for more efficient
455 -- breakpointing of assertion errors.
457 -- Generate the appropriate if statement. Note that we consider this to
458 -- be an explicit conditional in the source, not an implicit if, so we
459 -- do not call Make_Implicit_If_Statement.
461 -- Case where we generate a direct raise
463 if ((Debug_Flag_Dot_G
464 or else Restriction_Active
(No_Exception_Propagation
))
465 and then Present
(Find_Local_Handler
(RTE
(RE_Assert_Failure
), N
)))
466 or else (Opt
.Exception_Locations_Suppressed
and then No
(Arg3
(N
)))
469 Make_If_Statement
(Loc
,
470 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Cond
),
471 Then_Statements
=> New_List
(
472 Make_Raise_Statement
(Loc
,
473 Name
=> New_Occurrence_Of
(RTE
(RE_Assert_Failure
), Loc
)))));
475 -- Case where we call the procedure
478 -- If we have a message given, use it
480 if Present
(Arg3
(N
)) then
481 Msg
:= Get_Pragma_Arg
(Arg3
(N
));
483 -- Here we have no string, so prepare one
487 Loc_Str
: constant String := Build_Location_String
(Loc
);
492 -- For Assert, we just use the location
494 if Nam
= Name_Assert
then
497 -- For predicate, we generate the string "predicate failed at
498 -- yyy". We prefer all lower case for predicate.
500 elsif Nam
= Name_Predicate
then
501 Add_Str_To_Name_Buffer
("predicate failed at ");
503 -- For special case of Precondition/Postcondition the string is
504 -- "failed xx from yy" where xx is precondition/postcondition
505 -- in all lower case. The reason for this different wording is
506 -- that the failure is not at the point of occurrence of the
507 -- pragma, unlike the other Check cases.
509 elsif Nam_In
(Nam
, Name_Precondition
, Name_Postcondition
) then
510 Get_Name_String
(Nam
);
511 Insert_Str_In_Name_Buffer
("failed ", 1);
512 Add_Str_To_Name_Buffer
(" from ");
514 -- For special case of Invariant, the string is "failed
515 -- invariant from yy", to be consistent with the string that is
516 -- generated for the aspect case (the code later on checks for
517 -- this specific string to modify it in some cases, so this is
518 -- functionally important).
520 elsif Nam
= Name_Invariant
then
521 Add_Str_To_Name_Buffer
("failed invariant from ");
523 -- For all other checks, the string is "xxx failed at yyy"
524 -- where xxx is the check name with appropriate casing.
527 Get_Name_String
(Nam
);
529 (Identifier_Casing
(Source_Index
(Current_Sem_Unit
)));
530 Add_Str_To_Name_Buffer
(" failed at ");
533 -- In all cases, add location string
535 Add_Str_To_Name_Buffer
(Loc_Str
);
539 Msg
:= Make_String_Literal
(Loc
, Name_Buffer
(1 .. Name_Len
));
543 -- For a precondition, replace references to discriminants of a
544 -- protected type with the local discriminals.
546 if Is_Protected_Type
(Scope
(Current_Scope
))
547 and then Has_Discriminants
(Scope
(Current_Scope
))
548 and then From_Aspect_Specification
(N
)
550 Replace_Discriminals_Of_Protected_Op
(Cond
);
553 -- Now rewrite as an if statement
556 Make_If_Statement
(Loc
,
557 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Cond
),
558 Then_Statements
=> New_List
(
559 Make_Procedure_Call_Statement
(Loc
,
561 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
562 Parameter_Associations
=> New_List
(Relocate_Node
(Msg
))))));
567 -- If new condition is always false, give a warning
569 if Warn_On_Assertion_Failure
570 and then Nkind
(N
) = N_Procedure_Call_Statement
571 and then Is_RTE
(Entity
(Name
(N
)), RE_Raise_Assert_Failure
)
573 -- If original condition was a Standard.False, we assume that this is
574 -- indeed intended to raise assert error and no warning is required.
576 if Is_Entity_Name
(Original_Node
(Cond
))
577 and then Entity
(Original_Node
(Cond
)) = Standard_False
581 elsif Nam
= Name_Assert
then
582 Error_Msg_N
("?A?assertion will fail at run time", N
);
584 Error_Msg_N
("?A?check will fail at run time", N
);
587 end Expand_Pragma_Check
;
589 ---------------------------------
590 -- Expand_Pragma_Common_Object --
591 ---------------------------------
593 -- Use a machine attribute to replicate semantic effect in DEC Ada
595 -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
597 -- For now we do nothing with the size attribute ???
599 -- Note: Psect_Object shares this processing
601 procedure Expand_Pragma_Common_Object
(N
: Node_Id
) is
602 Loc
: constant Source_Ptr
:= Sloc
(N
);
604 Internal
: constant Node_Id
:= Arg1
(N
);
605 External
: constant Node_Id
:= Arg2
(N
);
608 -- Psect value upper cased as string literal
610 Iloc
: constant Source_Ptr
:= Sloc
(Internal
);
611 Eloc
: constant Source_Ptr
:= Sloc
(External
);
615 -- Acquire Psect value and fold to upper case
617 if Present
(External
) then
618 if Nkind
(External
) = N_String_Literal
then
619 String_To_Name_Buffer
(Strval
(External
));
621 Get_Name_String
(Chars
(External
));
627 Make_String_Literal
(Eloc
, Strval
=> String_From_Name_Buffer
);
630 Get_Name_String
(Chars
(Internal
));
633 Make_String_Literal
(Iloc
, Strval
=> String_From_Name_Buffer
);
636 Ploc
:= Sloc
(Psect
);
640 Insert_After_And_Analyze
(N
,
642 Chars
=> Name_Machine_Attribute
,
643 Pragma_Argument_Associations
=> New_List
(
644 Make_Pragma_Argument_Association
(Iloc
,
645 Expression
=> New_Copy_Tree
(Internal
)),
646 Make_Pragma_Argument_Association
(Eloc
,
648 Make_String_Literal
(Sloc
=> Ploc
, Strval
=> "common_object")),
649 Make_Pragma_Argument_Association
(Ploc
,
650 Expression
=> New_Copy_Tree
(Psect
)))));
651 end Expand_Pragma_Common_Object
;
653 ----------------------------------
654 -- Expand_Pragma_Contract_Cases --
655 ----------------------------------
657 -- Pragma Contract_Cases is expanded in the following manner:
660 -- Count : Natural := 0;
661 -- Flag_1 : Boolean := False;
663 -- Flag_N : Boolean := False;
664 -- Flag_N+1 : Boolean := False; -- when "others" present
669 -- <preconditions (if any)>
671 -- -- Evaluate all case guards
673 -- if Case_Guard_1 then
675 -- Count := Count + 1;
678 -- if Case_Guard_N then
680 -- Count := Count + 1;
683 -- -- Emit errors depending on the number of case guards that
684 -- -- evaluated to True.
687 -- raise Assertion_Error with "xxx contract cases incomplete";
689 -- Flag_N+1 := True; -- when "others" present
691 -- elsif Count > 1 then
693 -- Str0 : constant String :=
694 -- "contract cases overlap for subprogram ABC";
695 -- Str1 : constant String :=
697 -- Str0 & "case guard at xxx evaluates to True"
699 -- StrN : constant String :=
701 -- StrN-1 & "case guard at xxx evaluates to True"
704 -- raise Assertion_Error with StrN;
708 -- -- Evaluate all attribute 'Old prefixes found in the selected
712 -- Pref_1 := <prefix of 'Old found in Consequence_1>
715 -- Pref_M := <prefix of 'Old found in Consequence_N>
718 -- procedure _Postconditions is
720 -- <postconditions (if any)>
722 -- if Flag_1 and then not Consequence_1 then
723 -- raise Assertion_Error with "failed contract case at xxx";
726 -- if Flag_N[+1] and then not Consequence_N[+1] then
727 -- raise Assertion_Error with "failed contract case at xxx";
729 -- end _Postconditions;
734 procedure Expand_Pragma_Contract_Cases
738 Stmts
: in out List_Id
)
740 Loc
: constant Source_Ptr
:= Sloc
(CCs
);
742 procedure Case_Guard_Error
745 Error_Loc
: Source_Ptr
;
746 Msg
: in out Entity_Id
);
747 -- Given a declarative list Decls, status flag Flag, the location of the
748 -- error and a string Msg, construct the following check:
749 -- Msg : constant String :=
751 -- Msg & "case guard at Error_Loc evaluates to True"
753 -- The resulting code is added to Decls
755 procedure Consequence_Error
756 (Checks
: in out Node_Id
;
759 -- Given an if statement Checks, status flag Flag and a consequence
760 -- Conseq, construct the following check:
761 -- [els]if Flag and then not Conseq then
762 -- raise Assertion_Error
763 -- with "failed contract case at Sloc (Conseq)";
765 -- The resulting code is added to Checks
767 function Declaration_Of
(Id
: Entity_Id
) return Node_Id
;
768 -- Given the entity Id of a boolean flag, generate:
769 -- Id : Boolean := False;
771 procedure Expand_Attributes_In_Consequence
773 Evals
: in out Node_Id
;
776 -- Perform specialized expansion of all attribute 'Old references found
777 -- in consequence Conseq such that at runtime only prefixes coming from
778 -- the selected consequence are evaluated. Similarly expand attribute
779 -- 'Result references by replacing them with identifier _result which
780 -- resolves to the sole formal parameter of procedure _Postconditions.
781 -- Any temporaries generated in the process are added to declarations
782 -- Decls. Evals is a complex if statement tasked with the evaluation of
783 -- all prefixes coming from a single selected consequence. Flag is the
784 -- corresponding case guard flag. Conseq is the consequence expression.
786 function Increment
(Id
: Entity_Id
) return Node_Id
;
787 -- Given the entity Id of a numerical variable, generate:
790 function Set
(Id
: Entity_Id
) return Node_Id
;
791 -- Given the entity Id of a boolean variable, generate:
794 ----------------------
795 -- Case_Guard_Error --
796 ----------------------
798 procedure Case_Guard_Error
801 Error_Loc
: Source_Ptr
;
802 Msg
: in out Entity_Id
)
804 New_Line
: constant Character := Character'Val (10);
805 New_Msg
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
809 Store_String_Char
(New_Line
);
810 Store_String_Chars
(" case guard at ");
811 Store_String_Chars
(Build_Location_String
(Error_Loc
));
812 Store_String_Chars
(" evaluates to True");
815 -- New_Msg : constant String :=
817 -- Msg & "case guard at Error_Loc evaluates to True"
821 Make_Object_Declaration
(Loc
,
822 Defining_Identifier
=> New_Msg
,
823 Constant_Present
=> True,
824 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
826 Make_If_Expression
(Loc
,
827 Expressions
=> New_List
(
828 New_Occurrence_Of
(Flag
, Loc
),
831 Left_Opnd
=> New_Occurrence_Of
(Msg
, Loc
),
832 Right_Opnd
=> Make_String_Literal
(Loc
, End_String
)),
834 New_Occurrence_Of
(Msg
, Loc
)))));
837 end Case_Guard_Error
;
839 -----------------------
840 -- Consequence_Error --
841 -----------------------
843 procedure Consequence_Error
844 (Checks
: in out Node_Id
;
853 -- Flag and then not Conseq
857 Left_Opnd
=> New_Occurrence_Of
(Flag
, Loc
),
860 Right_Opnd
=> Relocate_Node
(Conseq
)));
863 -- raise Assertion_Error
864 -- with "failed contract case at Sloc (Conseq)";
867 Store_String_Chars
("failed contract case at ");
868 Store_String_Chars
(Build_Location_String
(Sloc
(Conseq
)));
871 Make_Procedure_Call_Statement
(Loc
,
873 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
874 Parameter_Associations
=> New_List
(
875 Make_String_Literal
(Loc
, End_String
)));
879 Make_Implicit_If_Statement
(CCs
,
881 Then_Statements
=> New_List
(Error
));
884 if No
(Elsif_Parts
(Checks
)) then
885 Set_Elsif_Parts
(Checks
, New_List
);
888 Append_To
(Elsif_Parts
(Checks
),
889 Make_Elsif_Part
(Loc
,
891 Then_Statements
=> New_List
(Error
)));
893 end Consequence_Error
;
899 function Declaration_Of
(Id
: Entity_Id
) return Node_Id
is
902 Make_Object_Declaration
(Loc
,
903 Defining_Identifier
=> Id
,
904 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
905 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
));
908 --------------------------------------
909 -- Expand_Attributes_In_Consequence --
910 --------------------------------------
912 procedure Expand_Attributes_In_Consequence
914 Evals
: in out Node_Id
;
918 Eval_Stmts
: List_Id
:= No_List
;
919 -- The evaluation sequence expressed as assignment statements of all
920 -- prefixes of attribute 'Old found in the current consequence.
922 function Expand_Attributes
(N
: Node_Id
) return Traverse_Result
;
923 -- Determine whether an arbitrary node denotes attribute 'Old or
924 -- 'Result and if it does, perform all expansion-related actions.
926 -----------------------
927 -- Expand_Attributes --
928 -----------------------
930 function Expand_Attributes
(N
: Node_Id
) return Traverse_Result
is
938 if Nkind
(N
) = N_Attribute_Reference
939 and then Attribute_Name
(N
) = Name_Old
942 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
943 Set_Etype
(Temp
, Etype
(Pref
));
945 -- Generate a temporary to capture the value of the prefix:
946 -- Temp : <Pref type>;
949 Make_Object_Declaration
(Loc
,
950 Defining_Identifier
=> Temp
,
952 New_Occurrence_Of
(Etype
(Pref
), Loc
));
954 -- Place that temporary at the beginning of declarations, to
955 -- prevent anomalies in the GNATprove flow-analysis pass in
956 -- the precondition procedure that follows.
958 Prepend_To
(Decls
, Decl
);
960 -- If the type is unconstrained, the prefix provides its
961 -- value and constraint, so add it to declaration.
963 if not Is_Constrained
(Etype
(Pref
))
964 and then Is_Entity_Name
(Pref
)
966 Set_Expression
(Decl
, Pref
);
969 -- Otherwise add an assignment statement to temporary using
975 if No
(Eval_Stmts
) then
976 Eval_Stmts
:= New_List
;
979 Append_To
(Eval_Stmts
,
980 Make_Assignment_Statement
(Loc
,
981 Name
=> New_Occurrence_Of
(Temp
, Loc
),
982 Expression
=> Pref
));
986 -- Ensure that the prefix is valid
988 if Validity_Checks_On
and then Validity_Check_Operands
then
992 -- Replace the original attribute 'Old by a reference to the
993 -- generated temporary.
995 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
999 elsif Is_Attribute_Result
(N
) then
1000 Rewrite
(N
, Make_Identifier
(Loc
, Name_uResult
));
1004 end Expand_Attributes
;
1006 procedure Expand_Attributes_In
is
1007 new Traverse_Proc
(Expand_Attributes
);
1009 -- Start of processing for Expand_Attributes_In_Consequence
1012 -- Inspect the consequence and expand any attribute 'Old and 'Result
1013 -- references found within.
1015 Expand_Attributes_In
(Conseq
);
1017 -- The consequence does not contain any attribute 'Old references
1019 if No
(Eval_Stmts
) then
1023 -- Augment the machinery to trigger the evaluation of all prefixes
1024 -- found in the step above. If Eval is empty, then this is the first
1025 -- consequence to yield expansion of 'Old. Generate:
1028 -- <evaluation statements>
1033 Make_Implicit_If_Statement
(CCs
,
1034 Condition
=> New_Occurrence_Of
(Flag
, Loc
),
1035 Then_Statements
=> Eval_Stmts
);
1037 -- Otherwise generate:
1039 -- <evaluation statements>
1043 if No
(Elsif_Parts
(Evals
)) then
1044 Set_Elsif_Parts
(Evals
, New_List
);
1047 Append_To
(Elsif_Parts
(Evals
),
1048 Make_Elsif_Part
(Loc
,
1049 Condition
=> New_Occurrence_Of
(Flag
, Loc
),
1050 Then_Statements
=> Eval_Stmts
));
1052 end Expand_Attributes_In_Consequence
;
1058 function Increment
(Id
: Entity_Id
) return Node_Id
is
1061 Make_Assignment_Statement
(Loc
,
1062 Name
=> New_Occurrence_Of
(Id
, Loc
),
1065 Left_Opnd
=> New_Occurrence_Of
(Id
, Loc
),
1066 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
1073 function Set
(Id
: Entity_Id
) return Node_Id
is
1076 Make_Assignment_Statement
(Loc
,
1077 Name
=> New_Occurrence_Of
(Id
, Loc
),
1078 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
1083 Aggr
: constant Node_Id
:=
1084 Expression
(First
(Pragma_Argument_Associations
(CCs
)));
1086 Case_Guard
: Node_Id
;
1087 CG_Checks
: Node_Id
;
1090 Conseq_Checks
: Node_Id
:= Empty
;
1092 Count_Decl
: Node_Id
;
1093 Error_Decls
: List_Id
:= No_List
; -- init to avoid warning
1095 Flag_Decl
: Node_Id
;
1097 Msg_Str
: Entity_Id
:= Empty
;
1098 Multiple_PCs
: Boolean;
1099 Old_Evals
: Node_Id
:= Empty
;
1100 Others_Decl
: Node_Id
;
1101 Others_Flag
: Entity_Id
:= Empty
;
1102 Post_Case
: Node_Id
;
1104 -- Start of processing for Expand_Pragma_Contract_Cases
1107 -- Do nothing if pragma is not enabled. If pragma is disabled, it has
1108 -- already been rewritten as a Null statement.
1110 if Is_Ignored
(CCs
) then
1113 -- Guard against malformed contract cases
1115 elsif Nkind
(Aggr
) /= N_Aggregate
then
1119 -- The expansion of contract cases is quite distributed as it produces
1120 -- various statements to evaluate the case guards and consequences. To
1121 -- preserve the original context, set the Is_Assertion_Expr flag. This
1122 -- aids the Ghost legality checks when verifying the placement of a
1123 -- reference to a Ghost entity.
1125 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
1127 Multiple_PCs
:= List_Length
(Component_Associations
(Aggr
)) > 1;
1129 -- Create the counter which tracks the number of case guards that
1130 -- evaluate to True.
1132 -- Count : Natural := 0;
1134 Count
:= Make_Temporary
(Loc
, 'C');
1136 Make_Object_Declaration
(Loc
,
1137 Defining_Identifier
=> Count
,
1138 Object_Definition
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1139 Expression
=> Make_Integer_Literal
(Loc
, 0));
1141 Prepend_To
(Decls
, Count_Decl
);
1142 Analyze
(Count_Decl
);
1144 -- Create the base error message for multiple overlapping case guards
1146 -- Msg_Str : constant String :=
1147 -- "contract cases overlap for subprogram Subp_Id";
1149 if Multiple_PCs
then
1150 Msg_Str
:= Make_Temporary
(Loc
, 'S');
1153 Store_String_Chars
("contract cases overlap for subprogram ");
1154 Store_String_Chars
(Get_Name_String
(Chars
(Subp_Id
)));
1156 Error_Decls
:= New_List
(
1157 Make_Object_Declaration
(Loc
,
1158 Defining_Identifier
=> Msg_Str
,
1159 Constant_Present
=> True,
1160 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
1161 Expression
=> Make_String_Literal
(Loc
, End_String
)));
1164 -- Process individual post cases
1166 Post_Case
:= First
(Component_Associations
(Aggr
));
1167 while Present
(Post_Case
) loop
1168 Case_Guard
:= First
(Choices
(Post_Case
));
1169 Conseq
:= Expression
(Post_Case
);
1171 -- The "others" choice requires special processing
1173 if Nkind
(Case_Guard
) = N_Others_Choice
then
1174 Others_Flag
:= Make_Temporary
(Loc
, 'F');
1175 Others_Decl
:= Declaration_Of
(Others_Flag
);
1177 Prepend_To
(Decls
, Others_Decl
);
1178 Analyze
(Others_Decl
);
1180 -- Check possible overlap between a case guard and "others"
1182 if Multiple_PCs
and Exception_Extra_Info
then
1184 (Decls
=> Error_Decls
,
1185 Flag
=> Others_Flag
,
1186 Error_Loc
=> Sloc
(Case_Guard
),
1190 -- Inspect the consequence and perform special expansion of any
1191 -- attribute 'Old and 'Result references found within.
1193 Expand_Attributes_In_Consequence
1196 Flag
=> Others_Flag
,
1199 -- Check the corresponding consequence of "others"
1202 (Checks
=> Conseq_Checks
,
1203 Flag
=> Others_Flag
,
1206 -- Regular post case
1209 -- Create the flag which tracks the state of its associated case
1212 Flag
:= Make_Temporary
(Loc
, 'F');
1213 Flag_Decl
:= Declaration_Of
(Flag
);
1215 Prepend_To
(Decls
, Flag_Decl
);
1216 Analyze
(Flag_Decl
);
1218 -- The flag is set when the case guard is evaluated to True
1219 -- if Case_Guard then
1221 -- Count := Count + 1;
1225 Make_Implicit_If_Statement
(CCs
,
1226 Condition
=> Relocate_Node
(Case_Guard
),
1227 Then_Statements
=> New_List
(
1229 Increment
(Count
)));
1231 Append_To
(Decls
, If_Stmt
);
1234 -- Check whether this case guard overlaps with another one
1236 if Multiple_PCs
and Exception_Extra_Info
then
1238 (Decls
=> Error_Decls
,
1240 Error_Loc
=> Sloc
(Case_Guard
),
1244 -- Inspect the consequence and perform special expansion of any
1245 -- attribute 'Old and 'Result references found within.
1247 Expand_Attributes_In_Consequence
1253 -- The corresponding consequence of the case guard which evaluated
1254 -- to True must hold on exit from the subprogram.
1257 (Checks
=> Conseq_Checks
,
1265 -- Raise Assertion_Error when none of the case guards evaluate to True.
1266 -- The only exception is when we have "others", in which case there is
1267 -- no error because "others" acts as a default True.
1272 if Present
(Others_Flag
) then
1273 CG_Stmts
:= New_List
(Set
(Others_Flag
));
1276 -- raise Assertion_Error with "xxx contract cases incomplete";
1280 Store_String_Chars
(Build_Location_String
(Loc
));
1281 Store_String_Chars
(" contract cases incomplete");
1283 CG_Stmts
:= New_List
(
1284 Make_Procedure_Call_Statement
(Loc
,
1286 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
1287 Parameter_Associations
=> New_List
(
1288 Make_String_Literal
(Loc
, End_String
))));
1292 Make_Implicit_If_Statement
(CCs
,
1295 Left_Opnd
=> New_Occurrence_Of
(Count
, Loc
),
1296 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
1297 Then_Statements
=> CG_Stmts
);
1299 -- Detect a possible failure due to several case guards evaluating to
1303 -- elsif Count > 0 then
1307 -- raise Assertion_Error with <Msg_Str>;
1310 if Multiple_PCs
then
1311 Set_Elsif_Parts
(CG_Checks
, New_List
(
1312 Make_Elsif_Part
(Loc
,
1315 Left_Opnd
=> New_Occurrence_Of
(Count
, Loc
),
1316 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)),
1318 Then_Statements
=> New_List
(
1319 Make_Block_Statement
(Loc
,
1320 Declarations
=> Error_Decls
,
1321 Handled_Statement_Sequence
=>
1322 Make_Handled_Sequence_Of_Statements
(Loc
,
1323 Statements
=> New_List
(
1324 Make_Procedure_Call_Statement
(Loc
,
1327 (RTE
(RE_Raise_Assert_Failure
), Loc
),
1328 Parameter_Associations
=> New_List
(
1329 New_Occurrence_Of
(Msg_Str
, Loc
))))))))));
1332 Append_To
(Decls
, CG_Checks
);
1333 Analyze
(CG_Checks
);
1335 -- Once all case guards are evaluated and checked, evaluate any prefixes
1336 -- of attribute 'Old founds in the selected consequence.
1338 if Present
(Old_Evals
) then
1339 Append_To
(Decls
, Old_Evals
);
1340 Analyze
(Old_Evals
);
1343 -- Raise Assertion_Error when the corresponding consequence of a case
1344 -- guard that evaluated to True fails.
1350 Append_To
(Stmts
, Conseq_Checks
);
1352 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
1353 end Expand_Pragma_Contract_Cases
;
1355 ---------------------------------------
1356 -- Expand_Pragma_Import_Or_Interface --
1357 ---------------------------------------
1359 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
) is
1363 -- In Relaxed_RM_Semantics, support old Ada 83 style:
1364 -- pragma Import (Entity, "external name");
1366 if Relaxed_RM_Semantics
1367 and then List_Length
(Pragma_Argument_Associations
(N
)) = 2
1368 and then Pragma_Name
(N
) = Name_Import
1369 and then Nkind
(Arg2
(N
)) = N_String_Literal
1371 Def_Id
:= Entity
(Arg1
(N
));
1373 Def_Id
:= Entity
(Arg2
(N
));
1376 -- Variable case (we have to undo any initialization already done)
1378 if Ekind
(Def_Id
) = E_Variable
then
1379 Undo_Initialization
(Def_Id
, N
);
1381 -- Case of exception with convention C++
1383 elsif Ekind
(Def_Id
) = E_Exception
1384 and then Convention
(Def_Id
) = Convention_CPP
1386 -- Import a C++ convention
1389 Loc
: constant Source_Ptr
:= Sloc
(N
);
1390 Rtti_Name
: constant Node_Id
:= Arg3
(N
);
1391 Dum
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
1393 Lang_Char
: Node_Id
;
1394 Foreign_Data
: Node_Id
;
1397 Exdata
:= Component_Associations
(Expression
(Parent
(Def_Id
)));
1399 Lang_Char
:= Next
(First
(Exdata
));
1401 -- Change the one-character language designator to 'C'
1403 Rewrite
(Expression
(Lang_Char
),
1404 Make_Character_Literal
(Loc
,
1406 Char_Literal_Value
=> UI_From_Int
(Character'Pos ('C'))));
1407 Analyze
(Expression
(Lang_Char
));
1409 -- Change the value of Foreign_Data
1411 Foreign_Data
:= Next
(Next
(Next
(Next
(Lang_Char
))));
1413 Insert_Actions
(Def_Id
, New_List
(
1414 Make_Object_Declaration
(Loc
,
1415 Defining_Identifier
=> Dum
,
1416 Object_Definition
=>
1417 New_Occurrence_Of
(Standard_Character
, Loc
)),
1420 Chars
=> Name_Import
,
1421 Pragma_Argument_Associations
=> New_List
(
1422 Make_Pragma_Argument_Association
(Loc
,
1423 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
1425 Make_Pragma_Argument_Association
(Loc
,
1426 Expression
=> Make_Identifier
(Loc
, Chars
(Dum
))),
1428 Make_Pragma_Argument_Association
(Loc
,
1429 Chars
=> Name_External_Name
,
1430 Expression
=> Relocate_Node
(Rtti_Name
))))));
1432 Rewrite
(Expression
(Foreign_Data
),
1433 Unchecked_Convert_To
(Standard_A_Char
,
1434 Make_Attribute_Reference
(Loc
,
1435 Prefix
=> Make_Identifier
(Loc
, Chars
(Dum
)),
1436 Attribute_Name
=> Name_Address
)));
1437 Analyze
(Expression
(Foreign_Data
));
1440 -- No special expansion required for any other case
1445 end Expand_Pragma_Import_Or_Interface
;
1447 -------------------------------------
1448 -- Expand_Pragma_Initial_Condition --
1449 -------------------------------------
1451 procedure Expand_Pragma_Initial_Condition
1452 (Pack_Id
: Entity_Id
;
1455 procedure Extract_Package_Body_Lists
1456 (Pack_Body
: Node_Id
;
1457 Body_List
: out List_Id
;
1458 Call_List
: out List_Id
;
1459 Spec_List
: out List_Id
);
1460 -- Obtain the various declarative and statement lists of package body
1461 -- Pack_Body needed to insert the initial condition procedure and the
1462 -- call to it. The lists are as follows:
1464 -- * Body_List - used to insert the initial condition procedure body
1466 -- * Call_List - used to insert the call to the initial condition
1469 -- * Spec_List - used to insert the initial condition procedure spec
1471 procedure Extract_Package_Declaration_Lists
1472 (Pack_Decl
: Node_Id
;
1473 Body_List
: out List_Id
;
1474 Call_List
: out List_Id
;
1475 Spec_List
: out List_Id
);
1476 -- Obtain the various declarative lists of package declaration Pack_Decl
1477 -- needed to insert the initial condition procedure and the call to it.
1478 -- The lists are as follows:
1480 -- * Body_List - used to insert the initial condition procedure body
1482 -- * Call_List - used to insert the call to the initial condition
1485 -- * Spec_List - used to insert the initial condition procedure spec
1487 --------------------------------
1488 -- Extract_Package_Body_Lists --
1489 --------------------------------
1491 procedure Extract_Package_Body_Lists
1492 (Pack_Body
: Node_Id
;
1493 Body_List
: out List_Id
;
1494 Call_List
: out List_Id
;
1495 Spec_List
: out List_Id
)
1497 Pack_Spec
: constant Entity_Id
:= Corresponding_Spec
(Pack_Body
);
1504 pragma Assert
(Present
(Pack_Spec
));
1506 -- The different parts of the invariant procedure are inserted as
1509 -- package Pack is package body Pack is
1510 -- <IC spec> <IC body>
1513 -- end Pack; end Pack;
1515 -- The initial condition procedure spec is inserted in the visible
1516 -- declaration of the corresponding package spec.
1518 Extract_Package_Declaration_Lists
1519 (Pack_Decl
=> Unit_Declaration_Node
(Pack_Spec
),
1520 Body_List
=> Dummy_1
,
1521 Call_List
=> Dummy_2
,
1522 Spec_List
=> Spec_List
);
1524 -- The initial condition procedure body is added to the declarations
1525 -- of the package body.
1527 Body_List
:= Declarations
(Pack_Body
);
1529 if No
(Body_List
) then
1530 Body_List
:= New_List
;
1531 Set_Declarations
(Pack_Body
, Body_List
);
1534 -- The call to the initial condition procedure is inserted in the
1535 -- statements of the package body.
1537 HSS
:= Handled_Statement_Sequence
(Pack_Body
);
1541 Make_Handled_Sequence_Of_Statements
(Sloc
(Pack_Body
),
1542 Statements
=> New_List
);
1543 Set_Handled_Statement_Sequence
(Pack_Body
, HSS
);
1546 Call_List
:= Statements
(HSS
);
1547 end Extract_Package_Body_Lists
;
1549 ---------------------------------------
1550 -- Extract_Package_Declaration_Lists --
1551 ---------------------------------------
1553 procedure Extract_Package_Declaration_Lists
1554 (Pack_Decl
: Node_Id
;
1555 Body_List
: out List_Id
;
1556 Call_List
: out List_Id
;
1557 Spec_List
: out List_Id
)
1559 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
1562 -- The different parts of the invariant procedure are inserted as
1572 -- The initial condition procedure spec and body are inserted in the
1573 -- visible declarations of the package spec.
1575 Body_List
:= Visible_Declarations
(Pack_Spec
);
1577 if No
(Body_List
) then
1578 Body_List
:= New_List
;
1579 Set_Visible_Declarations
(Pack_Spec
, Body_List
);
1582 Spec_List
:= Body_List
;
1584 -- The call to the initial procedure is inserted in the private
1585 -- declarations of the package spec.
1587 Call_List
:= Private_Declarations
(Pack_Spec
);
1589 if No
(Call_List
) then
1590 Call_List
:= New_List
;
1591 Set_Private_Declarations
(Pack_Spec
, Call_List
);
1593 end Extract_Package_Declaration_Lists
;
1597 IC_Prag
: constant Node_Id
:=
1598 Get_Pragma
(Pack_Id
, Pragma_Initial_Condition
);
1600 Body_List
: List_Id
;
1602 Call_List
: List_Id
;
1603 Call_Loc
: Source_Ptr
;
1606 Proc_Body
: Node_Id
;
1607 Proc_Body_Id
: Entity_Id
;
1608 Proc_Decl
: Node_Id
;
1609 Proc_Id
: Entity_Id
;
1610 Spec_List
: List_Id
;
1612 -- Start of processing for Expand_Pragma_Initial_Condition
1615 -- Nothing to do when the package is not subject to an Initial_Condition
1618 if No
(IC_Prag
) then
1622 Expr
:= Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(IC_Prag
)));
1623 Loc
:= Sloc
(IC_Prag
);
1625 -- Nothing to do when the pragma or its argument are illegal because
1626 -- there is no valid expression to check.
1628 if Error_Posted
(IC_Prag
) or else Error_Posted
(Expr
) then
1632 -- Obtain the various lists of the context where the individual pieces
1633 -- of the initial condition procedure are to be inserted.
1635 if Nkind
(N
) = N_Package_Body
then
1636 Extract_Package_Body_Lists
1638 Body_List
=> Body_List
,
1639 Call_List
=> Call_List
,
1640 Spec_List
=> Spec_List
);
1642 elsif Nkind
(N
) = N_Package_Declaration
then
1643 Extract_Package_Declaration_Lists
1645 Body_List
=> Body_List
,
1646 Call_List
=> Call_List
,
1647 Spec_List
=> Spec_List
);
1649 -- This routine should not be used on anything other than packages
1652 pragma Assert
(False);
1657 Make_Defining_Identifier
(Loc
,
1658 Chars
=> New_External_Name
(Chars
(Pack_Id
), "Initial_Condition"));
1660 Set_Ekind
(Proc_Id
, E_Procedure
);
1661 Set_Is_Initial_Condition_Procedure
(Proc_Id
);
1664 -- procedure <Pack_Id>Initial_Condition;
1667 Make_Subprogram_Declaration
(Loc
,
1668 Make_Procedure_Specification
(Loc
,
1669 Defining_Unit_Name
=> Proc_Id
));
1671 Append_To
(Spec_List
, Proc_Decl
);
1673 -- The initial condition procedure requires debug info when initial
1674 -- condition is subject to Source Coverage Obligations.
1676 if Generate_SCO
then
1677 Set_Needs_Debug_Info
(Proc_Id
);
1681 -- procedure <Pack_Id>Initial_Condition is
1683 -- pragma Check (Initial_Condition, <Expr>);
1684 -- end <Pack_Id>Initial_Condition;
1687 Make_Subprogram_Body
(Loc
,
1689 Copy_Subprogram_Spec
(Specification
(Proc_Decl
)),
1690 Declarations
=> Empty_List
,
1691 Handled_Statement_Sequence
=>
1692 Make_Handled_Sequence_Of_Statements
(Loc
,
1693 Statements
=> New_List
(
1695 Chars
=> Name_Check
,
1696 Pragma_Argument_Associations
=> New_List
(
1697 Make_Pragma_Argument_Association
(Loc
,
1699 Make_Identifier
(Loc
, Name_Initial_Condition
)),
1700 Make_Pragma_Argument_Association
(Loc
,
1701 Expression
=> New_Copy_Tree
(Expr
)))))));
1703 Append_To
(Body_List
, Proc_Body
);
1705 -- The initial condition procedure requires debug info when initial
1706 -- condition is subject to Source Coverage Obligations.
1708 Proc_Body_Id
:= Defining_Entity
(Proc_Body
);
1710 if Generate_SCO
then
1711 Set_Needs_Debug_Info
(Proc_Body_Id
);
1714 -- The location of the initial condition procedure call must be as close
1715 -- as possible to the intended semantic location of the check because
1716 -- the ABE mechanism relies heavily on accurate locations.
1718 Call_Loc
:= End_Keyword_Location
(N
);
1721 -- <Pack_Id>Initial_Condition;
1724 Make_Procedure_Call_Statement
(Call_Loc
,
1725 Name
=> New_Occurrence_Of
(Proc_Id
, Call_Loc
));
1727 Append_To
(Call_List
, Call
);
1729 Analyze
(Proc_Decl
);
1730 Analyze
(Proc_Body
);
1732 end Expand_Pragma_Initial_Condition
;
1734 ------------------------------------
1735 -- Expand_Pragma_Inspection_Point --
1736 ------------------------------------
1738 -- If no argument is given, then we supply a default argument list that
1739 -- includes all objects declared at the source level in all subprograms
1740 -- that enclose the inspection point pragma.
1742 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
) is
1743 Loc
: constant Source_Ptr
:= Sloc
(N
);
1750 if No
(Pragma_Argument_Associations
(N
)) then
1754 while S
/= Standard_Standard
loop
1755 E
:= First_Entity
(S
);
1756 while Present
(E
) loop
1757 if Comes_From_Source
(E
)
1758 and then Is_Object
(E
)
1759 and then not Is_Entry_Formal
(E
)
1760 and then Ekind
(E
) /= E_Component
1761 and then Ekind
(E
) /= E_Discriminant
1762 and then Ekind
(E
) /= E_Generic_In_Parameter
1763 and then Ekind
(E
) /= E_Generic_In_Out_Parameter
1766 Make_Pragma_Argument_Association
(Loc
,
1767 Expression
=> New_Occurrence_Of
(E
, Loc
)));
1776 Set_Pragma_Argument_Associations
(N
, A
);
1779 -- Expand the arguments of the pragma. Expanding an entity reference
1780 -- is a noop, except in a protected operation, where a reference may
1781 -- have to be transformed into a reference to the corresponding prival.
1782 -- Are there other pragmas that may require this ???
1784 Assoc
:= First
(Pragma_Argument_Associations
(N
));
1785 while Present
(Assoc
) loop
1786 Expand
(Expression
(Assoc
));
1789 end Expand_Pragma_Inspection_Point
;
1791 --------------------------------------
1792 -- Expand_Pragma_Interrupt_Priority --
1793 --------------------------------------
1795 -- Supply default argument if none exists (System.Interrupt_Priority'Last)
1797 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
) is
1798 Loc
: constant Source_Ptr
:= Sloc
(N
);
1800 if No
(Pragma_Argument_Associations
(N
)) then
1801 Set_Pragma_Argument_Associations
(N
, New_List
(
1802 Make_Pragma_Argument_Association
(Loc
,
1804 Make_Attribute_Reference
(Loc
,
1806 New_Occurrence_Of
(RTE
(RE_Interrupt_Priority
), Loc
),
1807 Attribute_Name
=> Name_Last
))));
1809 end Expand_Pragma_Interrupt_Priority
;
1811 --------------------------------
1812 -- Expand_Pragma_Loop_Variant --
1813 --------------------------------
1815 -- Pragma Loop_Variant is expanded in the following manner:
1819 -- for | while ... loop
1820 -- <preceding source statements>
1821 -- pragma Loop_Variant
1822 -- (Increases => Incr_Expr,
1823 -- Decreases => Decr_Expr);
1824 -- <succeeding source statements>
1829 -- Curr_1 : <type of Incr_Expr>;
1830 -- Curr_2 : <type of Decr_Expr>;
1831 -- Old_1 : <type of Incr_Expr>;
1832 -- Old_2 : <type of Decr_Expr>;
1833 -- Flag : Boolean := False;
1835 -- for | while ... loop
1836 -- <preceding source statements>
1843 -- Curr_1 := <Incr_Expr>;
1844 -- Curr_2 := <Decr_Expr>;
1847 -- if Curr_1 /= Old_1 then
1848 -- pragma Check (Loop_Variant, Curr_1 > Old_1);
1850 -- pragma Check (Loop_Variant, Curr_2 < Old_2);
1856 -- <succeeding source statements>
1859 procedure Expand_Pragma_Loop_Variant
(N
: Node_Id
) is
1860 Loc
: constant Source_Ptr
:= Sloc
(N
);
1861 Last_Var
: constant Node_Id
:=
1862 Last
(Pragma_Argument_Associations
(N
));
1864 Curr_Assign
: List_Id
:= No_List
;
1865 Flag_Id
: Entity_Id
:= Empty
;
1866 If_Stmt
: Node_Id
:= Empty
;
1867 Old_Assign
: List_Id
:= No_List
;
1868 Loop_Scop
: Entity_Id
;
1869 Loop_Stmt
: Node_Id
;
1872 procedure Process_Variant
(Variant
: Node_Id
; Is_Last
: Boolean);
1873 -- Process a single increasing / decreasing termination variant. Flag
1874 -- Is_Last should be set when processing the last variant.
1876 ---------------------
1877 -- Process_Variant --
1878 ---------------------
1880 procedure Process_Variant
(Variant
: Node_Id
; Is_Last
: Boolean) is
1884 Old_Val
: Node_Id
) return Node_Id
;
1885 -- Generate a comparison between Curr_Val and Old_Val depending on
1886 -- the change mode (Increases / Decreases) of the variant.
1895 Old_Val
: Node_Id
) return Node_Id
1898 if Chars
(Variant
) = Name_Increases
then
1899 return Make_Op_Gt
(Loc
, Curr_Val
, Old_Val
);
1900 else pragma Assert
(Chars
(Variant
) = Name_Decreases
);
1901 return Make_Op_Lt
(Loc
, Curr_Val
, Old_Val
);
1907 Expr
: constant Node_Id
:= Expression
(Variant
);
1908 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
1909 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1910 Loop_Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
1911 Curr_Id
: Entity_Id
;
1915 -- Start of processing for Process_Variant
1918 -- All temporaries generated in this routine must be inserted before
1919 -- the related loop statement. Ensure that the proper scope is on the
1920 -- stack when analyzing the temporaries. Note that we also use the
1921 -- Sloc of the related loop.
1923 Push_Scope
(Scope
(Loop_Scop
));
1925 -- Step 1: Create the declaration of the flag which controls the
1926 -- behavior of the assertion on the first iteration of the loop.
1928 if No
(Flag_Id
) then
1931 -- Flag : Boolean := False;
1933 Flag_Id
:= Make_Temporary
(Loop_Loc
, 'F');
1935 Insert_Action
(Loop_Stmt
,
1936 Make_Object_Declaration
(Loop_Loc
,
1937 Defining_Identifier
=> Flag_Id
,
1938 Object_Definition
=>
1939 New_Occurrence_Of
(Standard_Boolean
, Loop_Loc
),
1941 New_Occurrence_Of
(Standard_False
, Loop_Loc
)));
1943 -- Prevent an unwanted optimization where the Current_Value of
1944 -- the flag eliminates the if statement which stores the variant
1945 -- values coming from the previous iteration.
1947 -- Flag : Boolean := False;
1949 -- if Flag then -- condition rewritten to False
1950 -- Old_N := Curr_N; -- and if statement eliminated
1956 Set_Current_Value
(Flag_Id
, Empty
);
1959 -- Step 2: Create the temporaries which store the old and current
1960 -- values of the associated expression.
1963 -- Curr : <type of Expr>;
1965 Curr_Id
:= Make_Temporary
(Loc
, 'C');
1967 Insert_Action
(Loop_Stmt
,
1968 Make_Object_Declaration
(Loop_Loc
,
1969 Defining_Identifier
=> Curr_Id
,
1970 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loop_Loc
)));
1973 -- Old : <type of Expr>;
1975 Old_Id
:= Make_Temporary
(Loc
, 'P');
1977 Insert_Action
(Loop_Stmt
,
1978 Make_Object_Declaration
(Loop_Loc
,
1979 Defining_Identifier
=> Old_Id
,
1980 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loop_Loc
)));
1982 -- Restore original scope after all temporaries have been analyzed
1986 -- Step 3: Store value of the expression from the previous iteration
1988 if No
(Old_Assign
) then
1989 Old_Assign
:= New_List
;
1995 Append_To
(Old_Assign
,
1996 Make_Assignment_Statement
(Loc
,
1997 Name
=> New_Occurrence_Of
(Old_Id
, Loc
),
1998 Expression
=> New_Occurrence_Of
(Curr_Id
, Loc
)));
2000 -- Step 4: Store the current value of the expression
2002 if No
(Curr_Assign
) then
2003 Curr_Assign
:= New_List
;
2009 Append_To
(Curr_Assign
,
2010 Make_Assignment_Statement
(Loc
,
2011 Name
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2012 Expression
=> Relocate_Node
(Expr
)));
2014 -- Step 5: Create corresponding assertion to verify change of value
2017 -- pragma Check (Loop_Variant, Curr <|> Old);
2021 Chars
=> Name_Check
,
2022 Pragma_Argument_Associations
=> New_List
(
2023 Make_Pragma_Argument_Association
(Loc
,
2024 Expression
=> Make_Identifier
(Loc
, Name_Loop_Variant
)),
2025 Make_Pragma_Argument_Association
(Loc
,
2028 Curr_Val
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2029 Old_Val
=> New_Occurrence_Of
(Old_Id
, Loc
)))));
2032 -- if Curr /= Old then
2035 if No
(If_Stmt
) then
2037 -- When there is just one termination variant, do not compare the
2038 -- old and current value for equality, just check the pragma.
2044 Make_If_Statement
(Loc
,
2047 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2048 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
2049 Then_Statements
=> New_List
(Prag
));
2058 Set_Else_Statements
(If_Stmt
, New_List
(Prag
));
2061 -- elsif Curr /= Old then
2065 if Elsif_Parts
(If_Stmt
) = No_List
then
2066 Set_Elsif_Parts
(If_Stmt
, New_List
);
2069 Append_To
(Elsif_Parts
(If_Stmt
),
2070 Make_Elsif_Part
(Loc
,
2073 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
2074 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
2075 Then_Statements
=> New_List
(Prag
)));
2077 end Process_Variant
;
2079 -- Start of processing for Expand_Pragma_Loop_Variant
2082 -- If pragma is not enabled, rewrite as Null statement. If pragma is
2083 -- disabled, it has already been rewritten as a Null statement.
2085 if Is_Ignored
(N
) then
2086 Rewrite
(N
, Make_Null_Statement
(Loc
));
2091 -- The expansion of Loop_Variant is quite distributed as it produces
2092 -- various statements to capture and compare the arguments. To preserve
2093 -- the original context, set the Is_Assertion_Expr flag. This aids the
2094 -- Ghost legality checks when verifying the placement of a reference to
2097 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
2099 -- Locate the enclosing loop for which this assertion applies. In the
2100 -- case of Ada 2012 array iteration, we might be dealing with nested
2101 -- loops. Only the outermost loop has an identifier.
2104 while Present
(Loop_Stmt
) loop
2105 if Nkind
(Loop_Stmt
) = N_Loop_Statement
2106 and then Present
(Identifier
(Loop_Stmt
))
2111 Loop_Stmt
:= Parent
(Loop_Stmt
);
2114 Loop_Scop
:= Entity
(Identifier
(Loop_Stmt
));
2116 -- Create the circuitry which verifies individual variants
2118 Variant
:= First
(Pragma_Argument_Associations
(N
));
2119 while Present
(Variant
) loop
2120 Process_Variant
(Variant
, Is_Last
=> Variant
= Last_Var
);
2124 -- Construct the segment which stores the old values of all expressions.
2131 Make_If_Statement
(Loc
,
2132 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
2133 Then_Statements
=> Old_Assign
));
2135 -- Update the values of all expressions
2137 Insert_Actions
(N
, Curr_Assign
);
2139 -- Add the assertion circuitry to test all changes in expressions.
2148 Make_If_Statement
(Loc
,
2149 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
2150 Then_Statements
=> New_List
(If_Stmt
),
2151 Else_Statements
=> New_List
(
2152 Make_Assignment_Statement
(Loc
,
2153 Name
=> New_Occurrence_Of
(Flag_Id
, Loc
),
2154 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
2156 -- Note: the pragma has been completely transformed into a sequence of
2157 -- corresponding declarations and statements. We leave it in the tree
2158 -- for documentation purposes. It will be ignored by the backend.
2160 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
2161 end Expand_Pragma_Loop_Variant
;
2163 --------------------------------
2164 -- Expand_Pragma_Psect_Object --
2165 --------------------------------
2167 -- Convert to Common_Object, and expand the resulting pragma
2169 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
)
2170 renames Expand_Pragma_Common_Object
;
2172 -------------------------------------
2173 -- Expand_Pragma_Relative_Deadline --
2174 -------------------------------------
2176 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
) is
2177 P
: constant Node_Id
:= Parent
(N
);
2178 Loc
: constant Source_Ptr
:= Sloc
(N
);
2181 -- Expand the pragma only in the case of the main subprogram. For tasks
2182 -- the expansion is done in exp_ch9. Generate a call to Set_Deadline
2183 -- at Clock plus the relative deadline specified in the pragma. Time
2184 -- values are translated into Duration to allow for non-private
2185 -- addition operation.
2187 if Nkind
(P
) = N_Subprogram_Body
then
2190 Make_Procedure_Call_Statement
(Loc
,
2191 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Deadline
), Loc
),
2192 Parameter_Associations
=> New_List
(
2193 Unchecked_Convert_To
(RTE
(RO_RT_Time
),
2196 Make_Function_Call
(Loc
,
2197 New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
2200 (Loc
, New_Occurrence_Of
(RTE
(RE_Clock
), Loc
)))),
2202 Unchecked_Convert_To
(Standard_Duration
, Arg1
(N
)))))));
2206 end Expand_Pragma_Relative_Deadline
;
2208 -------------------------------------------
2209 -- Expand_Pragma_Suppress_Initialization --
2210 -------------------------------------------
2212 procedure Expand_Pragma_Suppress_Initialization
(N
: Node_Id
) is
2213 Def_Id
: constant Entity_Id
:= Entity
(Arg1
(N
));
2216 -- Variable case (we have to undo any initialization already done)
2218 if Ekind
(Def_Id
) = E_Variable
then
2219 Undo_Initialization
(Def_Id
, N
);
2221 end Expand_Pragma_Suppress_Initialization
;
2223 -------------------------
2224 -- Undo_Initialization --
2225 -------------------------
2227 procedure Undo_Initialization
(Def_Id
: Entity_Id
; N
: Node_Id
) is
2228 Init_Call
: Node_Id
;
2231 -- When applied to a variable, the default initialization must not be
2232 -- done. As it is already done when the pragma is found, we just get rid
2233 -- of the call the initialization procedure which followed the object
2234 -- declaration. The call is inserted after the declaration, but validity
2235 -- checks may also have been inserted and thus the initialization call
2236 -- does not necessarily appear immediately after the object declaration.
2238 -- We can't use the freezing mechanism for this purpose, since we have
2239 -- to elaborate the initialization expression when it is first seen (so
2240 -- this elaboration cannot be deferred to the freeze point).
2242 -- Find and remove generated initialization call for object, if any
2244 Init_Call
:= Remove_Init_Call
(Def_Id
, Rep_Clause
=> N
);
2246 -- Any default initialization expression should be removed (e.g.
2247 -- null defaults for access objects, zero initialization of packed
2248 -- bit arrays). Imported objects aren't allowed to have explicit
2249 -- initialization, so the expression must have been generated by
2252 if No
(Init_Call
) and then Present
(Expression
(Parent
(Def_Id
))) then
2253 Set_Expression
(Parent
(Def_Id
), Empty
);
2256 -- The object may not have any initialization, but in the presence of
2257 -- Initialize_Scalars code is inserted after then declaration, which
2258 -- must now be removed as well. The code carries the same source
2259 -- location as the declaration itself.
2261 if Initialize_Scalars
and then Is_Array_Type
(Etype
(Def_Id
)) then
2266 Init
:= Next
(Parent
(Def_Id
));
2267 while not Comes_From_Source
(Init
)
2268 and then Sloc
(Init
) = Sloc
(Def_Id
)
2276 end Undo_Initialization
;