aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8/gcc/ada/exp_prag.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8/gcc/ada/exp_prag.adb')
-rw-r--r--gcc-4.8/gcc/ada/exp_prag.adb1176
1 files changed, 0 insertions, 1176 deletions
diff --git a/gcc-4.8/gcc/ada/exp_prag.adb b/gcc-4.8/gcc/ada/exp_prag.adb
deleted file mode 100644
index 2ae1b5619..000000000
--- a/gcc-4.8/gcc/ada/exp_prag.adb
+++ /dev/null
@@ -1,1176 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- E X P _ P R A G --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Atree; use Atree;
-with Casing; use Casing;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Exp_Ch11; use Exp_Ch11;
-with Exp_Util; use Exp_Util;
-with Expander; use Expander;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Stringt; use Stringt;
-with Stand; use Stand;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
-
-package body Exp_Prag is
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function Arg1 (N : Node_Id) return Node_Id;
- function Arg2 (N : Node_Id) return Node_Id;
- function Arg3 (N : Node_Id) return Node_Id;
- -- Obtain specified pragma argument expression
-
- procedure Expand_Pragma_Abort_Defer (N : Node_Id);
- procedure Expand_Pragma_Check (N : Node_Id);
- procedure Expand_Pragma_Common_Object (N : Node_Id);
- procedure Expand_Pragma_Import_Or_Interface (N : Node_Id);
- procedure Expand_Pragma_Import_Export_Exception (N : Node_Id);
- procedure Expand_Pragma_Inspection_Point (N : Node_Id);
- procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
- procedure Expand_Pragma_Loop_Variant (N : Node_Id);
- procedure Expand_Pragma_Psect_Object (N : Node_Id);
- procedure Expand_Pragma_Relative_Deadline (N : Node_Id);
-
- ----------
- -- Arg1 --
- ----------
-
- function Arg1 (N : Node_Id) return Node_Id is
- Arg : constant Node_Id := First (Pragma_Argument_Associations (N));
- begin
- if Present (Arg)
- and then Nkind (Arg) = N_Pragma_Argument_Association
- then
- return Expression (Arg);
- else
- return Arg;
- end if;
- end Arg1;
-
- ----------
- -- Arg2 --
- ----------
-
- function Arg2 (N : Node_Id) return Node_Id is
- Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
-
- begin
- if No (Arg1) then
- return Empty;
-
- else
- declare
- Arg : constant Node_Id := Next (Arg1);
- begin
- if Present (Arg)
- and then Nkind (Arg) = N_Pragma_Argument_Association
- then
- return Expression (Arg);
- else
- return Arg;
- end if;
- end;
- end if;
- end Arg2;
-
- ----------
- -- Arg3 --
- ----------
-
- function Arg3 (N : Node_Id) return Node_Id is
- Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
-
- begin
- if No (Arg1) then
- return Empty;
-
- else
- declare
- Arg : Node_Id := Next (Arg1);
- begin
- if No (Arg) then
- return Empty;
-
- else
- Next (Arg);
-
- if Present (Arg)
- and then Nkind (Arg) = N_Pragma_Argument_Association
- then
- return Expression (Arg);
- else
- return Arg;
- end if;
- end if;
- end;
- end if;
- end Arg3;
-
- ---------------------
- -- Expand_N_Pragma --
- ---------------------
-
- procedure Expand_N_Pragma (N : Node_Id) is
- Pname : constant Name_Id := Pragma_Name (N);
-
- begin
- -- Note: we may have a pragma whose Pragma_Identifier field is not a
- -- recognized pragma, and we must ignore it at this stage.
-
- if Is_Pragma_Name (Pname) then
- case Get_Pragma_Id (Pname) is
-
- -- Pragmas requiring special expander action
-
- when Pragma_Abort_Defer =>
- Expand_Pragma_Abort_Defer (N);
-
- when Pragma_Check =>
- Expand_Pragma_Check (N);
-
- when Pragma_Common_Object =>
- Expand_Pragma_Common_Object (N);
-
- when Pragma_Export_Exception =>
- Expand_Pragma_Import_Export_Exception (N);
-
- when Pragma_Import =>
- Expand_Pragma_Import_Or_Interface (N);
-
- when Pragma_Import_Exception =>
- Expand_Pragma_Import_Export_Exception (N);
-
- when Pragma_Inspection_Point =>
- Expand_Pragma_Inspection_Point (N);
-
- when Pragma_Interface =>
- Expand_Pragma_Import_Or_Interface (N);
-
- when Pragma_Interrupt_Priority =>
- Expand_Pragma_Interrupt_Priority (N);
-
- when Pragma_Loop_Variant =>
- Expand_Pragma_Loop_Variant (N);
-
- when Pragma_Psect_Object =>
- Expand_Pragma_Psect_Object (N);
-
- when Pragma_Relative_Deadline =>
- Expand_Pragma_Relative_Deadline (N);
-
- -- All other pragmas need no expander action
-
- when others => null;
- end case;
- end if;
-
- end Expand_N_Pragma;
-
- -------------------------------
- -- Expand_Pragma_Abort_Defer --
- -------------------------------
-
- -- An Abort_Defer pragma appears as the first statement in a handled
- -- statement sequence (right after the begin). It defers aborts for
- -- the entire statement sequence, but not for any declarations or
- -- handlers (if any) associated with this statement sequence.
-
- -- The transformation is to transform
-
- -- pragma Abort_Defer;
- -- statements;
-
- -- into
-
- -- begin
- -- Abort_Defer.all;
- -- statements
- -- exception
- -- when all others =>
- -- Abort_Undefer.all;
- -- raise;
- -- at end
- -- Abort_Undefer_Direct;
- -- end;
-
- procedure Expand_Pragma_Abort_Defer (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Stm : Node_Id;
- Stms : List_Id;
- HSS : Node_Id;
- Blk : constant Entity_Id :=
- New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
-
- begin
- Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
-
- loop
- Stm := Remove_Next (N);
- exit when No (Stm);
- Append (Stm, Stms);
- end loop;
-
- HSS :=
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stms,
- At_End_Proc =>
- New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
-
- Rewrite (N,
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence => HSS));
-
- Set_Scope (Blk, Current_Scope);
- Set_Etype (Blk, Standard_Void_Type);
- Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
- Expand_At_End_Handler (HSS, Blk);
- Analyze (N);
- end Expand_Pragma_Abort_Defer;
-
- --------------------------
- -- Expand_Pragma_Check --
- --------------------------
-
- procedure Expand_Pragma_Check (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- -- Location of the pragma node. Note: it is important to use this
- -- location (and not the location of the expression) for the generated
- -- statements, otherwise the implicit return statement in the body
- -- of a pre/postcondition subprogram may inherit the source location
- -- of part of the expression, which causes confusing debug information
- -- to be generated, which interferes with coverage analysis tools.
-
- Cond : constant Node_Id := Arg2 (N);
- Nam : constant Name_Id := Chars (Arg1 (N));
- Msg : Node_Id;
-
- begin
- -- We already know that this check is enabled, because otherwise the
- -- semantic pass dealt with rewriting the assertion (see Sem_Prag)
-
- -- Since this check is enabled, we rewrite the pragma into a
- -- corresponding if statement, and then analyze the statement
-
- -- The normal case expansion transforms:
-
- -- pragma Check (name, condition [,message]);
-
- -- into
-
- -- if not condition then
- -- System.Assertions.Raise_Assert_Failure (Str);
- -- end if;
-
- -- where Str is the message if one is present, or the default of
- -- name failed at file:line if no message is given (the "name failed
- -- at" is omitted for name = Assertion, since it is redundant, given
- -- that the name of the exception is Assert_Failure.)
-
- -- An alternative expansion is used when the No_Exception_Propagation
- -- restriction is active and there is a local Assert_Failure handler.
- -- This is not a common combination of circumstances, but it occurs in
- -- the context of Aunit and the zero footprint profile. In this case we
- -- generate:
-
- -- if not condition then
- -- raise Assert_Failure;
- -- end if;
-
- -- This will then be transformed into a goto, and the local handler will
- -- be able to handle the assert error (which would not be the case if a
- -- call is made to the Raise_Assert_Failure procedure).
-
- -- We also generate the direct raise if the Suppress_Exception_Locations
- -- is active, since we don't want to generate messages in this case.
-
- -- Note that the reason we do not always generate a direct raise is that
- -- the form in which the procedure is called allows for more efficient
- -- breakpointing of assertion errors.
-
- -- Generate the appropriate if statement. Note that we consider this to
- -- be an explicit conditional in the source, not an implicit if, so we
- -- do not call Make_Implicit_If_Statement.
-
- -- Case where we generate a direct raise
-
- if ((Debug_Flag_Dot_G
- or else Restriction_Active (No_Exception_Propagation))
- and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)))
- or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N)))
- then
- Rewrite (N,
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Not (Loc,
- Right_Opnd => Cond),
- Then_Statements => New_List (
- Make_Raise_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Assert_Failure), Loc)))));
-
- -- Case where we call the procedure
-
- else
- -- If we have a message given, use it
-
- if Present (Arg3 (N)) then
- Msg := Get_Pragma_Arg (Arg3 (N));
-
- -- Here we have no string, so prepare one
-
- else
- declare
- Msg_Loc : constant String :=
- Build_Location_String (Sloc (First_Node (Cond)));
- -- Source location used in the case of a failed assertion:
- -- point to the failing condition, not Loc. Note that the
- -- source location of the expression is not usually the best
- -- choice here. For example, it gets located on the last AND
- -- keyword in a chain of boolean expressiond AND'ed together.
- -- It is best to put the message on the first character of the
- -- condition, which is the effect of the First_Node call here.
-
- begin
- Name_Len := 0;
-
- -- For Assert, we just use the location
-
- if Nam = Name_Assertion then
- null;
-
- -- For predicate, we generate the string "predicate failed
- -- at yyy". We prefer all lower case for predicate.
-
- elsif Nam = Name_Predicate then
- Add_Str_To_Name_Buffer ("predicate failed at ");
-
- -- For special case of Precondition/Postcondition the string is
- -- "failed xx from yy" where xx is precondition/postcondition
- -- in all lower case. The reason for this different wording is
- -- that the failure is not at the point of occurrence of the
- -- pragma, unlike the other Check cases.
-
- elsif Nam = Name_Precondition
- or else
- Nam = Name_Postcondition
- then
- Get_Name_String (Nam);
- Insert_Str_In_Name_Buffer ("failed ", 1);
- Add_Str_To_Name_Buffer (" from ");
-
- -- For all other checks, the string is "xxx failed at yyy"
- -- where xxx is the check name with current source file casing.
-
- else
- Get_Name_String (Nam);
- Set_Casing (Identifier_Casing (Current_Source_File));
- Add_Str_To_Name_Buffer (" failed at ");
- end if;
-
- -- In all cases, add location string
-
- Add_Str_To_Name_Buffer (Msg_Loc);
-
- -- Build the message
-
- Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
- end;
- end if;
-
- -- Now rewrite as an if statement
-
- Rewrite (N,
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Not (Loc,
- Right_Opnd => Cond),
- Then_Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc),
- Parameter_Associations => New_List (Relocate_Node (Msg))))));
- end if;
-
- Analyze (N);
-
- -- If new condition is always false, give a warning
-
- if Warn_On_Assertion_Failure
- and then Nkind (N) = N_Procedure_Call_Statement
- and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure)
- then
- -- If original condition was a Standard.False, we assume that this is
- -- indeed intended to raise assert error and no warning is required.
-
- if Is_Entity_Name (Original_Node (Cond))
- and then Entity (Original_Node (Cond)) = Standard_False
- then
- return;
-
- elsif Nam = Name_Assertion then
- Error_Msg_N ("?A?assertion will fail at run time", N);
- else
-
- Error_Msg_N ("?A?check will fail at run time", N);
- end if;
- end if;
- end Expand_Pragma_Check;
-
- ---------------------------------
- -- Expand_Pragma_Common_Object --
- ---------------------------------
-
- -- Use a machine attribute to replicate semantic effect in DEC Ada
-
- -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
-
- -- For now we do nothing with the size attribute ???
-
- -- Note: Psect_Object shares this processing
-
- procedure Expand_Pragma_Common_Object (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
-
- Internal : constant Node_Id := Arg1 (N);
- External : constant Node_Id := Arg2 (N);
-
- Psect : Node_Id;
- -- Psect value upper cased as string literal
-
- Iloc : constant Source_Ptr := Sloc (Internal);
- Eloc : constant Source_Ptr := Sloc (External);
- Ploc : Source_Ptr;
-
- begin
- -- Acquire Psect value and fold to upper case
-
- if Present (External) then
- if Nkind (External) = N_String_Literal then
- String_To_Name_Buffer (Strval (External));
- else
- Get_Name_String (Chars (External));
- end if;
-
- Set_All_Upper_Case;
-
- Psect :=
- Make_String_Literal (Eloc,
- Strval => String_From_Name_Buffer);
-
- else
- Get_Name_String (Chars (Internal));
- Set_All_Upper_Case;
- Psect :=
- Make_String_Literal (Iloc,
- Strval => String_From_Name_Buffer);
- end if;
-
- Ploc := Sloc (Psect);
-
- -- Insert the pragma
-
- Insert_After_And_Analyze (N,
- Make_Pragma (Loc,
- Chars => Name_Machine_Attribute,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Iloc,
- Expression => New_Copy_Tree (Internal)),
- Make_Pragma_Argument_Association (Eloc,
- Expression =>
- Make_String_Literal (Sloc => Ploc,
- Strval => "common_object")),
- Make_Pragma_Argument_Association (Ploc,
- Expression => New_Copy_Tree (Psect)))));
-
- end Expand_Pragma_Common_Object;
-
- ---------------------------------------
- -- Expand_Pragma_Import_Or_Interface --
- ---------------------------------------
-
- -- When applied to a variable, the default initialization must not be done.
- -- As it is already done when the pragma is found, we just get rid of the
- -- call the initialization procedure which followed the object declaration.
- -- The call is inserted after the declaration, but validity checks may
- -- also have been inserted and the initialization call does not necessarily
- -- appear immediately after the object declaration.
-
- -- We can't use the freezing mechanism for this purpose, since we have to
- -- elaborate the initialization expression when it is first seen (i.e. this
- -- elaboration cannot be deferred to the freeze point).
-
- procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is
- Def_Id : Entity_Id;
- Init_Call : Node_Id;
-
- begin
- Def_Id := Entity (Arg2 (N));
- if Ekind (Def_Id) = E_Variable then
-
- -- Find and remove generated initialization call for object, if any
-
- Init_Call := Remove_Init_Call (Def_Id, Rep_Clause => N);
-
- -- Any default initialization expression should be removed (e.g.,
- -- null defaults for access objects, zero initialization of packed
- -- bit arrays). Imported objects aren't allowed to have explicit
- -- initialization, so the expression must have been generated by
- -- the compiler.
-
- if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then
- Set_Expression (Parent (Def_Id), Empty);
- end if;
- end if;
- end Expand_Pragma_Import_Or_Interface;
-
- -------------------------------------------
- -- Expand_Pragma_Import_Export_Exception --
- -------------------------------------------
-
- -- For a VMS exception fix up the language field with "VMS"
- -- instead of "Ada" (gigi needs this), create a constant that will be the
- -- value of the VMS condition code and stuff the Interface_Name field
- -- with the unexpanded name of the exception (if not already set).
- -- For a Ada exception, just stuff the Interface_Name field
- -- with the unexpanded name of the exception (if not already set).
-
- procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is
- begin
- -- This pragma is only effective on OpenVMS systems, it was ignored
- -- on non-VMS systems, and we need to ignore it here as well.
-
- if not OpenVMS_On_Target then
- return;
- end if;
-
- declare
- Id : constant Entity_Id := Entity (Arg1 (N));
- Call : constant Node_Id := Register_Exception_Call (Id);
- Loc : constant Source_Ptr := Sloc (N);
-
- begin
- if Present (Call) then
- declare
- Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V');
- Export_Pragma : Node_Id;
- Excep_Alias : Node_Id;
- Excep_Object : Node_Id;
- Excep_Image : String_Id;
- Exdata : List_Id;
- Lang_Char : Node_Id;
- Code : Node_Id;
-
- begin
- if Present (Interface_Name (Id)) then
- Excep_Image := Strval (Interface_Name (Id));
- else
- Get_Name_String (Chars (Id));
- Set_All_Upper_Case;
- Excep_Image := String_From_Name_Buffer;
- end if;
-
- Exdata := Component_Associations (Expression (Parent (Id)));
-
- if Is_VMS_Exception (Id) then
- Lang_Char := Next (First (Exdata));
-
- -- Change the one-character language designator to 'V'
-
- Rewrite (Expression (Lang_Char),
- Make_Character_Literal (Loc,
- Chars => Name_uV,
- Char_Literal_Value =>
- UI_From_Int (Character'Pos ('V'))));
- Analyze (Expression (Lang_Char));
-
- if Exception_Code (Id) /= No_Uint then
- Code :=
- Make_Integer_Literal (Loc,
- Intval => Exception_Code (Id));
-
- Excep_Object :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Excep_Internal,
- Object_Definition =>
- New_Reference_To (RTE (RE_Exception_Code), Loc));
-
- Insert_Action (N, Excep_Object);
- Analyze (Excep_Object);
-
- Start_String;
- Store_String_Int
- (UI_To_Int (Exception_Code (Id)) / 8 * 8);
-
- Excep_Alias :=
- Make_Pragma (Loc,
- Chars => Name_Linker_Alias,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- New_Reference_To (Excep_Internal, Loc)),
-
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_String_Literal (Loc, End_String))));
-
- Insert_Action (N, Excep_Alias);
- Analyze (Excep_Alias);
-
- Export_Pragma :=
- Make_Pragma (Loc,
- Chars => Name_Export,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression => Make_Identifier (Loc, Name_C)),
-
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- New_Reference_To (Excep_Internal, Loc)),
-
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_String_Literal (Loc, Excep_Image)),
-
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_String_Literal (Loc, Excep_Image))));
-
- Insert_Action (N, Export_Pragma);
- Analyze (Export_Pragma);
-
- else
- Code :=
- Unchecked_Convert_To (RTE (RE_Exception_Code),
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Import_Value), Loc),
- Parameter_Associations => New_List
- (Make_String_Literal (Loc,
- Strval => Excep_Image))));
- end if;
-
- Rewrite (Call,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To
- (RTE (RE_Register_VMS_Exception), Loc),
- Parameter_Associations => New_List (
- Code,
- Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Id, Loc),
- Attribute_Name => Name_Unrestricted_Access)))));
-
- Analyze_And_Resolve (Code, RTE (RE_Exception_Code));
- Analyze (Call);
- end if;
-
- if No (Interface_Name (Id)) then
- Set_Interface_Name (Id,
- Make_String_Literal
- (Sloc => Loc,
- Strval => Excep_Image));
- end if;
- end;
- end if;
- end;
- end Expand_Pragma_Import_Export_Exception;
-
- ------------------------------------
- -- Expand_Pragma_Inspection_Point --
- ------------------------------------
-
- -- If no argument is given, then we supply a default argument list that
- -- includes all objects declared at the source level in all subprograms
- -- that enclose the inspection point pragma.
-
- procedure Expand_Pragma_Inspection_Point (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- A : List_Id;
- Assoc : Node_Id;
- S : Entity_Id;
- E : Entity_Id;
-
- begin
- if No (Pragma_Argument_Associations (N)) then
- A := New_List;
- S := Current_Scope;
-
- while S /= Standard_Standard loop
- E := First_Entity (S);
- while Present (E) loop
- if Comes_From_Source (E)
- and then Is_Object (E)
- and then not Is_Entry_Formal (E)
- and then Ekind (E) /= E_Component
- and then Ekind (E) /= E_Discriminant
- and then Ekind (E) /= E_Generic_In_Parameter
- and then Ekind (E) /= E_Generic_In_Out_Parameter
- then
- Append_To (A,
- Make_Pragma_Argument_Association (Loc,
- Expression => New_Occurrence_Of (E, Loc)));
- end if;
-
- Next_Entity (E);
- end loop;
-
- S := Scope (S);
- end loop;
-
- Set_Pragma_Argument_Associations (N, A);
- end if;
-
- -- Expand the arguments of the pragma. Expanding an entity reference
- -- is a noop, except in a protected operation, where a reference may
- -- have to be transformed into a reference to the corresponding prival.
- -- Are there other pragmas that may require this ???
-
- Assoc := First (Pragma_Argument_Associations (N));
-
- while Present (Assoc) loop
- Expand (Expression (Assoc));
- Next (Assoc);
- end loop;
- end Expand_Pragma_Inspection_Point;
-
- --------------------------------------
- -- Expand_Pragma_Interrupt_Priority --
- --------------------------------------
-
- -- Supply default argument if none exists (System.Interrupt_Priority'Last)
-
- procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
-
- begin
- if No (Pragma_Argument_Associations (N)) then
- Set_Pragma_Argument_Associations (N, New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc),
- Attribute_Name => Name_Last))));
- end if;
- end Expand_Pragma_Interrupt_Priority;
-
- --------------------------------
- -- Expand_Pragma_Loop_Variant --
- --------------------------------
-
- -- Pragma Loop_Variant is expanded in the following manner:
-
- -- Original code
-
- -- for | while ... loop
- -- <preceding source statements>
- -- pragma Loop_Variant
- -- (Increases => Incr_Expr,
- -- Decreases => Decr_Expr);
- -- <succeeding source statements>
- -- end loop;
-
- -- Expanded code
-
- -- Curr_1 : <type of Incr_Expr>;
- -- Curr_2 : <type of Decr_Expr>;
- -- Old_1 : <type of Incr_Expr>;
- -- Old_2 : <type of Decr_Expr>;
- -- Flag : Boolean := False;
-
- -- for | while ... loop
- -- <preceding source statements>
-
- -- if Flag then
- -- Old_1 := Curr_1;
- -- Old_2 := Curr_2;
- -- end if;
-
- -- Curr_1 := <Incr_Expr>;
- -- Curr_2 := <Decr_Expr>;
-
- -- if Flag then
- -- if Curr_1 /= Old_1 then
- -- pragma Assert (Curr_1 > Old_1);
- -- else
- -- pragma Assert (Curr_2 < Old_2);
- -- end if;
- -- else
- -- Flag := True;
- -- end if;
-
- -- <succeeding source statements>
- -- end loop;
-
- procedure Expand_Pragma_Loop_Variant (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
-
- Last_Var : constant Node_Id := Last (Pragma_Argument_Associations (N));
-
- Curr_Assign : List_Id := No_List;
- Flag_Id : Entity_Id := Empty;
- If_Stmt : Node_Id := Empty;
- Old_Assign : List_Id := No_List;
- Loop_Scop : Entity_Id;
- Loop_Stmt : Node_Id;
- Variant : Node_Id;
-
- procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean);
- -- Process a single increasing / decreasing termination variant. Flag
- -- Is_Last should be set when processing the last variant.
-
- ---------------------
- -- Process_Variant --
- ---------------------
-
- procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean) is
- function Make_Op
- (Loc : Source_Ptr;
- Curr_Val : Node_Id;
- Old_Val : Node_Id) return Node_Id;
- -- Generate a comparison between Curr_Val and Old_Val depending on
- -- the change mode (Increases / Decreases) of the variant.
-
- -------------
- -- Make_Op --
- -------------
-
- function Make_Op
- (Loc : Source_Ptr;
- Curr_Val : Node_Id;
- Old_Val : Node_Id) return Node_Id
- is
- begin
- if Chars (Variant) = Name_Increases then
- return Make_Op_Gt (Loc, Curr_Val, Old_Val);
- else pragma Assert (Chars (Variant) = Name_Decreases);
- return Make_Op_Lt (Loc, Curr_Val, Old_Val);
- end if;
- end Make_Op;
-
- -- Local variables
-
- Expr : constant Node_Id := Expression (Variant);
- Expr_Typ : constant Entity_Id := Etype (Expr);
- Loc : constant Source_Ptr := Sloc (Expr);
- Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt);
- Curr_Id : Entity_Id;
- Old_Id : Entity_Id;
- Prag : Node_Id;
-
- -- Start of processing for Process_Variant
-
- begin
- -- All temporaries generated in this routine must be inserted before
- -- the related loop statement. Ensure that the proper scope is on the
- -- stack when analyzing the temporaries. Note that we also use the
- -- Sloc of the related loop.
-
- Push_Scope (Scope (Loop_Scop));
-
- -- Step 1: Create the declaration of the flag which controls the
- -- behavior of the assertion on the first iteration of the loop.
-
- if No (Flag_Id) then
-
- -- Generate:
- -- Flag : Boolean := False;
-
- Flag_Id := Make_Temporary (Loop_Loc, 'F');
-
- Insert_Action (Loop_Stmt,
- Make_Object_Declaration (Loop_Loc,
- Defining_Identifier => Flag_Id,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loop_Loc),
- Expression =>
- New_Reference_To (Standard_False, Loop_Loc)));
-
- -- Prevent an unwanted optimization where the Current_Value of
- -- the flag eliminates the if statement which stores the variant
- -- values coming from the previous iteration.
-
- -- Flag : Boolean := False;
- -- loop
- -- if Flag then -- condition rewritten to False
- -- Old_N := Curr_N; -- and if statement eliminated
- -- end if;
- -- . . .
- -- Flag := True;
- -- end loop;
-
- Set_Current_Value (Flag_Id, Empty);
- end if;
-
- -- Step 2: Create the temporaries which store the old and current
- -- values of the associated expression.
-
- -- Generate:
- -- Curr : <type of Expr>;
-
- Curr_Id := Make_Temporary (Loc, 'C');
-
- Insert_Action (Loop_Stmt,
- Make_Object_Declaration (Loop_Loc,
- Defining_Identifier => Curr_Id,
- Object_Definition => New_Reference_To (Expr_Typ, Loop_Loc)));
-
- -- Generate:
- -- Old : <type of Expr>;
-
- Old_Id := Make_Temporary (Loc, 'P');
-
- Insert_Action (Loop_Stmt,
- Make_Object_Declaration (Loop_Loc,
- Defining_Identifier => Old_Id,
- Object_Definition => New_Reference_To (Expr_Typ, Loop_Loc)));
-
- -- Restore original scope after all temporaries have been analyzed
-
- Pop_Scope;
-
- -- Step 3: Store value of the expression from the previous iteration
-
- if No (Old_Assign) then
- Old_Assign := New_List;
- end if;
-
- -- Generate:
- -- Old := Curr;
-
- Append_To (Old_Assign,
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Old_Id, Loc),
- Expression => New_Reference_To (Curr_Id, Loc)));
-
- -- Step 4: Store the current value of the expression
-
- if No (Curr_Assign) then
- Curr_Assign := New_List;
- end if;
-
- -- Generate:
- -- Curr := <Expr>;
-
- Append_To (Curr_Assign,
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Curr_Id, Loc),
- Expression => Relocate_Node (Expr)));
-
- -- Step 5: Create corresponding assertion to verify change of value
-
- -- Generate:
- -- pragma Assert (Curr <|> Old);
-
- Prag :=
- Make_Pragma (Loc,
- Chars => Name_Assert,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_Op (Loc,
- Curr_Val => New_Reference_To (Curr_Id, Loc),
- Old_Val => New_Reference_To (Old_Id, Loc)))));
-
- -- Generate:
- -- if Curr /= Old then
- -- <Prag>;
-
- if No (If_Stmt) then
-
- -- When there is just one termination variant, do not compare the
- -- old and current value for equality, just check the pragma.
-
- if Is_Last then
- If_Stmt := Prag;
- else
- If_Stmt :=
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd => New_Reference_To (Curr_Id, Loc),
- Right_Opnd => New_Reference_To (Old_Id, Loc)),
- Then_Statements => New_List (Prag));
- end if;
-
- -- Generate:
- -- else
- -- <Prag>;
- -- end if;
-
- elsif Is_Last then
- Set_Else_Statements (If_Stmt, New_List (Prag));
-
- -- Generate:
- -- elsif Curr /= Old then
- -- <Prag>;
-
- else
- if Elsif_Parts (If_Stmt) = No_List then
- Set_Elsif_Parts (If_Stmt, New_List);
- end if;
-
- Append_To (Elsif_Parts (If_Stmt),
- Make_Elsif_Part (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd => New_Reference_To (Curr_Id, Loc),
- Right_Opnd => New_Reference_To (Old_Id, Loc)),
- Then_Statements => New_List (Prag)));
- end if;
- end Process_Variant;
-
- -- Start of processing for Expand_Pragma_Loop_Assertion
-
- begin
- -- Locate the enclosing loop for which this assertion applies. In the
- -- case of Ada 2012 array iteration, we might be dealing with nested
- -- loops. Only the outermost loop has an identifier.
-
- Loop_Stmt := N;
- while Present (Loop_Stmt) loop
- if Nkind (Loop_Stmt) = N_Loop_Statement
- and then Present (Identifier (Loop_Stmt))
- then
- exit;
- end if;
-
- Loop_Stmt := Parent (Loop_Stmt);
- end loop;
-
- Loop_Scop := Entity (Identifier (Loop_Stmt));
-
- -- Create the circuitry which verifies individual variants
-
- Variant := First (Pragma_Argument_Associations (N));
- while Present (Variant) loop
- Process_Variant (Variant, Is_Last => Variant = Last_Var);
-
- Next (Variant);
- end loop;
-
- -- Construct the segment which stores the old values of all expressions.
- -- Generate:
- -- if Flag then
- -- <Old_Assign>
- -- end if;
-
- Insert_Action (N,
- Make_If_Statement (Loc,
- Condition => New_Reference_To (Flag_Id, Loc),
- Then_Statements => Old_Assign));
-
- -- Update the values of all expressions
-
- Insert_Actions (N, Curr_Assign);
-
- -- Add the assertion circuitry to test all changes in expressions.
- -- Generate:
- -- if Flag then
- -- <If_Stmt>
- -- else
- -- Flag := True;
- -- end if;
-
- Insert_Action (N,
- Make_If_Statement (Loc,
- Condition => New_Reference_To (Flag_Id, Loc),
- Then_Statements => New_List (If_Stmt),
- Else_Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Flag_Id, Loc),
- Expression => New_Reference_To (Standard_True, Loc)))));
-
- -- Note: the pragma has been completely transformed into a sequence of
- -- corresponding declarations and statements. We leave it in the tree
- -- for documentation purposes. It will be ignored by the backend.
-
- end Expand_Pragma_Loop_Variant;
-
- --------------------------------
- -- Expand_Pragma_Psect_Object --
- --------------------------------
-
- -- Convert to Common_Object, and expand the resulting pragma
-
- procedure Expand_Pragma_Psect_Object (N : Node_Id)
- renames Expand_Pragma_Common_Object;
-
- -------------------------------------
- -- Expand_Pragma_Relative_Deadline --
- -------------------------------------
-
- procedure Expand_Pragma_Relative_Deadline (N : Node_Id) is
- P : constant Node_Id := Parent (N);
- Loc : constant Source_Ptr := Sloc (N);
-
- begin
- -- Expand the pragma only in the case of the main subprogram. For tasks
- -- the expansion is done in exp_ch9. Generate a call to Set_Deadline
- -- at Clock plus the relative deadline specified in the pragma. Time
- -- values are translated into Duration to allow for non-private
- -- addition operation.
-
- if Nkind (P) = N_Subprogram_Body then
- Rewrite
- (N,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Set_Deadline), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RO_RT_Time),
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Function_Call (Loc,
- New_Reference_To (RTE (RO_RT_To_Duration), Loc),
- New_List (Make_Function_Call (Loc,
- New_Reference_To (RTE (RE_Clock), Loc)))),
- Right_Opnd =>
- Unchecked_Convert_To (Standard_Duration, Arg1 (N)))))));
-
- Analyze (N);
- end if;
- end Expand_Pragma_Relative_Deadline;
-
-end Exp_Prag;