1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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 Namet
; use Namet
;
36 with Nlists
; use Nlists
;
37 with Nmake
; use Nmake
;
39 with Restrict
; use Restrict
;
40 with Rident
; use Rident
;
41 with Rtsfind
; use Rtsfind
;
43 with Sem_Ch8
; use Sem_Ch8
;
44 with Sem_Util
; use Sem_Util
;
45 with Sinfo
; use Sinfo
;
46 with Sinput
; use Sinput
;
47 with Snames
; use Snames
;
48 with Stringt
; use Stringt
;
49 with Stand
; use Stand
;
50 with Tbuild
; use Tbuild
;
51 with Uintp
; use Uintp
;
52 with Validsw
; use Validsw
;
54 package body Exp_Prag
is
56 -----------------------
57 -- Local Subprograms --
58 -----------------------
60 function Arg1
(N
: Node_Id
) return Node_Id
;
61 function Arg2
(N
: Node_Id
) return Node_Id
;
62 function Arg3
(N
: Node_Id
) return Node_Id
;
63 -- Obtain specified pragma argument expression
65 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
);
66 procedure Expand_Pragma_Check
(N
: Node_Id
);
67 procedure Expand_Pragma_Common_Object
(N
: Node_Id
);
68 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
);
69 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
);
70 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
);
71 procedure Expand_Pragma_Loop_Variant
(N
: Node_Id
);
72 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
);
73 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
);
74 procedure Expand_Pragma_Suppress_Initialization
(N
: Node_Id
);
76 procedure Undo_Initialization
(Def_Id
: Entity_Id
; N
: Node_Id
);
77 -- This procedure is used to undo initialization already done for Def_Id,
78 -- which is always an E_Variable, in response to the occurrence of the
79 -- pragma N, a pragma Interface, Import, or Suppress_Initialization. In all
80 -- these cases we want no initialization to occur, but we have already done
81 -- the initialization by the time we see the pragma, so we have to undo it.
87 function Arg1
(N
: Node_Id
) return Node_Id
is
88 Arg
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
91 and then Nkind
(Arg
) = N_Pragma_Argument_Association
93 return Expression
(Arg
);
103 function Arg2
(N
: Node_Id
) return Node_Id
is
104 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
112 Arg
: constant Node_Id
:= Next
(Arg1
);
115 and then Nkind
(Arg
) = N_Pragma_Argument_Association
117 return Expression
(Arg
);
129 function Arg3
(N
: Node_Id
) return Node_Id
is
130 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
138 Arg
: Node_Id
:= Next
(Arg1
);
147 and then Nkind
(Arg
) = N_Pragma_Argument_Association
149 return Expression
(Arg
);
158 ---------------------------
159 -- Expand_Contract_Cases --
160 ---------------------------
162 -- Pragma Contract_Cases is expanded in the following manner:
165 -- Count : Natural := 0;
166 -- Flag_1 : Boolean := False;
168 -- Flag_N : Boolean := False;
169 -- Flag_N+1 : Boolean := False; -- when "others" present
174 -- <preconditions (if any)>
176 -- -- Evaluate all case guards
178 -- if Case_Guard_1 then
180 -- Count := Count + 1;
183 -- if Case_Guard_N then
185 -- Count := Count + 1;
188 -- -- Emit errors depending on the number of case guards that
189 -- -- evaluated to True.
192 -- raise Assertion_Error with "xxx contract cases incomplete";
194 -- Flag_N+1 := True; -- when "others" present
196 -- elsif Count > 1 then
198 -- Str0 : constant String :=
199 -- "contract cases overlap for subprogram ABC";
200 -- Str1 : constant String :=
202 -- Str0 & "case guard at xxx evaluates to True"
204 -- StrN : constant String :=
206 -- StrN-1 & "case guard at xxx evaluates to True"
209 -- raise Assertion_Error with StrN;
213 -- -- Evaluate all attribute 'Old prefixes found in the selected
217 -- Pref_1 := <prefix of 'Old found in Consequence_1>
220 -- Pref_M := <prefix of 'Old found in Consequence_N>
223 -- procedure _Postconditions is
225 -- <postconditions (if any)>
227 -- if Flag_1 and then not Consequence_1 then
228 -- raise Assertion_Error with "failed contract case at xxx";
231 -- if Flag_N[+1] and then not Consequence_N[+1] then
232 -- raise Assertion_Error with "failed contract case at xxx";
234 -- end _Postconditions;
239 procedure Expand_Contract_Cases
243 Stmts
: in out List_Id
)
245 Loc
: constant Source_Ptr
:= Sloc
(CCs
);
247 procedure Case_Guard_Error
250 Error_Loc
: Source_Ptr
;
251 Msg
: in out Entity_Id
);
252 -- Given a declarative list Decls, status flag Flag, the location of the
253 -- error and a string Msg, construct the following check:
254 -- Msg : constant String :=
256 -- Msg & "case guard at Error_Loc evaluates to True"
258 -- The resulting code is added to Decls
260 procedure Consequence_Error
261 (Checks
: in out Node_Id
;
264 -- Given an if statement Checks, status flag Flag and a consequence
265 -- Conseq, construct the following check:
266 -- [els]if Flag and then not Conseq then
267 -- raise Assertion_Error
268 -- with "failed contract case at Sloc (Conseq)";
270 -- The resulting code is added to Checks
272 function Declaration_Of
(Id
: Entity_Id
) return Node_Id
;
273 -- Given the entity Id of a boolean flag, generate:
274 -- Id : Boolean := False;
276 procedure Expand_Old_In_Consequence
278 Evals
: in out Node_Id
;
281 -- Perform specialized expansion of all attribute 'Old references found
282 -- in consequence Conseq such that at runtime only prefixes coming from
283 -- the selected consequence are evaluated. Any temporaries generated in
284 -- the process are added to declarative list Decls. Evals is a complex
285 -- if statement tasked with the evaluation of all prefixes coming from
286 -- a selected consequence. Flag is the corresponding case guard flag.
287 -- Conseq is the consequence expression.
289 function Increment
(Id
: Entity_Id
) return Node_Id
;
290 -- Given the entity Id of a numerical variable, generate:
293 function Set
(Id
: Entity_Id
) return Node_Id
;
294 -- Given the entity Id of a boolean variable, generate:
297 ----------------------
298 -- Case_Guard_Error --
299 ----------------------
301 procedure Case_Guard_Error
304 Error_Loc
: Source_Ptr
;
305 Msg
: in out Entity_Id
)
307 New_Line
: constant Character := Character'Val (10);
308 New_Msg
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
312 Store_String_Char
(New_Line
);
313 Store_String_Chars
(" case guard at ");
314 Store_String_Chars
(Build_Location_String
(Error_Loc
));
315 Store_String_Chars
(" evaluates to True");
318 -- New_Msg : constant String :=
320 -- Msg & "case guard at Error_Loc evaluates to True"
324 Make_Object_Declaration
(Loc
,
325 Defining_Identifier
=> New_Msg
,
326 Constant_Present
=> True,
327 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
329 Make_If_Expression
(Loc
,
330 Expressions
=> New_List
(
331 New_Occurrence_Of
(Flag
, Loc
),
334 Left_Opnd
=> New_Occurrence_Of
(Msg
, Loc
),
335 Right_Opnd
=> Make_String_Literal
(Loc
, End_String
)),
337 New_Occurrence_Of
(Msg
, Loc
)))));
340 end Case_Guard_Error
;
342 -----------------------
343 -- Consequence_Error --
344 -----------------------
346 procedure Consequence_Error
347 (Checks
: in out Node_Id
;
356 -- Flag and then not Conseq
360 Left_Opnd
=> New_Occurrence_Of
(Flag
, Loc
),
363 Right_Opnd
=> Relocate_Node
(Conseq
)));
366 -- raise Assertion_Error
367 -- with "failed contract case at Sloc (Conseq)";
370 Store_String_Chars
("failed contract case at ");
371 Store_String_Chars
(Build_Location_String
(Sloc
(Conseq
)));
374 Make_Procedure_Call_Statement
(Loc
,
376 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
377 Parameter_Associations
=> New_List
(
378 Make_String_Literal
(Loc
, End_String
)));
382 Make_Implicit_If_Statement
(CCs
,
384 Then_Statements
=> New_List
(Error
));
387 if No
(Elsif_Parts
(Checks
)) then
388 Set_Elsif_Parts
(Checks
, New_List
);
391 Append_To
(Elsif_Parts
(Checks
),
392 Make_Elsif_Part
(Loc
,
394 Then_Statements
=> New_List
(Error
)));
396 end Consequence_Error
;
402 function Declaration_Of
(Id
: Entity_Id
) return Node_Id
is
405 Make_Object_Declaration
(Loc
,
406 Defining_Identifier
=> Id
,
407 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
408 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
));
411 -------------------------------
412 -- Expand_Old_In_Consequence --
413 -------------------------------
415 procedure Expand_Old_In_Consequence
417 Evals
: in out Node_Id
;
421 Eval_Stmts
: List_Id
:= No_List
;
422 -- The evaluation sequence expressed as assignment statements of all
423 -- prefixes of attribute 'Old found in the current consequence.
425 function Expand_Old
(N
: Node_Id
) return Traverse_Result
;
426 -- Determine whether an arbitrary node denotes attribute 'Old and if
427 -- it does, perform all expansion-related actions.
433 function Expand_Old
(N
: Node_Id
) return Traverse_Result
is
439 if Nkind
(N
) = N_Attribute_Reference
440 and then Attribute_Name
(N
) = Name_Old
443 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
444 Set_Etype
(Temp
, Etype
(Pref
));
446 -- Generate a temporary to capture the value of the prefix:
447 -- Temp : <Pref type>;
448 -- Place that temporary at the beginning of declarations, to
449 -- prevent anomalies in the GNATprove flow-analysis pass in
450 -- the precondition procedure that follows.
453 Make_Object_Declaration
(Loc
,
454 Defining_Identifier
=> Temp
,
456 New_Occurrence_Of
(Etype
(Pref
), Loc
));
457 Set_No_Initialization
(Decl
);
459 Prepend_To
(Decls
, Decl
);
461 -- Evaluate the prefix, generate:
464 if No
(Eval_Stmts
) then
465 Eval_Stmts
:= New_List
;
468 Append_To
(Eval_Stmts
,
469 Make_Assignment_Statement
(Loc
,
470 Name
=> New_Occurrence_Of
(Temp
, Loc
),
471 Expression
=> Pref
));
473 -- Ensure that the prefix is valid
475 if Validity_Checks_On
and then Validity_Check_Operands
then
479 -- Replace the original attribute 'Old by a reference to the
480 -- generated temporary.
482 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
488 procedure Expand_Olds
is new Traverse_Proc
(Expand_Old
);
490 -- Start of processing for Expand_Old_In_Consequence
493 -- Inspect the consequence and expand any attribute 'Old references
496 Expand_Olds
(Conseq
);
498 -- Augment the machinery to trigger the evaluation of all prefixes
499 -- found in the step above. If Eval is empty, then this is the first
500 -- consequence to yield expansion of 'Old. Generate:
503 -- <evaluation statements>
508 Make_Implicit_If_Statement
(CCs
,
509 Condition
=> New_Occurrence_Of
(Flag
, Loc
),
510 Then_Statements
=> Eval_Stmts
);
512 -- Otherwise generate:
514 -- <evaluation statements>
518 if No
(Elsif_Parts
(Evals
)) then
519 Set_Elsif_Parts
(Evals
, New_List
);
522 Append_To
(Elsif_Parts
(Evals
),
523 Make_Elsif_Part
(Loc
,
524 Condition
=> New_Occurrence_Of
(Flag
, Loc
),
525 Then_Statements
=> Eval_Stmts
));
527 end Expand_Old_In_Consequence
;
533 function Increment
(Id
: Entity_Id
) return Node_Id
is
536 Make_Assignment_Statement
(Loc
,
537 Name
=> New_Occurrence_Of
(Id
, Loc
),
540 Left_Opnd
=> New_Occurrence_Of
(Id
, Loc
),
541 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
548 function Set
(Id
: Entity_Id
) return Node_Id
is
551 Make_Assignment_Statement
(Loc
,
552 Name
=> New_Occurrence_Of
(Id
, Loc
),
553 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
558 Aggr
: constant Node_Id
:=
560 (Pragma_Argument_Associations
(CCs
)));
561 Case_Guard
: Node_Id
;
565 Conseq_Checks
: Node_Id
:= Empty
;
567 Error_Decls
: List_Id
;
570 Multiple_PCs
: Boolean;
571 Old_Evals
: Node_Id
:= Empty
;
572 Others_Flag
: Entity_Id
:= Empty
;
575 -- Start of processing for Expand_Contract_Cases
578 -- Do nothing if pragma is not enabled. If pragma is disabled, it has
579 -- already been rewritten as a Null statement.
581 if Is_Ignored
(CCs
) then
584 -- Guard against malformed contract cases
586 elsif Nkind
(Aggr
) /= N_Aggregate
then
590 Multiple_PCs
:= List_Length
(Component_Associations
(Aggr
)) > 1;
592 -- Create the counter which tracks the number of case guards that
595 -- Count : Natural := 0;
597 Count
:= Make_Temporary
(Loc
, 'C');
600 Make_Object_Declaration
(Loc
,
601 Defining_Identifier
=> Count
,
602 Object_Definition
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
603 Expression
=> Make_Integer_Literal
(Loc
, 0)));
605 -- Create the base error message for multiple overlapping case guards
607 -- Msg_Str : constant String :=
608 -- "contract cases overlap for subprogram Subp_Id";
611 Msg_Str
:= Make_Temporary
(Loc
, 'S');
614 Store_String_Chars
("contract cases overlap for subprogram ");
615 Store_String_Chars
(Get_Name_String
(Chars
(Subp_Id
)));
617 Error_Decls
:= New_List
(
618 Make_Object_Declaration
(Loc
,
619 Defining_Identifier
=> Msg_Str
,
620 Constant_Present
=> True,
621 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
622 Expression
=> Make_String_Literal
(Loc
, End_String
)));
625 -- Process individual post cases
627 Post_Case
:= First
(Component_Associations
(Aggr
));
628 while Present
(Post_Case
) loop
629 Case_Guard
:= First
(Choices
(Post_Case
));
630 Conseq
:= Expression
(Post_Case
);
632 -- The "others" choice requires special processing
634 if Nkind
(Case_Guard
) = N_Others_Choice
then
635 Others_Flag
:= Make_Temporary
(Loc
, 'F');
636 Prepend_To
(Decls
, Declaration_Of
(Others_Flag
));
638 -- Check possible overlap between a case guard and "others"
640 if Multiple_PCs
and Exception_Extra_Info
then
642 (Decls
=> Error_Decls
,
644 Error_Loc
=> Sloc
(Case_Guard
),
648 -- Inspect the consequence and perform special expansion of any
649 -- attribute 'Old references found within.
651 Expand_Old_In_Consequence
657 -- Check the corresponding consequence of "others"
660 (Checks
=> Conseq_Checks
,
667 -- Create the flag which tracks the state of its associated case
670 Flag
:= Make_Temporary
(Loc
, 'F');
671 Prepend_To
(Decls
, Declaration_Of
(Flag
));
673 -- The flag is set when the case guard is evaluated to True
674 -- if Case_Guard then
676 -- Count := Count + 1;
680 Make_Implicit_If_Statement
(CCs
,
681 Condition
=> Relocate_Node
(Case_Guard
),
682 Then_Statements
=> New_List
(
684 Increment
(Count
))));
686 -- Check whether this case guard overlaps with another one
688 if Multiple_PCs
and Exception_Extra_Info
then
690 (Decls
=> Error_Decls
,
692 Error_Loc
=> Sloc
(Case_Guard
),
696 -- Inspect the consequence and perform special expansion of any
697 -- attribute 'Old references found within.
699 Expand_Old_In_Consequence
705 -- The corresponding consequence of the case guard which evaluated
706 -- to True must hold on exit from the subprogram.
709 (Checks
=> Conseq_Checks
,
717 -- Raise Assertion_Error when none of the case guards evaluate to True.
718 -- The only exception is when we have "others", in which case there is
719 -- no error because "others" acts as a default True.
724 if Present
(Others_Flag
) then
725 CG_Stmts
:= New_List
(Set
(Others_Flag
));
728 -- raise Assertion_Error with "xxx contract cases incomplete";
732 Store_String_Chars
(Build_Location_String
(Loc
));
733 Store_String_Chars
(" contract cases incomplete");
735 CG_Stmts
:= New_List
(
736 Make_Procedure_Call_Statement
(Loc
,
738 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
739 Parameter_Associations
=> New_List
(
740 Make_String_Literal
(Loc
, End_String
))));
744 Make_Implicit_If_Statement
(CCs
,
747 Left_Opnd
=> New_Occurrence_Of
(Count
, Loc
),
748 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
749 Then_Statements
=> CG_Stmts
);
751 -- Detect a possible failure due to several case guards evaluating to
755 -- elsif Count > 0 then
759 -- raise Assertion_Error with <Msg_Str>;
763 Set_Elsif_Parts
(CG_Checks
, New_List
(
764 Make_Elsif_Part
(Loc
,
767 Left_Opnd
=> New_Occurrence_Of
(Count
, Loc
),
768 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)),
770 Then_Statements
=> New_List
(
771 Make_Block_Statement
(Loc
,
772 Declarations
=> Error_Decls
,
773 Handled_Statement_Sequence
=>
774 Make_Handled_Sequence_Of_Statements
(Loc
,
775 Statements
=> New_List
(
776 Make_Procedure_Call_Statement
(Loc
,
779 (RTE
(RE_Raise_Assert_Failure
), Loc
),
780 Parameter_Associations
=> New_List
(
781 New_Occurrence_Of
(Msg_Str
, Loc
))))))))));
784 Append_To
(Decls
, CG_Checks
);
786 -- Once all case guards are evaluated and checked, evaluate any prefixes
787 -- of attribute 'Old founds in the selected consequence.
789 Append_To
(Decls
, Old_Evals
);
791 -- Raise Assertion_Error when the corresponding consequence of a case
792 -- guard that evaluated to True fails.
798 Append_To
(Stmts
, Conseq_Checks
);
799 end Expand_Contract_Cases
;
801 ---------------------
802 -- Expand_N_Pragma --
803 ---------------------
805 procedure Expand_N_Pragma
(N
: Node_Id
) is
806 Pname
: constant Name_Id
:= Pragma_Name
(N
);
809 -- Note: we may have a pragma whose Pragma_Identifier field is not a
810 -- recognized pragma, and we must ignore it at this stage.
812 if Is_Pragma_Name
(Pname
) then
813 case Get_Pragma_Id
(Pname
) is
815 -- Pragmas requiring special expander action
817 when Pragma_Abort_Defer
=>
818 Expand_Pragma_Abort_Defer
(N
);
821 Expand_Pragma_Check
(N
);
823 when Pragma_Common_Object
=>
824 Expand_Pragma_Common_Object
(N
);
826 when Pragma_Import
=>
827 Expand_Pragma_Import_Or_Interface
(N
);
829 when Pragma_Inspection_Point
=>
830 Expand_Pragma_Inspection_Point
(N
);
832 when Pragma_Interface
=>
833 Expand_Pragma_Import_Or_Interface
(N
);
835 when Pragma_Interrupt_Priority
=>
836 Expand_Pragma_Interrupt_Priority
(N
);
838 when Pragma_Loop_Variant
=>
839 Expand_Pragma_Loop_Variant
(N
);
841 when Pragma_Psect_Object
=>
842 Expand_Pragma_Psect_Object
(N
);
844 when Pragma_Relative_Deadline
=>
845 Expand_Pragma_Relative_Deadline
(N
);
847 when Pragma_Suppress_Initialization
=>
848 Expand_Pragma_Suppress_Initialization
(N
);
850 -- All other pragmas need no expander action
858 -------------------------------
859 -- Expand_Pragma_Abort_Defer --
860 -------------------------------
862 -- An Abort_Defer pragma appears as the first statement in a handled
863 -- statement sequence (right after the begin). It defers aborts for
864 -- the entire statement sequence, but not for any declarations or
865 -- handlers (if any) associated with this statement sequence.
867 -- The transformation is to transform
869 -- pragma Abort_Defer;
878 -- when all others =>
879 -- Abort_Undefer.all;
882 -- Abort_Undefer_Direct;
885 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
) is
886 Loc
: constant Source_Ptr
:= Sloc
(N
);
890 Blk
: constant Entity_Id
:=
891 New_Internal_Entity
(E_Block
, Current_Scope
, Sloc
(N
), 'B');
894 Stms
:= New_List
(Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
897 Stm
:= Remove_Next
(N
);
903 Make_Handled_Sequence_Of_Statements
(Loc
,
906 New_Occurrence_Of
(RTE
(RE_Abort_Undefer_Direct
), Loc
));
909 Make_Block_Statement
(Loc
,
910 Handled_Statement_Sequence
=> HSS
));
912 Set_Scope
(Blk
, Current_Scope
);
913 Set_Etype
(Blk
, Standard_Void_Type
);
914 Set_Identifier
(N
, New_Occurrence_Of
(Blk
, Sloc
(N
)));
915 Expand_At_End_Handler
(HSS
, Blk
);
917 end Expand_Pragma_Abort_Defer
;
919 --------------------------
920 -- Expand_Pragma_Check --
921 --------------------------
923 procedure Expand_Pragma_Check
(N
: Node_Id
) is
924 Cond
: constant Node_Id
:= Arg2
(N
);
925 Nam
: constant Name_Id
:= Chars
(Arg1
(N
));
928 Loc
: constant Source_Ptr
:= Sloc
(First_Node
(Cond
));
929 -- Source location used in the case of a failed assertion: point to the
930 -- failing condition, not Loc. Note that the source location of the
931 -- expression is not usually the best choice here, because it points to
932 -- the location of the topmost tree node, which may be an operator in
933 -- the middle of the source text of the expression. For example, it gets
934 -- located on the last AND keyword in a chain of boolean expressiond
935 -- AND'ed together. It is best to put the message on the first character
936 -- of the condition, which is the effect of the First_Node call here.
937 -- This source location is used to build the default exception message,
938 -- and also as the sloc of the call to the runtime subprogram raising
939 -- Assert_Failure, so that coverage analysis tools can relate the
940 -- call to the failed check.
943 -- Nothing to do if pragma is ignored
945 if Is_Ignored
(N
) then
949 -- Since this check is active, we rewrite the pragma into a
950 -- corresponding if statement, and then analyze the statement
952 -- The normal case expansion transforms:
954 -- pragma Check (name, condition [,message]);
958 -- if not condition then
959 -- System.Assertions.Raise_Assert_Failure (Str);
962 -- where Str is the message if one is present, or the default of
963 -- name failed at file:line if no message is given (the "name failed
964 -- at" is omitted for name = Assertion, since it is redundant, given
965 -- that the name of the exception is Assert_Failure.)
967 -- Also, instead of "XXX failed at", we generate slightly
968 -- different messages for some of the contract assertions (see
969 -- code below for details).
971 -- An alternative expansion is used when the No_Exception_Propagation
972 -- restriction is active and there is a local Assert_Failure handler.
973 -- This is not a common combination of circumstances, but it occurs in
974 -- the context of Aunit and the zero footprint profile. In this case we
977 -- if not condition then
978 -- raise Assert_Failure;
981 -- This will then be transformed into a goto, and the local handler will
982 -- be able to handle the assert error (which would not be the case if a
983 -- call is made to the Raise_Assert_Failure procedure).
985 -- We also generate the direct raise if the Suppress_Exception_Locations
986 -- is active, since we don't want to generate messages in this case.
988 -- Note that the reason we do not always generate a direct raise is that
989 -- the form in which the procedure is called allows for more efficient
990 -- breakpointing of assertion errors.
992 -- Generate the appropriate if statement. Note that we consider this to
993 -- be an explicit conditional in the source, not an implicit if, so we
994 -- do not call Make_Implicit_If_Statement.
996 -- Case where we generate a direct raise
998 if ((Debug_Flag_Dot_G
999 or else Restriction_Active
(No_Exception_Propagation
))
1000 and then Present
(Find_Local_Handler
(RTE
(RE_Assert_Failure
), N
)))
1001 or else (Opt
.Exception_Locations_Suppressed
and then No
(Arg3
(N
)))
1004 Make_If_Statement
(Loc
,
1005 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Cond
),
1006 Then_Statements
=> New_List
(
1007 Make_Raise_Statement
(Loc
,
1008 Name
=> New_Occurrence_Of
(RTE
(RE_Assert_Failure
), Loc
)))));
1010 -- Case where we call the procedure
1013 -- If we have a message given, use it
1015 if Present
(Arg3
(N
)) then
1016 Msg
:= Get_Pragma_Arg
(Arg3
(N
));
1018 -- Here we have no string, so prepare one
1022 Loc_Str
: constant String := Build_Location_String
(Loc
);
1027 -- For Assert, we just use the location
1029 if Nam
= Name_Assert
then
1032 -- For predicate, we generate the string "predicate failed
1033 -- at yyy". We prefer all lower case for predicate.
1035 elsif Nam
= Name_Predicate
then
1036 Add_Str_To_Name_Buffer
("predicate failed at ");
1038 -- For special case of Precondition/Postcondition the string is
1039 -- "failed xx from yy" where xx is precondition/postcondition
1040 -- in all lower case. The reason for this different wording is
1041 -- that the failure is not at the point of occurrence of the
1042 -- pragma, unlike the other Check cases.
1044 elsif Nam_In
(Nam
, Name_Precondition
, Name_Postcondition
) then
1045 Get_Name_String
(Nam
);
1046 Insert_Str_In_Name_Buffer
("failed ", 1);
1047 Add_Str_To_Name_Buffer
(" from ");
1049 -- For special case of Invariant, the string is "failed
1050 -- invariant from yy", to be consistent with the string that is
1051 -- generated for the aspect case (the code later on checks for
1052 -- this specific string to modify it in some cases, so this is
1053 -- functionally important).
1055 elsif Nam
= Name_Invariant
then
1056 Add_Str_To_Name_Buffer
("failed invariant from ");
1058 -- For all other checks, the string is "xxx failed at yyy"
1059 -- where xxx is the check name with current source file casing.
1062 Get_Name_String
(Nam
);
1063 Set_Casing
(Identifier_Casing
(Current_Source_File
));
1064 Add_Str_To_Name_Buffer
(" failed at ");
1067 -- In all cases, add location string
1069 Add_Str_To_Name_Buffer
(Loc_Str
);
1071 -- Build the message
1073 Msg
:= Make_String_Literal
(Loc
, Name_Buffer
(1 .. Name_Len
));
1077 -- Now rewrite as an if statement
1080 Make_If_Statement
(Loc
,
1081 Condition
=> Make_Op_Not
(Loc
, Right_Opnd
=> Cond
),
1082 Then_Statements
=> New_List
(
1083 Make_Procedure_Call_Statement
(Loc
,
1085 New_Occurrence_Of
(RTE
(RE_Raise_Assert_Failure
), Loc
),
1086 Parameter_Associations
=> New_List
(Relocate_Node
(Msg
))))));
1091 -- If new condition is always false, give a warning
1093 if Warn_On_Assertion_Failure
1094 and then Nkind
(N
) = N_Procedure_Call_Statement
1095 and then Is_RTE
(Entity
(Name
(N
)), RE_Raise_Assert_Failure
)
1097 -- If original condition was a Standard.False, we assume that this is
1098 -- indeed intended to raise assert error and no warning is required.
1100 if Is_Entity_Name
(Original_Node
(Cond
))
1101 and then Entity
(Original_Node
(Cond
)) = Standard_False
1105 elsif Nam
= Name_Assert
then
1106 Error_Msg_N
("?A?assertion will fail at run time", N
);
1109 Error_Msg_N
("?A?check will fail at run time", N
);
1112 end Expand_Pragma_Check
;
1114 ---------------------------------
1115 -- Expand_Pragma_Common_Object --
1116 ---------------------------------
1118 -- Use a machine attribute to replicate semantic effect in DEC Ada
1120 -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
1122 -- For now we do nothing with the size attribute ???
1124 -- Note: Psect_Object shares this processing
1126 procedure Expand_Pragma_Common_Object
(N
: Node_Id
) is
1127 Loc
: constant Source_Ptr
:= Sloc
(N
);
1129 Internal
: constant Node_Id
:= Arg1
(N
);
1130 External
: constant Node_Id
:= Arg2
(N
);
1133 -- Psect value upper cased as string literal
1135 Iloc
: constant Source_Ptr
:= Sloc
(Internal
);
1136 Eloc
: constant Source_Ptr
:= Sloc
(External
);
1140 -- Acquire Psect value and fold to upper case
1142 if Present
(External
) then
1143 if Nkind
(External
) = N_String_Literal
then
1144 String_To_Name_Buffer
(Strval
(External
));
1146 Get_Name_String
(Chars
(External
));
1152 Make_String_Literal
(Eloc
, Strval
=> String_From_Name_Buffer
);
1155 Get_Name_String
(Chars
(Internal
));
1158 Make_String_Literal
(Iloc
, Strval
=> String_From_Name_Buffer
);
1161 Ploc
:= Sloc
(Psect
);
1163 -- Insert the pragma
1165 Insert_After_And_Analyze
(N
,
1167 Chars
=> Name_Machine_Attribute
,
1168 Pragma_Argument_Associations
=> New_List
(
1169 Make_Pragma_Argument_Association
(Iloc
,
1170 Expression
=> New_Copy_Tree
(Internal
)),
1171 Make_Pragma_Argument_Association
(Eloc
,
1173 Make_String_Literal
(Sloc
=> Ploc
, Strval
=> "common_object")),
1174 Make_Pragma_Argument_Association
(Ploc
,
1175 Expression
=> New_Copy_Tree
(Psect
)))));
1176 end Expand_Pragma_Common_Object
;
1178 ---------------------------------------
1179 -- Expand_Pragma_Import_Or_Interface --
1180 ---------------------------------------
1182 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
) is
1186 -- In Relaxed_RM_Semantics, support old Ada 83 style:
1187 -- pragma Import (Entity, "external name");
1189 if Relaxed_RM_Semantics
1190 and then List_Length
(Pragma_Argument_Associations
(N
)) = 2
1191 and then Chars
(Pragma_Identifier
(N
)) = Name_Import
1192 and then Nkind
(Arg2
(N
)) = N_String_Literal
1194 Def_Id
:= Entity
(Arg1
(N
));
1196 Def_Id
:= Entity
(Arg2
(N
));
1199 -- Variable case (we have to undo any initialization already done)
1201 if Ekind
(Def_Id
) = E_Variable
then
1202 Undo_Initialization
(Def_Id
, N
);
1204 -- Case of exception with convention C++
1206 elsif Ekind
(Def_Id
) = E_Exception
1207 and then Convention
(Def_Id
) = Convention_CPP
1209 -- Import a C++ convention
1212 Loc
: constant Source_Ptr
:= Sloc
(N
);
1213 Rtti_Name
: constant Node_Id
:= Arg3
(N
);
1214 Dum
: constant Entity_Id
:= Make_Temporary
(Loc
, 'D');
1216 Lang_Char
: Node_Id
;
1217 Foreign_Data
: Node_Id
;
1220 Exdata
:= Component_Associations
(Expression
(Parent
(Def_Id
)));
1222 Lang_Char
:= Next
(First
(Exdata
));
1224 -- Change the one-character language designator to 'C'
1226 Rewrite
(Expression
(Lang_Char
),
1227 Make_Character_Literal
(Loc
,
1229 Char_Literal_Value
=> UI_From_Int
(Character'Pos ('C'))));
1230 Analyze
(Expression
(Lang_Char
));
1232 -- Change the value of Foreign_Data
1234 Foreign_Data
:= Next
(Next
(Next
(Next
(Lang_Char
))));
1236 Insert_Actions
(Def_Id
, New_List
(
1237 Make_Object_Declaration
(Loc
,
1238 Defining_Identifier
=> Dum
,
1239 Object_Definition
=>
1240 New_Occurrence_Of
(Standard_Character
, Loc
)),
1243 Chars
=> Name_Import
,
1244 Pragma_Argument_Associations
=> New_List
(
1245 Make_Pragma_Argument_Association
(Loc
,
1246 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
1248 Make_Pragma_Argument_Association
(Loc
,
1249 Expression
=> Make_Identifier
(Loc
, Chars
(Dum
))),
1251 Make_Pragma_Argument_Association
(Loc
,
1252 Chars
=> Name_External_Name
,
1253 Expression
=> Relocate_Node
(Rtti_Name
))))));
1255 Rewrite
(Expression
(Foreign_Data
),
1256 Unchecked_Convert_To
(Standard_A_Char
,
1257 Make_Attribute_Reference
(Loc
,
1258 Prefix
=> Make_Identifier
(Loc
, Chars
(Dum
)),
1259 Attribute_Name
=> Name_Address
)));
1260 Analyze
(Expression
(Foreign_Data
));
1263 -- No special expansion required for any other case
1268 end Expand_Pragma_Import_Or_Interface
;
1270 -------------------------------------
1271 -- Expand_Pragma_Initial_Condition --
1272 -------------------------------------
1274 procedure Expand_Pragma_Initial_Condition
(Spec_Or_Body
: Node_Id
) is
1275 Loc
: constant Source_Ptr
:= Sloc
(Spec_Or_Body
);
1278 Init_Cond
: Node_Id
;
1280 Pack_Id
: Entity_Id
;
1283 if Nkind
(Spec_Or_Body
) = N_Package_Body
then
1284 Pack_Id
:= Corresponding_Spec
(Spec_Or_Body
);
1286 if Present
(Handled_Statement_Sequence
(Spec_Or_Body
)) then
1287 List
:= Statements
(Handled_Statement_Sequence
(Spec_Or_Body
));
1289 -- The package body lacks statements, create an empty list
1294 Set_Handled_Statement_Sequence
(Spec_Or_Body
,
1295 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> List
));
1298 elsif Nkind
(Spec_Or_Body
) = N_Package_Declaration
then
1299 Pack_Id
:= Defining_Entity
(Spec_Or_Body
);
1301 if Present
(Visible_Declarations
(Specification
(Spec_Or_Body
))) then
1302 List
:= Visible_Declarations
(Specification
(Spec_Or_Body
));
1304 -- The package lacks visible declarations, create an empty list
1309 Set_Visible_Declarations
(Specification
(Spec_Or_Body
), List
);
1312 -- This routine should not be used on anything other than packages
1315 raise Program_Error
;
1318 Init_Cond
:= Get_Pragma
(Pack_Id
, Pragma_Initial_Condition
);
1320 -- The caller should check whether the package is subject to pragma
1321 -- Initial_Condition.
1323 pragma Assert
(Present
(Init_Cond
));
1326 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Init_Cond
)));
1328 -- The assertion expression was found to be illegal, do not generate the
1329 -- runtime check as it will repeat the illegality.
1331 if Error_Posted
(Init_Cond
) or else Error_Posted
(Expr
) then
1336 -- pragma Check (Initial_Condition, <Expr>);
1340 Chars
=> Name_Check
,
1341 Pragma_Argument_Associations
=> New_List
(
1342 Make_Pragma_Argument_Association
(Loc
,
1343 Expression
=> Make_Identifier
(Loc
, Name_Initial_Condition
)),
1345 Make_Pragma_Argument_Association
(Loc
,
1346 Expression
=> New_Copy_Tree
(Expr
))));
1348 Append_To
(List
, Check
);
1350 end Expand_Pragma_Initial_Condition
;
1352 ------------------------------------
1353 -- Expand_Pragma_Inspection_Point --
1354 ------------------------------------
1356 -- If no argument is given, then we supply a default argument list that
1357 -- includes all objects declared at the source level in all subprograms
1358 -- that enclose the inspection point pragma.
1360 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
) is
1361 Loc
: constant Source_Ptr
:= Sloc
(N
);
1368 if No
(Pragma_Argument_Associations
(N
)) then
1372 while S
/= Standard_Standard
loop
1373 E
:= First_Entity
(S
);
1374 while Present
(E
) loop
1375 if Comes_From_Source
(E
)
1376 and then Is_Object
(E
)
1377 and then not Is_Entry_Formal
(E
)
1378 and then Ekind
(E
) /= E_Component
1379 and then Ekind
(E
) /= E_Discriminant
1380 and then Ekind
(E
) /= E_Generic_In_Parameter
1381 and then Ekind
(E
) /= E_Generic_In_Out_Parameter
1384 Make_Pragma_Argument_Association
(Loc
,
1385 Expression
=> New_Occurrence_Of
(E
, Loc
)));
1394 Set_Pragma_Argument_Associations
(N
, A
);
1397 -- Expand the arguments of the pragma. Expanding an entity reference
1398 -- is a noop, except in a protected operation, where a reference may
1399 -- have to be transformed into a reference to the corresponding prival.
1400 -- Are there other pragmas that may require this ???
1402 Assoc
:= First
(Pragma_Argument_Associations
(N
));
1404 while Present
(Assoc
) loop
1405 Expand
(Expression
(Assoc
));
1408 end Expand_Pragma_Inspection_Point
;
1410 --------------------------------------
1411 -- Expand_Pragma_Interrupt_Priority --
1412 --------------------------------------
1414 -- Supply default argument if none exists (System.Interrupt_Priority'Last)
1416 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
) is
1417 Loc
: constant Source_Ptr
:= Sloc
(N
);
1420 if No
(Pragma_Argument_Associations
(N
)) then
1421 Set_Pragma_Argument_Associations
(N
, New_List
(
1422 Make_Pragma_Argument_Association
(Loc
,
1424 Make_Attribute_Reference
(Loc
,
1426 New_Occurrence_Of
(RTE
(RE_Interrupt_Priority
), Loc
),
1427 Attribute_Name
=> Name_Last
))));
1429 end Expand_Pragma_Interrupt_Priority
;
1431 --------------------------------
1432 -- Expand_Pragma_Loop_Variant --
1433 --------------------------------
1435 -- Pragma Loop_Variant is expanded in the following manner:
1439 -- for | while ... loop
1440 -- <preceding source statements>
1441 -- pragma Loop_Variant
1442 -- (Increases => Incr_Expr,
1443 -- Decreases => Decr_Expr);
1444 -- <succeeding source statements>
1449 -- Curr_1 : <type of Incr_Expr>;
1450 -- Curr_2 : <type of Decr_Expr>;
1451 -- Old_1 : <type of Incr_Expr>;
1452 -- Old_2 : <type of Decr_Expr>;
1453 -- Flag : Boolean := False;
1455 -- for | while ... loop
1456 -- <preceding source statements>
1463 -- Curr_1 := <Incr_Expr>;
1464 -- Curr_2 := <Decr_Expr>;
1467 -- if Curr_1 /= Old_1 then
1468 -- pragma Check (Loop_Variant, Curr_1 > Old_1);
1470 -- pragma Check (Loop_Variant, Curr_2 < Old_2);
1476 -- <succeeding source statements>
1479 procedure Expand_Pragma_Loop_Variant
(N
: Node_Id
) is
1480 Loc
: constant Source_Ptr
:= Sloc
(N
);
1482 Last_Var
: constant Node_Id
:= Last
(Pragma_Argument_Associations
(N
));
1484 Curr_Assign
: List_Id
:= No_List
;
1485 Flag_Id
: Entity_Id
:= Empty
;
1486 If_Stmt
: Node_Id
:= Empty
;
1487 Old_Assign
: List_Id
:= No_List
;
1488 Loop_Scop
: Entity_Id
;
1489 Loop_Stmt
: Node_Id
;
1492 procedure Process_Variant
(Variant
: Node_Id
; Is_Last
: Boolean);
1493 -- Process a single increasing / decreasing termination variant. Flag
1494 -- Is_Last should be set when processing the last variant.
1496 ---------------------
1497 -- Process_Variant --
1498 ---------------------
1500 procedure Process_Variant
(Variant
: Node_Id
; Is_Last
: Boolean) is
1504 Old_Val
: Node_Id
) return Node_Id
;
1505 -- Generate a comparison between Curr_Val and Old_Val depending on
1506 -- the change mode (Increases / Decreases) of the variant.
1515 Old_Val
: Node_Id
) return Node_Id
1518 if Chars
(Variant
) = Name_Increases
then
1519 return Make_Op_Gt
(Loc
, Curr_Val
, Old_Val
);
1520 else pragma Assert
(Chars
(Variant
) = Name_Decreases
);
1521 return Make_Op_Lt
(Loc
, Curr_Val
, Old_Val
);
1527 Expr
: constant Node_Id
:= Expression
(Variant
);
1528 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
1529 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1530 Loop_Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
1531 Curr_Id
: Entity_Id
;
1535 -- Start of processing for Process_Variant
1538 -- All temporaries generated in this routine must be inserted before
1539 -- the related loop statement. Ensure that the proper scope is on the
1540 -- stack when analyzing the temporaries. Note that we also use the
1541 -- Sloc of the related loop.
1543 Push_Scope
(Scope
(Loop_Scop
));
1545 -- Step 1: Create the declaration of the flag which controls the
1546 -- behavior of the assertion on the first iteration of the loop.
1548 if No
(Flag_Id
) then
1551 -- Flag : Boolean := False;
1553 Flag_Id
:= Make_Temporary
(Loop_Loc
, 'F');
1555 Insert_Action
(Loop_Stmt
,
1556 Make_Object_Declaration
(Loop_Loc
,
1557 Defining_Identifier
=> Flag_Id
,
1558 Object_Definition
=>
1559 New_Occurrence_Of
(Standard_Boolean
, Loop_Loc
),
1561 New_Occurrence_Of
(Standard_False
, Loop_Loc
)));
1563 -- Prevent an unwanted optimization where the Current_Value of
1564 -- the flag eliminates the if statement which stores the variant
1565 -- values coming from the previous iteration.
1567 -- Flag : Boolean := False;
1569 -- if Flag then -- condition rewritten to False
1570 -- Old_N := Curr_N; -- and if statement eliminated
1576 Set_Current_Value
(Flag_Id
, Empty
);
1579 -- Step 2: Create the temporaries which store the old and current
1580 -- values of the associated expression.
1583 -- Curr : <type of Expr>;
1585 Curr_Id
:= Make_Temporary
(Loc
, 'C');
1587 Insert_Action
(Loop_Stmt
,
1588 Make_Object_Declaration
(Loop_Loc
,
1589 Defining_Identifier
=> Curr_Id
,
1590 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loop_Loc
)));
1593 -- Old : <type of Expr>;
1595 Old_Id
:= Make_Temporary
(Loc
, 'P');
1597 Insert_Action
(Loop_Stmt
,
1598 Make_Object_Declaration
(Loop_Loc
,
1599 Defining_Identifier
=> Old_Id
,
1600 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loop_Loc
)));
1602 -- Restore original scope after all temporaries have been analyzed
1606 -- Step 3: Store value of the expression from the previous iteration
1608 if No
(Old_Assign
) then
1609 Old_Assign
:= New_List
;
1615 Append_To
(Old_Assign
,
1616 Make_Assignment_Statement
(Loc
,
1617 Name
=> New_Occurrence_Of
(Old_Id
, Loc
),
1618 Expression
=> New_Occurrence_Of
(Curr_Id
, Loc
)));
1620 -- Step 4: Store the current value of the expression
1622 if No
(Curr_Assign
) then
1623 Curr_Assign
:= New_List
;
1629 Append_To
(Curr_Assign
,
1630 Make_Assignment_Statement
(Loc
,
1631 Name
=> New_Occurrence_Of
(Curr_Id
, Loc
),
1632 Expression
=> Relocate_Node
(Expr
)));
1634 -- Step 5: Create corresponding assertion to verify change of value
1637 -- pragma Check (Loop_Variant, Curr <|> Old);
1641 Chars
=> Name_Check
,
1642 Pragma_Argument_Associations
=> New_List
(
1643 Make_Pragma_Argument_Association
(Loc
,
1644 Expression
=> Make_Identifier
(Loc
, Name_Loop_Variant
)),
1645 Make_Pragma_Argument_Association
(Loc
,
1648 Curr_Val
=> New_Occurrence_Of
(Curr_Id
, Loc
),
1649 Old_Val
=> New_Occurrence_Of
(Old_Id
, Loc
)))));
1652 -- if Curr /= Old then
1655 if No
(If_Stmt
) then
1657 -- When there is just one termination variant, do not compare the
1658 -- old and current value for equality, just check the pragma.
1664 Make_If_Statement
(Loc
,
1667 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
1668 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
1669 Then_Statements
=> New_List
(Prag
));
1678 Set_Else_Statements
(If_Stmt
, New_List
(Prag
));
1681 -- elsif Curr /= Old then
1685 if Elsif_Parts
(If_Stmt
) = No_List
then
1686 Set_Elsif_Parts
(If_Stmt
, New_List
);
1689 Append_To
(Elsif_Parts
(If_Stmt
),
1690 Make_Elsif_Part
(Loc
,
1693 Left_Opnd
=> New_Occurrence_Of
(Curr_Id
, Loc
),
1694 Right_Opnd
=> New_Occurrence_Of
(Old_Id
, Loc
)),
1695 Then_Statements
=> New_List
(Prag
)));
1697 end Process_Variant
;
1699 -- Start of processing for Expand_Pragma_Loop_Variant
1702 -- If pragma is not enabled, rewrite as Null statement. If pragma is
1703 -- disabled, it has already been rewritten as a Null statement.
1705 if Is_Ignored
(N
) then
1706 Rewrite
(N
, Make_Null_Statement
(Loc
));
1711 -- Locate the enclosing loop for which this assertion applies. In the
1712 -- case of Ada 2012 array iteration, we might be dealing with nested
1713 -- loops. Only the outermost loop has an identifier.
1716 while Present
(Loop_Stmt
) loop
1717 if Nkind
(Loop_Stmt
) = N_Loop_Statement
1718 and then Present
(Identifier
(Loop_Stmt
))
1723 Loop_Stmt
:= Parent
(Loop_Stmt
);
1726 Loop_Scop
:= Entity
(Identifier
(Loop_Stmt
));
1728 -- Create the circuitry which verifies individual variants
1730 Variant
:= First
(Pragma_Argument_Associations
(N
));
1731 while Present
(Variant
) loop
1732 Process_Variant
(Variant
, Is_Last
=> Variant
= Last_Var
);
1737 -- Construct the segment which stores the old values of all expressions.
1744 Make_If_Statement
(Loc
,
1745 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
1746 Then_Statements
=> Old_Assign
));
1748 -- Update the values of all expressions
1750 Insert_Actions
(N
, Curr_Assign
);
1752 -- Add the assertion circuitry to test all changes in expressions.
1761 Make_If_Statement
(Loc
,
1762 Condition
=> New_Occurrence_Of
(Flag_Id
, Loc
),
1763 Then_Statements
=> New_List
(If_Stmt
),
1764 Else_Statements
=> New_List
(
1765 Make_Assignment_Statement
(Loc
,
1766 Name
=> New_Occurrence_Of
(Flag_Id
, Loc
),
1767 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)))));
1769 -- Note: the pragma has been completely transformed into a sequence of
1770 -- corresponding declarations and statements. We leave it in the tree
1771 -- for documentation purposes. It will be ignored by the backend.
1773 end Expand_Pragma_Loop_Variant
;
1775 --------------------------------
1776 -- Expand_Pragma_Psect_Object --
1777 --------------------------------
1779 -- Convert to Common_Object, and expand the resulting pragma
1781 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
)
1782 renames Expand_Pragma_Common_Object
;
1784 -------------------------------------
1785 -- Expand_Pragma_Relative_Deadline --
1786 -------------------------------------
1788 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
) is
1789 P
: constant Node_Id
:= Parent
(N
);
1790 Loc
: constant Source_Ptr
:= Sloc
(N
);
1793 -- Expand the pragma only in the case of the main subprogram. For tasks
1794 -- the expansion is done in exp_ch9. Generate a call to Set_Deadline
1795 -- at Clock plus the relative deadline specified in the pragma. Time
1796 -- values are translated into Duration to allow for non-private
1797 -- addition operation.
1799 if Nkind
(P
) = N_Subprogram_Body
then
1802 Make_Procedure_Call_Statement
(Loc
,
1803 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Deadline
), Loc
),
1804 Parameter_Associations
=> New_List
(
1805 Unchecked_Convert_To
(RTE
(RO_RT_Time
),
1808 Make_Function_Call
(Loc
,
1809 New_Occurrence_Of
(RTE
(RO_RT_To_Duration
), Loc
),
1810 New_List
(Make_Function_Call
(Loc
,
1811 New_Occurrence_Of
(RTE
(RE_Clock
), Loc
)))),
1813 Unchecked_Convert_To
(Standard_Duration
, Arg1
(N
)))))));
1817 end Expand_Pragma_Relative_Deadline
;
1819 -------------------------------------------
1820 -- Expand_Pragma_Suppress_Initialization --
1821 -------------------------------------------
1823 procedure Expand_Pragma_Suppress_Initialization
(N
: Node_Id
) is
1824 Def_Id
: constant Entity_Id
:= Entity
(Arg1
(N
));
1827 -- Variable case (we have to undo any initialization already done)
1829 if Ekind
(Def_Id
) = E_Variable
then
1830 Undo_Initialization
(Def_Id
, N
);
1832 end Expand_Pragma_Suppress_Initialization
;
1834 -------------------------
1835 -- Undo_Initialization --
1836 -------------------------
1838 procedure Undo_Initialization
(Def_Id
: Entity_Id
; N
: Node_Id
) is
1839 Init_Call
: Node_Id
;
1842 -- When applied to a variable, the default initialization must not be
1843 -- done. As it is already done when the pragma is found, we just get rid
1844 -- of the call the initialization procedure which followed the object
1845 -- declaration. The call is inserted after the declaration, but validity
1846 -- checks may also have been inserted and thus the initialization call
1847 -- does not necessarily appear immediately after the object declaration.
1849 -- We can't use the freezing mechanism for this purpose, since we have
1850 -- to elaborate the initialization expression when it is first seen (so
1851 -- this elaboration cannot be deferred to the freeze point).
1853 -- Find and remove generated initialization call for object, if any
1855 Init_Call
:= Remove_Init_Call
(Def_Id
, Rep_Clause
=> N
);
1857 -- Any default initialization expression should be removed (e.g.
1858 -- null defaults for access objects, zero initialization of packed
1859 -- bit arrays). Imported objects aren't allowed to have explicit
1860 -- initialization, so the expression must have been generated by
1863 if No
(Init_Call
) and then Present
(Expression
(Parent
(Def_Id
))) then
1864 Set_Expression
(Parent
(Def_Id
), Empty
);
1867 -- The object may not have any initialization, but in the presence of
1868 -- Initialize_Scalars code is inserted after then declaration, which
1869 -- must now be removed as well. The code carries the same source
1870 -- location as the declaration itself.
1872 if Initialize_Scalars
and then Is_Array_Type
(Etype
(Def_Id
)) then
1877 Init
:= Next
(Parent
(Def_Id
));
1878 while not Comes_From_Source
(Init
)
1879 and then Sloc
(Init
) = Sloc
(Def_Id
)
1887 end Undo_Initialization
;