aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.7/gcc/ada/exp_prag.adb
diff options
context:
space:
mode:
authorDan Albert <danalbert@google.com>2015-06-17 11:09:54 -0700
committerDan Albert <danalbert@google.com>2015-06-17 14:15:22 -0700
commitf378ebf14df0952eae870c9865bab8326aa8f137 (patch)
tree31794503eb2a8c64ea5f313b93100f1163afcffb /gcc-4.7/gcc/ada/exp_prag.adb
parent2c58169824949d3a597d9fa81931e001ef9b1bd0 (diff)
downloadtoolchain_gcc-f378ebf14df0952eae870c9865bab8326aa8f137.tar.gz
toolchain_gcc-f378ebf14df0952eae870c9865bab8326aa8f137.tar.bz2
toolchain_gcc-f378ebf14df0952eae870c9865bab8326aa8f137.zip
Delete old versions of GCC.
Change-Id: I710f125d905290e1024cbd67f48299861790c66c
Diffstat (limited to 'gcc-4.7/gcc/ada/exp_prag.adb')
-rw-r--r--gcc-4.7/gcc/ada/exp_prag.adb836
1 files changed, 0 insertions, 836 deletions
diff --git a/gcc-4.7/gcc/ada/exp_prag.adb b/gcc-4.7/gcc/ada/exp_prag.adb
deleted file mode 100644
index 8cb084d6b..000000000
--- a/gcc-4.7/gcc/ada/exp_prag.adb
+++ /dev/null
@@ -1,836 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- E X P _ P R A G --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2011, 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_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_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_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
- Cond : constant Node_Id := Arg2 (N);
- Nam : constant Name_Id := Chars (Arg1 (N));
- Msg : Node_Id;
-
- Loc : constant Source_Ptr := Sloc (First_Node (Cond));
- -- Source location used in the case of a failed assertion. 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 assertion, which is the effect
- -- of the First_Node call here.
-
- 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 (Loc);
-
- 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 ("?assertion will fail at run time", N);
- else
- Error_Msg_N ("?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 : constant Entity_Id := Entity (Arg2 (N));
- Init_Call : Node_Id;
-
- begin
- if Ekind (Def_Id) = E_Variable then
-
- -- Find generated initialization call for object, if any
-
- Init_Call := Find_Init_Call (Def_Id, Rep_Clause => N);
- if Present (Init_Call) then
- Remove (Init_Call);
- end if;
-
- -- 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,
- Name_Linker_Alias,
- New_List
- (Make_Pragma_Argument_Association
- (Sloc => Loc,
- Expression =>
- New_Reference_To (Excep_Internal, Loc)),
-
- Make_Pragma_Argument_Association
- (Sloc => Loc,
- Expression =>
- Make_String_Literal
- (Sloc => Loc,
- Strval => End_String))));
-
- Insert_Action (N, Excep_Alias);
- Analyze (Excep_Alias);
-
- Export_Pragma :=
- Make_Pragma
- (Loc,
- Name_Export,
- 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_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;