1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 Debug; use Debug;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Exp_Ch11; use Exp_Ch11;
32 with Exp_Util; use Exp_Util;
33 with Expander; use Expander;
34 with Namet; use Namet;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
38 with Restrict; use Restrict;
39 with Rident; use Rident;
40 with Rtsfind; use Rtsfind;
42 with Sem_Ch8; use Sem_Ch8;
43 with Sem_Res; use Sem_Res;
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 Targparm; use Targparm;
51 with Tbuild; use Tbuild;
52 with Uintp; use Uintp;
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_Import_Export_Exception (N : Node_Id);
70 procedure Expand_Pragma_Inspection_Point (N : Node_Id);
71 procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
72 procedure Expand_Pragma_Loop_Assertion (N : Node_Id);
73 procedure Expand_Pragma_Psect_Object (N : Node_Id);
74 procedure Expand_Pragma_Relative_Deadline (N : Node_Id);
80 function Arg1 (N : Node_Id) return Node_Id is
81 Arg : constant Node_Id := First (Pragma_Argument_Associations (N));
84 and then Nkind (Arg) = N_Pragma_Argument_Association
86 return Expression (Arg);
96 function Arg2 (N : Node_Id) return Node_Id is
97 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
105 Arg : constant Node_Id := Next (Arg1);
108 and then Nkind (Arg) = N_Pragma_Argument_Association
110 return Expression (Arg);
122 function Arg3 (N : Node_Id) return Node_Id is
123 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
131 Arg : Node_Id := Next (Arg1);
140 and then Nkind (Arg) = N_Pragma_Argument_Association
142 return Expression (Arg);
151 ---------------------
152 -- Expand_N_Pragma --
153 ---------------------
155 procedure Expand_N_Pragma (N : Node_Id) is
156 Pname : constant Name_Id := Pragma_Name (N);
159 -- Note: we may have a pragma whose Pragma_Identifier field is not a
160 -- recognized pragma, and we must ignore it at this stage.
162 if Is_Pragma_Name (Pname) then
163 case Get_Pragma_Id (Pname) is
165 -- Pragmas requiring special expander action
167 when Pragma_Abort_Defer =>
168 Expand_Pragma_Abort_Defer (N);
171 Expand_Pragma_Check (N);
173 when Pragma_Common_Object =>
174 Expand_Pragma_Common_Object (N);
176 when Pragma_Export_Exception =>
177 Expand_Pragma_Import_Export_Exception (N);
179 when Pragma_Import =>
180 Expand_Pragma_Import_Or_Interface (N);
182 when Pragma_Import_Exception =>
183 Expand_Pragma_Import_Export_Exception (N);
185 when Pragma_Inspection_Point =>
186 Expand_Pragma_Inspection_Point (N);
188 when Pragma_Interface =>
189 Expand_Pragma_Import_Or_Interface (N);
191 when Pragma_Interrupt_Priority =>
192 Expand_Pragma_Interrupt_Priority (N);
194 when Pragma_Loop_Assertion =>
195 Expand_Pragma_Loop_Assertion (N);
197 when Pragma_Psect_Object =>
198 Expand_Pragma_Psect_Object (N);
200 when Pragma_Relative_Deadline =>
201 Expand_Pragma_Relative_Deadline (N);
203 -- All other pragmas need no expander action
211 -------------------------------
212 -- Expand_Pragma_Abort_Defer --
213 -------------------------------
215 -- An Abort_Defer pragma appears as the first statement in a handled
216 -- statement sequence (right after the begin). It defers aborts for
217 -- the entire statement sequence, but not for any declarations or
218 -- handlers (if any) associated with this statement sequence.
220 -- The transformation is to transform
222 -- pragma Abort_Defer;
231 -- when all others =>
232 -- Abort_Undefer.all;
235 -- Abort_Undefer_Direct;
238 procedure Expand_Pragma_Abort_Defer (N : Node_Id) is
239 Loc : constant Source_Ptr := Sloc (N);
243 Blk : constant Entity_Id :=
244 New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
247 Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
250 Stm := Remove_Next (N);
256 Make_Handled_Sequence_Of_Statements (Loc,
259 New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
262 Make_Block_Statement (Loc,
263 Handled_Statement_Sequence => HSS));
265 Set_Scope (Blk, Current_Scope);
266 Set_Etype (Blk, Standard_Void_Type);
267 Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
268 Expand_At_End_Handler (HSS, Blk);
270 end Expand_Pragma_Abort_Defer;
272 --------------------------
273 -- Expand_Pragma_Check --
274 --------------------------
276 procedure Expand_Pragma_Check (N : Node_Id) is
277 Cond : constant Node_Id := Arg2 (N);
278 Nam : constant Name_Id := Chars (Arg1 (N));
281 Loc : constant Source_Ptr := Sloc (First_Node (Cond));
282 -- Source location used in the case of a failed assertion. Note that
283 -- the source location of the expression is not usually the best choice
284 -- here. For example, it gets located on the last AND keyword in a
285 -- chain of boolean expressiond AND'ed together. It is best to put the
286 -- message on the first character of the assertion, which is the effect
287 -- of the First_Node call here.
290 -- We already know that this check is enabled, because otherwise the
291 -- semantic pass dealt with rewriting the assertion (see Sem_Prag)
293 -- Since this check is enabled, we rewrite the pragma into a
294 -- corresponding if statement, and then analyze the statement
296 -- The normal case expansion transforms:
298 -- pragma Check (name, condition [,message]);
302 -- if not condition then
303 -- System.Assertions.Raise_Assert_Failure (Str);
306 -- where Str is the message if one is present, or the default of
307 -- name failed at file:line if no message is given (the "name failed
308 -- at" is omitted for name = Assertion, since it is redundant, given
309 -- that the name of the exception is Assert_Failure.)
311 -- An alternative expansion is used when the No_Exception_Propagation
312 -- restriction is active and there is a local Assert_Failure handler.
313 -- This is not a common combination of circumstances, but it occurs in
314 -- the context of Aunit and the zero footprint profile. In this case we
317 -- if not condition then
318 -- raise Assert_Failure;
321 -- This will then be transformed into a goto, and the local handler will
322 -- be able to handle the assert error (which would not be the case if a
323 -- call is made to the Raise_Assert_Failure procedure).
325 -- We also generate the direct raise if the Suppress_Exception_Locations
326 -- is active, since we don't want to generate messages in this case.
328 -- Note that the reason we do not always generate a direct raise is that
329 -- the form in which the procedure is called allows for more efficient
330 -- breakpointing of assertion errors.
332 -- Generate the appropriate if statement. Note that we consider this to
333 -- be an explicit conditional in the source, not an implicit if, so we
334 -- do not call Make_Implicit_If_Statement.
336 -- Case where we generate a direct raise
338 if ((Debug_Flag_Dot_G
339 or else Restriction_Active (No_Exception_Propagation))
340 and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)))
341 or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N)))
344 Make_If_Statement (Loc,
348 Then_Statements => New_List (
349 Make_Raise_Statement (Loc,
351 New_Reference_To (RTE (RE_Assert_Failure), Loc)))));
353 -- Case where we call the procedure
356 -- If we have a message given, use it
358 if Present (Arg3 (N)) then
359 Msg := Get_Pragma_Arg (Arg3 (N));
361 -- Here we have no string, so prepare one
365 Msg_Loc : constant String := Build_Location_String (Loc);
370 -- For Assert, we just use the location
372 if Nam = Name_Assertion then
375 -- For predicate, we generate the string "predicate failed
376 -- at yyy". We prefer all lower case for predicate.
378 elsif Nam = Name_Predicate then
379 Add_Str_To_Name_Buffer ("predicate failed at ");
381 -- For special case of Precondition/Postcondition the string is
382 -- "failed xx from yy" where xx is precondition/postcondition
383 -- in all lower case. The reason for this different wording is
384 -- that the failure is not at the point of occurrence of the
385 -- pragma, unlike the other Check cases.
387 elsif Nam = Name_Precondition
389 Nam = Name_Postcondition
391 Get_Name_String (Nam);
392 Insert_Str_In_Name_Buffer ("failed ", 1);
393 Add_Str_To_Name_Buffer (" from ");
395 -- For all other checks, the string is "xxx failed at yyy"
396 -- where xxx is the check name with current source file casing.
399 Get_Name_String (Nam);
400 Set_Casing (Identifier_Casing (Current_Source_File));
401 Add_Str_To_Name_Buffer (" failed at ");
404 -- In all cases, add location string
406 Add_Str_To_Name_Buffer (Msg_Loc);
410 Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
414 -- Now rewrite as an if statement
417 Make_If_Statement (Loc,
421 Then_Statements => New_List (
422 Make_Procedure_Call_Statement (Loc,
424 New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc),
425 Parameter_Associations => New_List (Relocate_Node (Msg))))));
430 -- If new condition is always false, give a warning
432 if Warn_On_Assertion_Failure
433 and then Nkind (N) = N_Procedure_Call_Statement
434 and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure)
436 -- If original condition was a Standard.False, we assume that this is
437 -- indeed intended to raise assert error and no warning is required.
439 if Is_Entity_Name (Original_Node (Cond))
440 and then Entity (Original_Node (Cond)) = Standard_False
443 elsif Nam = Name_Assertion then
444 Error_Msg_N ("?assertion will fail at run time", N);
446 Error_Msg_N ("?check will fail at run time", N);
449 end Expand_Pragma_Check;
451 ---------------------------------
452 -- Expand_Pragma_Common_Object --
453 ---------------------------------
455 -- Use a machine attribute to replicate semantic effect in DEC Ada
457 -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
459 -- For now we do nothing with the size attribute ???
461 -- Note: Psect_Object shares this processing
463 procedure Expand_Pragma_Common_Object (N : Node_Id) is
464 Loc : constant Source_Ptr := Sloc (N);
466 Internal : constant Node_Id := Arg1 (N);
467 External : constant Node_Id := Arg2 (N);
470 -- Psect value upper cased as string literal
472 Iloc : constant Source_Ptr := Sloc (Internal);
473 Eloc : constant Source_Ptr := Sloc (External);
477 -- Acquire Psect value and fold to upper case
479 if Present (External) then
480 if Nkind (External) = N_String_Literal then
481 String_To_Name_Buffer (Strval (External));
483 Get_Name_String (Chars (External));
489 Make_String_Literal (Eloc,
490 Strval => String_From_Name_Buffer);
493 Get_Name_String (Chars (Internal));
496 Make_String_Literal (Iloc,
497 Strval => String_From_Name_Buffer);
500 Ploc := Sloc (Psect);
504 Insert_After_And_Analyze (N,
506 Chars => Name_Machine_Attribute,
507 Pragma_Argument_Associations => New_List (
508 Make_Pragma_Argument_Association (Iloc,
509 Expression => New_Copy_Tree (Internal)),
510 Make_Pragma_Argument_Association (Eloc,
512 Make_String_Literal (Sloc => Ploc,
513 Strval => "common_object")),
514 Make_Pragma_Argument_Association (Ploc,
515 Expression => New_Copy_Tree (Psect)))));
517 end Expand_Pragma_Common_Object;
519 ---------------------------------------
520 -- Expand_Pragma_Import_Or_Interface --
521 ---------------------------------------
523 -- When applied to a variable, the default initialization must not be
524 -- done. As it is already done when the pragma is found, we just get rid
525 -- of the call the initialization procedure which followed the object
526 -- declaration. The call is inserted after the declaration, but validity
527 -- checks may also have been inserted and the initialization call does
528 -- not necessarily appear immediately after the object declaration.
530 -- We can't use the freezing mechanism for this purpose, since we
531 -- have to elaborate the initialization expression when it is first
532 -- seen (i.e. this elaboration cannot be deferred to the freeze point).
534 procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is
539 Def_Id := Entity (Arg2 (N));
540 if Ekind (Def_Id) = E_Variable then
542 -- Find generated initialization call for object, if any
544 Init_Call := Find_Init_Call (Def_Id, Rep_Clause => N);
545 if Present (Init_Call) then
549 -- Any default initialization expression should be removed
550 -- (e.g., null defaults for access objects, zero initialization
551 -- of packed bit arrays). Imported objects aren't allowed to
552 -- have explicit initialization, so the expression must have
553 -- been generated by the compiler.
555 if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then
556 Set_Expression (Parent (Def_Id), Empty);
559 end Expand_Pragma_Import_Or_Interface;
561 -------------------------------------------
562 -- Expand_Pragma_Import_Export_Exception --
563 -------------------------------------------
565 -- For a VMS exception fix up the language field with "VMS"
566 -- instead of "Ada" (gigi needs this), create a constant that will be the
567 -- value of the VMS condition code and stuff the Interface_Name field
568 -- with the unexpanded name of the exception (if not already set).
569 -- For a Ada exception, just stuff the Interface_Name field
570 -- with the unexpanded name of the exception (if not already set).
572 procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is
574 -- This pragma is only effective on OpenVMS systems, it was ignored
575 -- on non-VMS systems, and we need to ignore it here as well.
577 if not OpenVMS_On_Target then
582 Id : constant Entity_Id := Entity (Arg1 (N));
583 Call : constant Node_Id := Register_Exception_Call (Id);
584 Loc : constant Source_Ptr := Sloc (N);
587 if Present (Call) then
589 Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V');
590 Export_Pragma : Node_Id;
591 Excep_Alias : Node_Id;
592 Excep_Object : Node_Id;
593 Excep_Image : String_Id;
599 if Present (Interface_Name (Id)) then
600 Excep_Image := Strval (Interface_Name (Id));
602 Get_Name_String (Chars (Id));
604 Excep_Image := String_From_Name_Buffer;
607 Exdata := Component_Associations (Expression (Parent (Id)));
609 if Is_VMS_Exception (Id) then
610 Lang_Char := Next (First (Exdata));
612 -- Change the one-character language designator to 'V'
614 Rewrite (Expression (Lang_Char),
615 Make_Character_Literal (Loc,
617 Char_Literal_Value =>
618 UI_From_Int (Character'Pos ('V'))));
619 Analyze (Expression (Lang_Char));
621 if Exception_Code (Id) /= No_Uint then
623 Make_Integer_Literal (Loc,
624 Intval => Exception_Code (Id));
627 Make_Object_Declaration (Loc,
628 Defining_Identifier => Excep_Internal,
630 New_Reference_To (RTE (RE_Exception_Code), Loc));
632 Insert_Action (N, Excep_Object);
633 Analyze (Excep_Object);
637 (UI_To_Int (Exception_Code (Id)) / 8 * 8);
644 (Make_Pragma_Argument_Association
647 New_Reference_To (Excep_Internal, Loc)),
649 Make_Pragma_Argument_Association
654 Strval => End_String))));
656 Insert_Action (N, Excep_Alias);
657 Analyze (Excep_Alias);
664 (Make_Pragma_Argument_Association (Loc,
665 Expression => Make_Identifier (Loc, Name_C)),
667 Make_Pragma_Argument_Association (Loc,
669 New_Reference_To (Excep_Internal, Loc)),
671 Make_Pragma_Argument_Association (Loc,
673 Make_String_Literal (Loc, Excep_Image)),
675 Make_Pragma_Argument_Association (Loc,
677 Make_String_Literal (Loc, Excep_Image))));
679 Insert_Action (N, Export_Pragma);
680 Analyze (Export_Pragma);
684 Unchecked_Convert_To (RTE (RE_Exception_Code),
685 Make_Function_Call (Loc,
687 New_Reference_To (RTE (RE_Import_Value), Loc),
688 Parameter_Associations => New_List
689 (Make_String_Literal (Loc,
690 Strval => Excep_Image))));
694 Make_Procedure_Call_Statement (Loc,
695 Name => New_Reference_To
696 (RTE (RE_Register_VMS_Exception), Loc),
697 Parameter_Associations => New_List (
699 Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
700 Make_Attribute_Reference (Loc,
701 Prefix => New_Occurrence_Of (Id, Loc),
702 Attribute_Name => Name_Unrestricted_Access)))));
704 Analyze_And_Resolve (Code, RTE (RE_Exception_Code));
708 if No (Interface_Name (Id)) then
709 Set_Interface_Name (Id,
712 Strval => Excep_Image));
717 end Expand_Pragma_Import_Export_Exception;
719 ------------------------------------
720 -- Expand_Pragma_Inspection_Point --
721 ------------------------------------
723 -- If no argument is given, then we supply a default argument list that
724 -- includes all objects declared at the source level in all subprograms
725 -- that enclose the inspection point pragma.
727 procedure Expand_Pragma_Inspection_Point (N : Node_Id) is
728 Loc : constant Source_Ptr := Sloc (N);
735 if No (Pragma_Argument_Associations (N)) then
739 while S /= Standard_Standard loop
740 E := First_Entity (S);
741 while Present (E) loop
742 if Comes_From_Source (E)
743 and then Is_Object (E)
744 and then not Is_Entry_Formal (E)
745 and then Ekind (E) /= E_Component
746 and then Ekind (E) /= E_Discriminant
747 and then Ekind (E) /= E_Generic_In_Parameter
748 and then Ekind (E) /= E_Generic_In_Out_Parameter
751 Make_Pragma_Argument_Association (Loc,
752 Expression => New_Occurrence_Of (E, Loc)));
761 Set_Pragma_Argument_Associations (N, A);
764 -- Expand the arguments of the pragma. Expanding an entity reference
765 -- is a noop, except in a protected operation, where a reference may
766 -- have to be transformed into a reference to the corresponding prival.
767 -- Are there other pragmas that may require this ???
769 Assoc := First (Pragma_Argument_Associations (N));
771 while Present (Assoc) loop
772 Expand (Expression (Assoc));
775 end Expand_Pragma_Inspection_Point;
777 --------------------------------------
778 -- Expand_Pragma_Interrupt_Priority --
779 --------------------------------------
781 -- Supply default argument if none exists (System.Interrupt_Priority'Last)
783 procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is
784 Loc : constant Source_Ptr := Sloc (N);
787 if No (Pragma_Argument_Associations (N)) then
788 Set_Pragma_Argument_Associations (N, New_List (
789 Make_Pragma_Argument_Association (Loc,
791 Make_Attribute_Reference (Loc,
793 New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc),
794 Attribute_Name => Name_Last))));
796 end Expand_Pragma_Interrupt_Priority;
798 ----------------------------------
799 -- Expand_Pragma_Loop_Assertion --
800 ----------------------------------
802 -- Pragma Loop_Assertion is expanded in the following manner:
806 -- for | while ... loop
807 -- <preceding source statements>
808 -- pragma Loop_Assertion
809 -- (Invariant => Invar_Expr,
810 -- Increases => Incr_Expr,
811 -- Decreases => Decr_Expr);
812 -- <succeeding source statements>
817 -- Curr_1 : <type of Incr_Expr>;
818 -- Curr_2 : <type of Decr_Expr>;
819 -- Old_1 : <type of Incr_Expr>;
820 -- Old_2 : <type of Decr_Expr>;
821 -- Flag : Boolean := False;
823 -- for | while ... loop
824 -- <preceding source statements>
826 -- pragma Assert (<Invar_Expr>);
833 -- Curr_1 := <Incr_Expr>;
834 -- Curr_2 := <Decr_Expr>;
837 -- if Curr_1 /= Old_1 then
838 -- pragma Assert (Curr_1 > Old_1);
840 -- pragma Assert (Curr_2 < Old_2);
846 -- <succeeding source statements>
849 procedure Expand_Pragma_Loop_Assertion (N : Node_Id) is
850 Loc : constant Source_Ptr := Sloc (N);
851 Curr_Assign : List_Id := No_List;
852 Flag_Id : Entity_Id := Empty;
853 If_Stmt : Node_Id := Empty;
854 Loop_Scop : Entity_Id;
856 Old_Assign : List_Id := No_List;
858 procedure Process_Increase_Decrease (Arg : Node_Id; Is_Last : Boolean);
859 -- Process a single increases/decreases expression. Flag Is_Last should
860 -- be set when the expression is the last argument to be processed.
862 -------------------------------
863 -- Process_Increase_Decrease --
864 -------------------------------
866 procedure Process_Increase_Decrease (Arg : Node_Id; Is_Last : Boolean) is
870 Old_Val : Node_Id) return Node_Id;
871 -- Generate a comparison between Curr_Val and Old_Val depending on
872 -- the argument name (Increases / Decreases).
881 Old_Val : Node_Id) return Node_Id
884 if Chars (Arg) = Name_Increases then
887 Left_Opnd => Curr_Val,
888 Right_Opnd => Old_Val);
892 Left_Opnd => Curr_Val,
893 Right_Opnd => Old_Val);
899 Expr : constant Node_Id := Expression (Arg);
900 Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt);
906 -- Start of processing for Process_Increase_Decrease
909 -- All temporaries generated in this routine must be inserted before
910 -- the related loop statement. Ensure that the proper scope is on the
911 -- stack when analyzing the temporaries.
913 Push_Scope (Scope (Loop_Scop));
915 -- Step 1: Create the declaration of the flag which controls the
916 -- behavior of the assertion on the first iteration of the loop.
921 -- Flag : Boolean := False;
923 Flag_Id := Make_Temporary (Loop_Loc, 'F');
925 Insert_Action (Loop_Stmt,
926 Make_Object_Declaration (Loop_Loc,
927 Defining_Identifier => Flag_Id,
929 New_Reference_To (Standard_Boolean, Loop_Loc),
931 New_Reference_To (Standard_False, Loop_Loc)));
934 -- Step 2: Create the temporaries which store the old and current
935 -- values of the associated expression.
938 -- Curr : <type of Expr>;
940 Curr_Id := Make_Temporary (Loc, 'C');
942 Insert_Action (Loop_Stmt,
943 Make_Object_Declaration (Loop_Loc,
944 Defining_Identifier => Curr_Id,
946 New_Reference_To (Etype (Expr), Loop_Loc)));
949 -- Old : <type of Expr>;
951 Old_Id := Make_Temporary (Loc, 'P');
953 Insert_Action (Loop_Stmt,
954 Make_Object_Declaration (Loop_Loc,
955 Defining_Identifier => Old_Id,
957 New_Reference_To (Etype (Expr), Loop_Loc)));
959 -- Restore the original scope after all temporaries have been
964 -- Step 3: Store the value of the expression from the previous
967 if No (Old_Assign) then
968 Old_Assign := New_List;
974 Append_To (Old_Assign,
975 Make_Assignment_Statement (Loc,
976 Name => New_Reference_To (Old_Id, Loc),
977 Expression => New_Reference_To (Curr_Id, Loc)));
979 -- Step 4: Store the current value of the expression
981 if No (Curr_Assign) then
982 Curr_Assign := New_List;
988 Append_To (Curr_Assign,
989 Make_Assignment_Statement (Loc,
990 Name => New_Reference_To (Curr_Id, Loc),
991 Expression => Relocate_Node (Expr)));
993 -- Step 5: Create the corresponding assertion to verify the change of
997 -- pragma Assert (Curr <|> Old);
1001 Chars => Name_Assert,
1002 Pragma_Argument_Associations => New_List (
1003 Make_Pragma_Argument_Association (Loc,
1006 Curr_Val => New_Reference_To (Curr_Id, Loc),
1007 Old_Val => New_Reference_To (Old_Id, Loc)))));
1010 -- if Curr /= Old then
1015 Left_Opnd => New_Reference_To (Curr_Id, Loc),
1016 Right_Opnd => New_Reference_To (Old_Id, Loc));
1018 if No (If_Stmt) then
1020 Make_If_Statement (Loc,
1022 Then_Statements => New_List (Prag));
1030 Set_Else_Statements (If_Stmt, New_List (Prag));
1033 -- elsif Curr /= Old then
1037 if Elsif_Parts (If_Stmt) = No_List then
1038 Set_Elsif_Parts (If_Stmt, New_List);
1041 Append_To (Elsif_Parts (If_Stmt),
1042 Make_Elsif_Part (Loc,
1044 Then_Statements => New_List (Prag)));
1046 end Process_Increase_Decrease;
1050 Args : constant List_Id := Pragma_Argument_Associations (N);
1051 Last_Arg : constant Node_Id := Last (Args);
1053 Invar : Node_Id := Empty;
1055 -- Start of processing for Expand_Pragma_Loop_Assertion
1058 -- Locate the enclosing loop for which this assertion applies
1060 Loop_Scop := Current_Scope;
1061 while Present (Loop_Scop)
1062 and then Loop_Scop /= Standard_Standard
1063 and then Ekind (Loop_Scop) /= E_Loop
1065 Loop_Scop := Scope (Loop_Scop);
1069 while Present (Loop_Stmt)
1070 and then Nkind (Loop_Stmt) /= N_Loop_Statement
1072 Loop_Stmt := Parent (Loop_Stmt);
1075 -- Process all pragma arguments
1077 Arg := First (Args);
1078 while Present (Arg) loop
1079 if Chars (Arg) = Name_Increases
1080 or else Chars (Arg) = Name_Decreases
1082 Process_Increase_Decrease (Arg, Is_Last => Arg = Last_Arg);
1084 Invar := Expression (Arg);
1090 -- Verify the invariant expression, generate:
1091 -- pragma Assert (<Invar>);
1093 if Present (Invar) then
1096 Chars => Name_Assert,
1097 Pragma_Argument_Associations => New_List (
1098 Make_Pragma_Argument_Association (Loc,
1099 Expression => Relocate_Node (Invar)))));
1102 -- Construct the segment which stores the old values of all expressions.
1108 if Present (Old_Assign) then
1110 Make_If_Statement (Loc,
1111 Condition => New_Reference_To (Flag_Id, Loc),
1112 Then_Statements => Old_Assign));
1115 -- Update the values of all expressions
1117 if Present (Curr_Assign) then
1118 Insert_Actions (N, Curr_Assign);
1121 -- Add the assertion circuitry to test all changes in expressions.
1129 if Present (If_Stmt) then
1131 Make_If_Statement (Loc,
1132 Condition => New_Reference_To (Flag_Id, Loc),
1133 Then_Statements => New_List (If_Stmt),
1134 Else_Statements => New_List (
1135 Make_Assignment_Statement (Loc,
1136 Name => New_Reference_To (Flag_Id, Loc),
1137 Expression => New_Reference_To (Standard_True, Loc)))));
1140 Rewrite (N, Make_Null_Statement (Loc));
1142 end Expand_Pragma_Loop_Assertion;
1144 --------------------------------
1145 -- Expand_Pragma_Psect_Object --
1146 --------------------------------
1148 -- Convert to Common_Object, and expand the resulting pragma
1150 procedure Expand_Pragma_Psect_Object (N : Node_Id)
1151 renames Expand_Pragma_Common_Object;
1153 -------------------------------------
1154 -- Expand_Pragma_Relative_Deadline --
1155 -------------------------------------
1157 procedure Expand_Pragma_Relative_Deadline (N : Node_Id) is
1158 P : constant Node_Id := Parent (N);
1159 Loc : constant Source_Ptr := Sloc (N);
1162 -- Expand the pragma only in the case of the main subprogram. For tasks
1163 -- the expansion is done in exp_ch9. Generate a call to Set_Deadline
1164 -- at Clock plus the relative deadline specified in the pragma. Time
1165 -- values are translated into Duration to allow for non-private
1166 -- addition operation.
1168 if Nkind (P) = N_Subprogram_Body then
1171 Make_Procedure_Call_Statement (Loc,
1172 Name => New_Reference_To (RTE (RE_Set_Deadline), Loc),
1173 Parameter_Associations => New_List (
1174 Unchecked_Convert_To (RTE (RO_RT_Time),
1177 Make_Function_Call (Loc,
1178 New_Reference_To (RTE (RO_RT_To_Duration), Loc),
1179 New_List (Make_Function_Call (Loc,
1180 New_Reference_To (RTE (RE_Clock), Loc)))),
1182 Unchecked_Convert_To (Standard_Duration, Arg1 (N)))))));
1186 end Expand_Pragma_Relative_Deadline;