Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              E X P _ C H 2                               --

--                                                                          --

--                                 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 Checks;   use Checks;

with Debug;    use Debug;

with Einfo;    use Einfo;

with Elists;   use Elists;

with Errout;   use Errout;

with Exp_Smem; use Exp_Smem;

with Exp_Tss;  use Exp_Tss;

with Exp_Util; use Exp_Util;

with Exp_VFpt; use Exp_VFpt;

with Namet;    use Namet;

with Nmake;    use Nmake;

with Opt;      use Opt;

with Output;   use Output;

with Sem;      use Sem;

with Sem_Eval; use Sem_Eval;

with Sem_Res;  use Sem_Res;

with Sem_Util; use Sem_Util;

with Sem_Warn; use Sem_Warn;

with Sinfo;    use Sinfo;

with Sinput;   use Sinput;

with Snames;   use Snames;

with Tbuild;   use Tbuild;

with Uintp;    use Uintp;

package body Exp_Ch2 is

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Expand_Current_Value (N : Node_Id);

   --  N is a node for a variable whose Current_Value field is set. If N is

   --  node is for a discrete type, replaces node with a copy of the referenced

   --  value. This provides a limited form of value propagation for variables

   --  which are initialized or assigned not been further modified at the time

   --  of reference. The call has no effect if the Current_Value refers to a

   --  conditional with condition other than equality.

   procedure Expand_Discriminant (N : Node_Id);

   --  An occurrence of a discriminant within a discriminated type is replaced

   --  with the corresponding discriminal, that is to say the formal parameter

   --  of the initialization procedure for the type that is associated with

   --  that particular discriminant. This replacement is not performed for

   --  discriminants of records that appear in constraints of component of the

   --  record, because Gigi uses the discriminant name to retrieve its value.

   --  In the other hand, it has to be performed for default expressions of

   --  components because they are used in the record init procedure. See Einfo

   --  for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For

   --  discriminants of tasks and protected types, the transformation is more

   --  complex when it occurs within a default expression for an entry or

   --  protected operation. The corresponding default_expression_function has

   --  an additional parameter which is the target of an entry call, and the

   --  discriminant of the task must be replaced with a reference to the

   --  discriminant of that formal parameter.

   procedure Expand_Entity_Reference (N : Node_Id);

   --  Common processing for expansion of identifiers and expanded names

   --  Dispatches to specific expansion procedures.

   procedure Expand_Entry_Index_Parameter (N : Node_Id);

   --  A reference to the identifier in the entry index specification of an

   --  entry body is modified to a reference to a constant definition equal to

   --  the index of the entry family member being called. This constant is

   --  calculated as part of the elaboration of the expanded code for the body,

   --  and is calculated from the object-wide entry index returned by Next_

   --  Entry_Call.

   procedure Expand_Entry_Parameter (N : Node_Id);

   --  A reference to an entry parameter is modified to be a reference to the

   --  corresponding component of the entry parameter record that is passed by

   --  the runtime to the accept body procedure.

   procedure Expand_Formal (N : Node_Id);

   --  A reference to a formal parameter of a protected subprogram is expanded

   --  into the corresponding formal of the unprotected procedure used to

   --  represent the operation within the protected object. In other cases

   --  Expand_Formal is a no-op.

   procedure Expand_Protected_Component (N : Node_Id);

   --  A reference to a private component of a protected type is expanded into

   --  a reference to the corresponding prival in the current protected entry

   --  or subprogram.

   procedure Expand_Renaming (N : Node_Id);

   --  For renamings, just replace the identifier by the corresponding

   --  named expression. Note that this has been evaluated (see routine

   --  Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives

   --  the correct renaming semantics.

   --------------------------

   -- Expand_Current_Value --

   --------------------------

   procedure Expand_Current_Value (N : Node_Id) is

      Loc : constant Source_Ptr := Sloc (N);

      E   : constant Entity_Id  := Entity (N);

      CV  : constant Node_Id    := Current_Value (E);

      T   : constant Entity_Id  := Etype (N);

      Val : Node_Id;

      Op  : Node_Kind;

   --  Start of processing for Expand_Current_Value

   begin

      if True

         --  No replacement if value raises constraint error

         and then Nkind (CV) /= N_Raise_Constraint_Error

         --  Do this only for discrete types

         and then Is_Discrete_Type (T)

         --  Do not replace biased types, since it is problematic to

         --  consistently generate a sensible constant value in this case.

         and then not Has_Biased_Representation (T)

         --  Do not replace lvalues

         and then not May_Be_Lvalue (N)

         --  Check that entity is suitable for replacement

         and then OK_To_Do_Constant_Replacement (E)

         --  Do not replace occurrences in pragmas (where names typically

         --  appear not as values, but as simply names. If there are cases

         --  where values are required, it is only a very minor efficiency

         --  issue that they do not get replaced when they could be).

         and then Nkind (Parent (N)) /= N_Pragma_Argument_Association

         --  Do not replace the prefixes of attribute references, since this

         --  causes trouble with cases like 4'Size. Also for Name_Asm_Input and

         --  Name_Asm_Output, don't do replacement anywhere, since we can have

         --  lvalue references in the arguments.

         and then not (Nkind (Parent (N)) = N_Attribute_Reference

                         and then

                           (Attribute_Name (Parent (N)) = Name_Asm_Input

                              or else

                            Attribute_Name (Parent (N)) = Name_Asm_Output

                              or else

                            Prefix (Parent (N)) = N))

      then

         --  Case of Current_Value is a compile time known value

         if Nkind (CV) in N_Subexpr then

            Val := CV;

         --  Case of Current_Value is a conditional expression reference

         else

            Get_Current_Value_Condition (N, Op, Val);

            if Op /= N_Op_Eq then

               return;

            end if;

         end if;

         --  If constant value is an occurrence of an enumeration literal,

         --  then we just make another occurrence of the same literal.

         if Is_Entity_Name (Val)

           and then Ekind (Entity (Val)) = E_Enumeration_Literal

         then

            Rewrite (N,

              Unchecked_Convert_To (T,

                New_Occurrence_Of (Entity (Val), Loc)));

         --  If constant is of an integer type, just make an appropriately

         --  integer literal, which will get the proper type.

         elsif Is_Integer_Type (T) then

            Rewrite (N,

              Make_Integer_Literal (Loc,

                Intval => Expr_Rep_Value (Val)));

         --  Otherwise do unchecked conversion of value to right type

         else

            Rewrite (N,

              Unchecked_Convert_To (T,

                 Make_Integer_Literal (Loc,

                   Intval => Expr_Rep_Value (Val))));

         end if;

         Analyze_And_Resolve (N, T);

         Set_Is_Static_Expression (N, False);

      end if;

   end Expand_Current_Value;

   -------------------------

   -- Expand_Discriminant --

   -------------------------

   procedure Expand_Discriminant (N : Node_Id) is

      Scop     : constant Entity_Id := Scope (Entity (N));

      P        : Node_Id := N;

      Parent_P : Node_Id := Parent (P);

      In_Entry : Boolean := False;

   begin

      --  The Incomplete_Or_Private_Kind happens while resolving the

      --  discriminant constraint involved in a derived full type,

      --  such as:

      --    type D is private;

      --    type D(C : ...) is new T(C);

      if Ekind (Scop) = E_Record_Type

        or Ekind (Scop) in Incomplete_Or_Private_Kind

      then

         --  Find the origin by walking up the tree till the component

         --  declaration

         while Present (Parent_P)

           and then Nkind (Parent_P) /= N_Component_Declaration

         loop

            P := Parent_P;

            Parent_P := Parent (P);

         end loop;

         --  If the discriminant reference was part of the default expression

         --  it has to be "discriminalized"

         if Present (Parent_P) and then P = Expression (Parent_P) then

            Set_Entity (N, Discriminal (Entity (N)));

         end if;

      elsif Is_Concurrent_Type (Scop) then

         while Present (Parent_P)

           and then Nkind (Parent_P) /= N_Subprogram_Body

         loop

            P := Parent_P;

            if Nkind (P) = N_Entry_Declaration then

               In_Entry := True;

            end if;

            Parent_P := Parent (Parent_P);

         end loop;

         --  If the discriminant occurs within the default expression for a

         --  formal of an entry or protected operation, replace it with a

         --  reference to the discriminant of the formal of the enclosing

         --  operation.

         if Present (Parent_P)

           and then Present (Corresponding_Spec (Parent_P))

         then

            declare

               Loc    : constant Source_Ptr := Sloc (N);

               D_Fun  : constant Entity_Id := Corresponding_Spec  (Parent_P);

               Formal : constant Entity_Id := First_Formal (D_Fun);

               New_N  : Node_Id;

               Disc   : Entity_Id;

            begin

               --  Verify that we are within the body of an entry or protected

               --  operation. Its first formal parameter is the synchronized

               --  type itself.

               if Present (Formal)

                 and then Etype (Formal) = Scope (Entity (N))

               then

                  Disc := CR_Discriminant (Entity (N));

                  New_N :=

                    Make_Selected_Component (Loc,

                      Prefix => New_Occurrence_Of (Formal, Loc),

                      Selector_Name => New_Occurrence_Of (Disc, Loc));

                  Set_Etype (New_N, Etype (N));

                  Rewrite (N, New_N);

               else

                  Set_Entity (N, Discriminal (Entity (N)));

               end if;

            end;

         elsif Nkind (Parent (N)) = N_Range

           and then In_Entry

         then

            Set_Entity (N, CR_Discriminant (Entity (N)));

            --  Finally, if the entity is the discriminant of the original

            --  type declaration, and we are within the initialization

            --  procedure for a task, the designated entity is the

            --  discriminal of the task body. This can happen when the

            --  argument of pragma Task_Name mentions a discriminant,

            --  because the pragma is analyzed in the task declaration

            --  but is expanded in the call to Create_Task in the init_proc.

         elsif Within_Init_Proc then

            Set_Entity (N, Discriminal (CR_Discriminant (Entity (N))));

         else

            Set_Entity (N, Discriminal (Entity (N)));

         end if;

      else

         Set_Entity (N, Discriminal (Entity (N)));

      end if;

   end Expand_Discriminant;

   -----------------------------

   -- Expand_Entity_Reference --

   -----------------------------

   procedure Expand_Entity_Reference (N : Node_Id) is

      E : constant Entity_Id := Entity (N);

   begin

      --  Defend against errors

      if No (E) and then Total_Errors_Detected /= 0 then

         return;

      end if;

      if Ekind (E) = E_Discriminant then

         Expand_Discriminant (N);

      elsif Is_Entry_Formal (E) then

         Expand_Entry_Parameter (N);

      elsif Is_Protected_Component (E) then

         if No_Run_Time_Mode then

            return;

         else

            Expand_Protected_Component (N);

         end if;

      elsif Ekind (E) = E_Entry_Index_Parameter then

         Expand_Entry_Index_Parameter (N);

      elsif Is_Formal (E) then

         Expand_Formal (N);

      elsif Is_Renaming_Of_Object (E) then

         Expand_Renaming (N);

      elsif Ekind (E) = E_Variable

        and then Is_Shared_Passive (E)

      then

         Expand_Shared_Passive_Variable (N);

      end if;

      --  Test code for implementing the pragma Reviewable requirement of

      --  classifying reads of scalars as referencing potentially uninitialized

      --  objects or not.

      if Debug_Flag_XX

        and then Is_Scalar_Type (Etype (N))

        and then (Is_Assignable (E) or else Is_Constant_Object (E))

        and then Comes_From_Source (N)

        and then not Is_LHS (N)

        and then not Is_Actual_Out_Parameter (N)

        and then (Nkind (Parent (N)) /= N_Attribute_Reference

                   or else Attribute_Name (Parent (N)) /= Name_Valid)

      then

         Write_Location (Sloc (N));

         Write_Str (": Read from scalar """);

         Write_Name (Chars (N));

         Write_Str ("""");

         if Is_Known_Valid (E) then

            Write_Str (", Is_Known_Valid");

         end if;

         Write_Eol;

      end if;

      --  Set Atomic_Sync_Required if necessary for atomic variable

      if Nkind_In (N, N_Identifier, N_Expanded_Name)

        and then Ekind (E) = E_Variable

        and then (Is_Atomic (E) or else Is_Atomic (Etype (E)))

      then

         declare

            Set  : Boolean;

         begin

            --  If variable is atomic, but type is not, setting depends on

            --  disable/enable state for the variable.

            if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then

               Set := not Atomic_Synchronization_Disabled (E);

            --  If variable is not atomic, but its type is atomic, setting

            --  depends on disable/enable state for the type.

            elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then

               Set := not Atomic_Synchronization_Disabled (Etype (E));

            --  Else both variable and type are atomic (see outer if), and we

            --  disable if either variable or its type have sync disabled.

            else

               Set := (not Atomic_Synchronization_Disabled (E))

                        and then

                      (not Atomic_Synchronization_Disabled (Etype (E)));

            end if;

            --  Set flag if required

            if Set then

               Activate_Atomic_Synchronization (N);

            end if;

         end;

      end if;

      --  Interpret possible Current_Value for variable case

      if Is_Assignable (E)

        and then Present (Current_Value (E))

      then

         Expand_Current_Value (N);

         --  We do want to warn for the case of a boolean variable (not a

         --  boolean constant) whose value is known at compile time.

         if Is_Boolean_Type (Etype (N)) then

            Warn_On_Known_Condition (N);

         end if;

      --  Don't mess with Current_Value for compile time known values. Not

      --  only is it unnecessary, but we could disturb an indication of a

      --  static value, which could cause semantic trouble.

      elsif Compile_Time_Known_Value (N) then

         null;

      --  Interpret possible Current_Value for constant case

      elsif Is_Constant_Object (E)

        and then Present (Current_Value (E))

      then

         Expand_Current_Value (N);

      end if;

   end Expand_Entity_Reference;

   ----------------------------------

   -- Expand_Entry_Index_Parameter --

   ----------------------------------

   procedure Expand_Entry_Index_Parameter (N : Node_Id) is

      Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N));

   begin

      Set_Entity (N, Index_Con);

      Set_Etype  (N, Etype (Index_Con));

   end Expand_Entry_Index_Parameter;

   ----------------------------

   -- Expand_Entry_Parameter --

   ----------------------------

   procedure Expand_Entry_Parameter (N : Node_Id) is

      Loc        : constant Source_Ptr := Sloc (N);

      Ent_Formal : constant Entity_Id  := Entity (N);

      Ent_Spec   : constant Entity_Id  := Scope (Ent_Formal);

      Parm_Type  : constant Entity_Id  := Entry_Parameters_Type (Ent_Spec);

      Acc_Stack  : constant Elist_Id   := Accept_Address (Ent_Spec);

      Addr_Ent   : constant Entity_Id  := Node (Last_Elmt (Acc_Stack));

      P_Comp_Ref : Entity_Id;

      function In_Assignment_Context (N : Node_Id) return Boolean;

      --  Check whether this is a context in which the entry formal may be

      --  assigned to.

      ---------------------------

      -- In_Assignment_Context --

      ---------------------------

      function In_Assignment_Context (N : Node_Id) return Boolean is

      begin

         --  Case of use in a call

         --  ??? passing a formal as actual for a mode IN formal is

         --  considered as an assignment?

         if Nkind_In (Parent (N), N_Procedure_Call_Statement,

                                  N_Entry_Call_Statement)

           or else (Nkind (Parent (N)) = N_Assignment_Statement

                      and then N = Name (Parent (N)))

         then

            return True;

         --  Case of a parameter association: climb up to enclosing call

         elsif Nkind (Parent (N)) = N_Parameter_Association then

            return In_Assignment_Context (Parent (N));

         --  Case of a selected component, indexed component or slice prefix:

         --  climb up the tree, unless the prefix is of an access type (in

         --  which case there is an implicit dereference, and the formal itself

         --  is not being assigned to).

         elsif Nkind_In (Parent (N), N_Selected_Component,

                                     N_Indexed_Component,

                                     N_Slice)

           and then N = Prefix (Parent (N))

           and then not Is_Access_Type (Etype (N))

           and then In_Assignment_Context (Parent (N))

         then

            return True;

         else

            return False;

         end if;

      end In_Assignment_Context;

   --  Start of processing for Expand_Entry_Parameter

   begin

      if Is_Task_Type (Scope (Ent_Spec))

        and then Comes_From_Source (Ent_Formal)

      then

         --  Before replacing the formal with the local renaming that is used

         --  in the accept block, note if this is an assignment context, and

         --  note the modification to avoid spurious warnings, because the

         --  original entity is not used further. If formal is unconstrained,

         --  we also generate an extra parameter to hold the Constrained

         --  attribute of the actual. No renaming is generated for this flag.

         --  Calling Note_Possible_Modification in the expander is dubious,

         --  because this generates a cross-reference entry, and should be

         --  done during semantic processing so it is called in -gnatc mode???

         if Ekind (Entity (N)) /= E_In_Parameter

           and then In_Assignment_Context (N)

         then

            Note_Possible_Modification (N, Sure => True);

         end if;

      end if;

      --  What we need is a reference to the corresponding component of the

      --  parameter record object. The Accept_Address field of the entry entity

      --  references the address variable that contains the address of the

      --  accept parameters record. We first have to do an unchecked conversion

      --  to turn this into a pointer to the parameter record and then we

      --  select the required parameter field.

      --  The same processing applies to protected entries, where the Accept_

      --  Address is also the address of the Parameters record.

      P_Comp_Ref :=

        Make_Selected_Component (Loc,

          Prefix =>

            Make_Explicit_Dereference (Loc,

              Unchecked_Convert_To (Parm_Type,

                New_Reference_To (Addr_Ent, Loc))),

          Selector_Name =>

            New_Reference_To (Entry_Component (Ent_Formal), Loc));

      --  For all types of parameters, the constructed parameter record object

      --  contains a pointer to the parameter. Thus we must dereference them to

      --  access them (this will often be redundant, since the dereference is

      --  implicit, but no harm is done by making it explicit).

      Rewrite (N,

        Make_Explicit_Dereference (Loc, P_Comp_Ref));

      Analyze (N);

   end Expand_Entry_Parameter;

   -------------------

   -- Expand_Formal --

   -------------------

   procedure Expand_Formal (N : Node_Id) is

      E    : constant Entity_Id  := Entity (N);

      Scop : constant Entity_Id  := Scope (E);

   begin

      --  Check whether the subprogram of which this is a formal is

      --  a protected operation. The initialization procedure for

      --  the corresponding record type is not itself a protected operation.

      if Is_Protected_Type (Scope (Scop))

        and then not Is_Init_Proc (Scop)

        and then Present (Protected_Formal (E))

      then

         Set_Entity (N, Protected_Formal (E));

      end if;

   end Expand_Formal;

   ----------------------------

   -- Expand_N_Expanded_Name --

   ----------------------------

   procedure Expand_N_Expanded_Name (N : Node_Id) is

   begin

      Expand_Entity_Reference (N);

   end Expand_N_Expanded_Name;

   -------------------------

   -- Expand_N_Identifier --

   -------------------------

   procedure Expand_N_Identifier (N : Node_Id) is

   begin

      Expand_Entity_Reference (N);

   end Expand_N_Identifier;

   ---------------------------

   -- Expand_N_Real_Literal --

   ---------------------------

   procedure Expand_N_Real_Literal (N : Node_Id) is

   begin

      if Vax_Float (Etype (N)) then

         Expand_Vax_Real_Literal (N);

      end if;

   end Expand_N_Real_Literal;

   --------------------------------

   -- Expand_Protected_Component --

   --------------------------------

   procedure Expand_Protected_Component (N : Node_Id) is

      function Inside_Eliminated_Body return Boolean;

      --  Determine whether the current entity is inside a subprogram or an

      --  entry which has been marked as eliminated.

      ----------------------------

      -- Inside_Eliminated_Body --

      ----------------------------

      function Inside_Eliminated_Body return Boolean is

         S : Entity_Id := Current_Scope;

      begin

         while Present (S) loop

            if (Ekind (S) = E_Entry

                  or else Ekind (S) = E_Entry_Family

                  or else Ekind (S) = E_Function

                  or else Ekind (S) = E_Procedure)

              and then Is_Eliminated (S)

            then

               return True;

            end if;

            S := Scope (S);

         end loop;

         return False;

      end Inside_Eliminated_Body;

   --  Start of processing for Expand_Protected_Component

   begin

      --  Eliminated bodies are not expanded and thus do not need privals

      if not Inside_Eliminated_Body then

         declare

            Priv : constant Entity_Id := Prival (Entity (N));

         begin

            Set_Entity (N, Priv);

            Set_Etype  (N, Etype (Priv));

         end;

      end if;

   end Expand_Protected_Component;

   ---------------------

   -- Expand_Renaming --

   ---------------------

   procedure Expand_Renaming (N : Node_Id) is

      E : constant Entity_Id := Entity (N);

      T : constant Entity_Id := Etype (N);

   begin

      Rewrite (N, New_Copy_Tree (Renamed_Object (E)));

      --  We mark the copy as unanalyzed, so that it is sure to be reanalyzed

      --  at the top level. This is needed in the packed case since we

      --  specifically avoided expanding packed array references when the

      --  renaming declaration was analyzed.

      Reset_Analyzed_Flags (N);

      Analyze_And_Resolve (N, T);

   end Expand_Renaming;

   ------------------

   -- Param_Entity --

   ------------------

   --  This would be trivial, simply a test for an identifier that was a

   --  reference to a formal, if it were not for the fact that a previous call

   --  to Expand_Entry_Parameter will have modified the reference to the

   --  identifier. A formal of a protected entity is rewritten as

   --    typ!(recobj).rec.all'Constrained

   --  where rec is a selector whose Entry_Formal link points to the formal

   --  For a formal of a task entity, the formal is rewritten as a local

   --  renaming.

   --  In addition, a formal that is marked volatile because it is aliased

   --  through an address clause is rewritten as dereference as well.

   function Param_Entity (N : Node_Id) return Entity_Id is

      Renamed_Obj : Node_Id;

   begin

      --  Simple reference case

      if Nkind_In (N, N_Identifier, N_Expanded_Name) then

         if Is_Formal (Entity (N)) then

            return Entity (N);

         --  Handle renamings of formal parameters and formals of tasks that

         --  are rewritten as renamings.

         elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then

            Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N)));

            if Is_Entity_Name (Renamed_Obj)

              and then Is_Formal (Entity (Renamed_Obj))

            then

               return Entity (Renamed_Obj);

            elsif

              Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement

            then

               return Entity (N);

            end if;

         end if;