Subversion Repositories openrisc_2011-10-31

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             S E M _ S C I L                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--             Copyright (C) 2009, 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 Einfo;    use Einfo;

with Namet;    use Namet;

with Nlists;   use Nlists;

with Opt;      use Opt;

with Rtsfind;  use Rtsfind;

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Util; use Sem_Util;

with Sinfo;    use Sinfo;

with Snames;   use Snames;

with Stand;    use Stand;

package body Sem_SCIL is

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

   -- Adjust_SCIL_Node --

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

   procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id) is

      SCIL_Node : Node_Id;

   begin

      pragma Assert (Generate_SCIL);

      --  Check cases in which no action is required. Currently the only SCIL

      --  nodes that may require adjustment are those of dispatching calls

      --  internally generated by the frontend.

      if Comes_From_Source (Old_Node)

        or else not

          Nkind_In (New_Node, N_Function_Call, N_Procedure_Call_Statement)

      then

         return;

      --  Conditional expression associated with equality operator. Old_Node

      --  may be part of the expansion of the predefined equality operator of

      --  a tagged type and hence we need to check if it has a SCIL dispatching

      --  node that needs adjustment.

      elsif Nkind (Old_Node) = N_Conditional_Expression

        and then (Nkind (Original_Node (Old_Node)) = N_Op_Eq

                    or else

                      (Nkind (Original_Node (Old_Node)) = N_Function_Call

                        and then Chars (Name (Original_Node (Old_Node))) =

                                                                 Name_Op_Eq))

      then

         null;

      --  Type conversions may involve dispatching calls to functions whose

      --  associated SCIL dispatching node needs adjustment.

      elsif Nkind_In (Old_Node, N_Type_Conversion,

                                N_Unchecked_Type_Conversion)

      then

         null;

      --  Relocated subprogram call

      elsif Nkind (Old_Node) = Nkind (New_Node)

        and then Original_Node (Old_Node) = Original_Node (New_Node)

      then

         null;

      else

         return;

      end if;

      --  Search for the SCIL node and update it (if found)

      SCIL_Node := Find_SCIL_Node (Old_Node);

      if Present (SCIL_Node) then

         Set_SCIL_Related_Node (SCIL_Node, New_Node);

      end if;

   end Adjust_SCIL_Node;

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

   -- Check_SCIL_Node --

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

   function Check_SCIL_Node (N : Node_Id) return Traverse_Result is

      Ctrl_Tag : Node_Id;

      Ctrl_Typ : Entity_Id;

   begin

      if Nkind (N) = N_SCIL_Membership_Test then

         --  Check contents of the boolean expression associated with the

         --  membership test.

         pragma Assert (Nkind (SCIL_Related_Node (N)) = N_Identifier

           and then Etype (SCIL_Related_Node (N)) = Standard_Boolean);

         --  Check the entity identifier of the associated tagged type (that

         --  is, in testing for membership in T'Class, the entity id of the

         --  specific type T).

         --  Note: When the SCIL node is generated the private and full-view

         --    of the tagged types may have been swapped and hence the node

         --    referenced by attribute SCIL_Entity may be the private view.

         --    Therefore, in order to uniformily locate the full-view we use

         --    attribute Underlying_Type.

         pragma Assert (Is_Tagged_Type (Underlying_Type (SCIL_Entity (N))));

         --  Interface types are unsupported

         pragma Assert (not Is_Interface (Underlying_Type (SCIL_Entity (N))));

         --  Check the decoration of the expression that denotes the tag value

         --  being tested

         Ctrl_Tag := SCIL_Tag_Value (N);

         case Nkind (Ctrl_Tag) is

            --  For class-wide membership tests the SCIL tag value is the tag

            --  of the tested object (i.e. Obj.Tag).

            when N_Selected_Component =>

               pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag));

               null;

            when others =>

               pragma Assert (False);

               null;

         end case;

         return Skip;

      elsif Nkind (N) = N_SCIL_Dispatching_Call then

         Ctrl_Tag := SCIL_Controlling_Tag (N);

         --  SCIL_Related_Node of SCIL dispatching call nodes MUST reference

         --  subprogram calls.

         if not Nkind_In (SCIL_Related_Node (N), N_Function_Call,

                                                 N_Procedure_Call_Statement)

         then

            pragma Assert (False);

            raise Program_Error;

         --  In simple cases the controlling tag is the tag of the controlling

         --  argument (i.e. Obj.Tag).

         elsif Nkind (Ctrl_Tag) = N_Selected_Component then

            Ctrl_Typ := Etype (Ctrl_Tag);

            --  Interface types are unsupported

            if Is_Interface (Ctrl_Typ)

              or else (RTE_Available (RE_Interface_Tag)

                         and then Ctrl_Typ = RTE (RE_Interface_Tag))

            then

               null;

            else

               pragma Assert (Ctrl_Typ = RTE (RE_Tag));

               null;

            end if;

         --  When the controlling tag of a dispatching call is an identifier

         --  the SCIL_Controlling_Tag attribute references the corresponding

         --  object or parameter declaration. Interface types are still

         --  unsupported.

         elsif Nkind_In (Ctrl_Tag, N_Object_Declaration,

                                   N_Parameter_Specification)

         then

            Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag));

            --  Interface types are unsupported.

            if Is_Interface (Ctrl_Typ)

              or else (RTE_Available (RE_Interface_Tag)

                        and then Ctrl_Typ = RTE (RE_Interface_Tag))

              or else (Is_Access_Type (Ctrl_Typ)

                        and then

                          Is_Interface

                            (Available_View

                              (Base_Type (Designated_Type (Ctrl_Typ)))))

            then

               null;

            else

               pragma Assert

                 (Ctrl_Typ = RTE (RE_Tag)

                    or else

                      (Is_Access_Type (Ctrl_Typ)

                        and then Available_View

                                  (Base_Type (Designated_Type (Ctrl_Typ))) =

                                                                RTE (RE_Tag)));

               null;

            end if;

         --  Interface types are unsupported

         elsif Is_Interface (Etype (Ctrl_Tag)) then

            null;

         else

            pragma Assert (False);

            raise Program_Error;

         end if;

         return Skip;

      --  Node is not N_SCIL_Dispatching_Call

      else

         return OK;

      end if;

   end Check_SCIL_Node;

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

   -- Find_SCIL_Node --

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

   function Find_SCIL_Node (Node : Node_Id) return Node_Id is

      Found_Node : Node_Id;

      --  This variable stores the last node found by the nested subprogram

      --  Find_SCIL_Node.

      function Find_SCIL_Node (L : List_Id) return Boolean;

      --  Searches in list L for a SCIL node associated with a dispatching call

      --  whose SCIL_Related_Node is Node. If found returns true and stores the

      --  SCIL node in Found_Node; otherwise returns False and sets Found_Node

      --  to Empty.

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

      -- Find_SCIL_Node --

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

      function Find_SCIL_Node (L : List_Id) return Boolean is

         N : Node_Id;

      begin

         N := First (L);

         while Present (N) loop

            if Nkind (N) in N_SCIL_Node

              and then SCIL_Related_Node (N) = Node

            then

               Found_Node := N;

               return True;

            end if;

            Next (N);

         end loop;

         Found_Node := Empty;

         return False;

      end Find_SCIL_Node;

      --  Local variables

      P : Node_Id;

   --  Start of processing for Find_SCIL_Node

   begin

      pragma Assert (Generate_SCIL);

      --  Search for the SCIL node in list associated with a transient scope

      if Scope_Is_Transient then

         declare

            SE : Scope_Stack_Entry

                   renames Scope_Stack.Table (Scope_Stack.Last);

         begin

            if SE.Is_Transient

              and then Present (SE.Actions_To_Be_Wrapped_Before)

              and then Find_SCIL_Node (SE.Actions_To_Be_Wrapped_Before)

            then

               return Found_Node;

            end if;

         end;

      end if;

      --  Otherwise climb up the tree searching for the SCIL node analyzing

      --  all the lists in which Insert_Actions may have inserted it

      P := Node;

      while Present (P) loop

         case Nkind (P) is

            --  Actions associated with AND THEN or OR ELSE

            when N_Short_Circuit =>

               if Present (Actions (P))

                 and then Find_SCIL_Node (Actions (P))

               then

                  return Found_Node;

               end if;

            --  Actions of conditional expressions

            when N_Conditional_Expression =>

               if (Present (Then_Actions (P))

                    and then Find_SCIL_Node (Actions (P)))

                 or else

                  (Present (Else_Actions (P))

                    and then Find_SCIL_Node (Else_Actions (P)))

               then

                  return Found_Node;

               end if;

            --  Actions in handled sequence of statements

            when

               N_Handled_Sequence_Of_Statements =>

                  if Find_SCIL_Node (Statements (P)) then

                     return Found_Node;

                  end if;

            --  Conditions of while expression or elsif.

            when N_Iteration_Scheme |

                 N_Elsif_Part

            =>

               if Present (Condition_Actions (P))

                 and then Find_SCIL_Node (Condition_Actions (P))

               then

                  return Found_Node;

               end if;

            --  Statements, declarations, pragmas, representation clauses

            when

               --  Statements

               N_Procedure_Call_Statement               |

               N_Statement_Other_Than_Procedure_Call    |

               --  Pragmas

               N_Pragma                                 |

               --  Representation_Clause

               N_At_Clause                              |

               N_Attribute_Definition_Clause            |

               N_Enumeration_Representation_Clause      |

               N_Record_Representation_Clause           |

               --  Declarations

               N_Abstract_Subprogram_Declaration        |

               N_Entry_Body                             |

               N_Exception_Declaration                  |

               N_Exception_Renaming_Declaration         |

               N_Formal_Abstract_Subprogram_Declaration |

               N_Formal_Concrete_Subprogram_Declaration |

               N_Formal_Object_Declaration              |

               N_Formal_Type_Declaration                |

               N_Full_Type_Declaration                  |

               N_Function_Instantiation                 |

               N_Generic_Function_Renaming_Declaration  |

               N_Generic_Package_Declaration            |

               N_Generic_Package_Renaming_Declaration   |

               N_Generic_Procedure_Renaming_Declaration |

               N_Generic_Subprogram_Declaration         |

               N_Implicit_Label_Declaration             |

               N_Incomplete_Type_Declaration            |

               N_Number_Declaration                     |

               N_Object_Declaration                     |

               N_Object_Renaming_Declaration            |

               N_Package_Body                           |

               N_Package_Body_Stub                      |

               N_Package_Declaration                    |

               N_Package_Instantiation                  |

               N_Package_Renaming_Declaration           |

               N_Private_Extension_Declaration          |

               N_Private_Type_Declaration               |

               N_Procedure_Instantiation                |

               N_Protected_Body                         |

               N_Protected_Body_Stub                    |

               N_Protected_Type_Declaration             |

               N_Single_Task_Declaration                |

               N_Subprogram_Body                        |

               N_Subprogram_Body_Stub                   |

               N_Subprogram_Declaration                 |

               N_Subprogram_Renaming_Declaration        |

               N_Subtype_Declaration                    |

               N_Task_Body                              |

               N_Task_Body_Stub                         |

               N_Task_Type_Declaration                  |

               --  Freeze entity behaves like a declaration or statement

               N_Freeze_Entity

            =>

               --  Do not search here if the item is not a list member

               if not Is_List_Member (P) then

                  null;

               --  Do not search if parent of P is an N_Component_Association

               --  node (i.e. we are in the context of an N_Aggregate or

               --  N_Extension_Aggregate node). In this case the node should

               --  have been added before the entire aggregate.

               elsif Nkind (Parent (P)) = N_Component_Association then

                  null;

               --  Do not search if the parent of P is either an N_Variant

               --  node or an N_Record_Definition node. In this case the node

               --  should have been added before the entire record.

               elsif Nkind (Parent (P)) = N_Variant

                 or else Nkind (Parent (P)) = N_Record_Definition

               then

                  null;

               --  Otherwise search it in the list containing this node

               elsif Find_SCIL_Node (List_Containing (P)) then

                  return Found_Node;

               end if;

            --  A special case, N_Raise_xxx_Error can act either as a statement

            --  or a subexpression. We diferentiate them by looking at the

            --  Etype. It is set to Standard_Void_Type in the statement case.

            when

               N_Raise_xxx_Error =>

                  if Etype (P) = Standard_Void_Type then

                     if Is_List_Member (P)

                       and then Find_SCIL_Node (List_Containing (P))

                     then

                        return Found_Node;

                     end if;

                  --  In the subexpression case, keep climbing

                  else

                     null;

                  end if;

            --  If a component association appears within a loop created for

            --  an array aggregate, check if the SCIL node was added to the

            --  the list of nodes attached to the association.

            when

               N_Component_Association =>

                  if Nkind (Parent (P)) = N_Aggregate

                    and then Present (Loop_Actions (P))

                    and then Find_SCIL_Node (Loop_Actions (P))

                  then

                     return Found_Node;

                  end if;

            --  Another special case, an attribute denoting a procedure call

            when

               N_Attribute_Reference =>

                  if Is_Procedure_Attribute_Name (Attribute_Name (P))

                    and then Find_SCIL_Node (List_Containing (P))

                  then

                     return Found_Node;

                  --  In the subexpression case, keep climbing

                  else

                     null;

                  end if;

            --  SCIL nodes do not have subtrees and hence they can never be

            --  found climbing tree

            when

               N_SCIL_Dispatch_Table_Object_Init        |

               N_SCIL_Dispatch_Table_Tag_Init           |

               N_SCIL_Dispatching_Call                  |

               N_SCIL_Membership_Test                   |

               N_SCIL_Tag_Init

            =>

               pragma Assert (False);

               raise Program_Error;

            --  For all other node types, keep climbing tree

            when

               N_Abortable_Part                         |

               N_Accept_Alternative                     |

               N_Access_Definition                      |

               N_Access_Function_Definition             |

               N_Access_Procedure_Definition            |

               N_Access_To_Object_Definition            |

               N_Aggregate                              |

               N_Allocator                              |

               N_Case_Statement_Alternative             |

               N_Character_Literal                      |

               N_Compilation_Unit                       |

               N_Compilation_Unit_Aux                   |

               N_Component_Clause                       |

               N_Component_Declaration                  |

               N_Component_Definition                   |

               N_Component_List                         |

               N_Constrained_Array_Definition           |

               N_Decimal_Fixed_Point_Definition         |

               N_Defining_Character_Literal             |

               N_Defining_Identifier                    |

               N_Defining_Operator_Symbol               |

               N_Defining_Program_Unit_Name             |

               N_Delay_Alternative                      |

               N_Delta_Constraint                       |

               N_Derived_Type_Definition                |

               N_Designator                             |

               N_Digits_Constraint                      |

               N_Discriminant_Association               |

               N_Discriminant_Specification             |

               N_Empty                                  |

               N_Entry_Body_Formal_Part                 |

               N_Entry_Call_Alternative                 |

               N_Entry_Declaration                      |

               N_Entry_Index_Specification              |

               N_Enumeration_Type_Definition            |

               N_Error                                  |

               N_Exception_Handler                      |

               N_Expanded_Name                          |

               N_Explicit_Dereference                   |

               N_Extension_Aggregate                    |

               N_Floating_Point_Definition              |

               N_Formal_Decimal_Fixed_Point_Definition  |

               N_Formal_Derived_Type_Definition         |

               N_Formal_Discrete_Type_Definition        |

               N_Formal_Floating_Point_Definition       |

               N_Formal_Modular_Type_Definition         |

               N_Formal_Ordinary_Fixed_Point_Definition |

               N_Formal_Package_Declaration             |

               N_Formal_Private_Type_Definition         |

               N_Formal_Signed_Integer_Type_Definition  |

               N_Function_Call                          |

               N_Function_Specification                 |

               N_Generic_Association                    |

               N_Identifier                             |

               N_In                                     |

               N_Index_Or_Discriminant_Constraint       |

               N_Indexed_Component                      |

               N_Integer_Literal                        |

               N_Itype_Reference                        |

               N_Label                                  |

               N_Loop_Parameter_Specification           |

               N_Mod_Clause                             |

               N_Modular_Type_Definition                |

               N_Not_In                                 |

               N_Null                                   |

               N_Op_Abs                                 |

               N_Op_Add                                 |

               N_Op_And                                 |

               N_Op_Concat                              |

               N_Op_Divide                              |

               N_Op_Eq                                  |

               N_Op_Expon                               |

               N_Op_Ge                                  |

               N_Op_Gt                                  |

               N_Op_Le                                  |

               N_Op_Lt                                  |

               N_Op_Minus                               |

               N_Op_Mod                                 |

               N_Op_Multiply                            |

               N_Op_Ne                                  |

               N_Op_Not                                 |

               N_Op_Or                                  |

               N_Op_Plus                                |

               N_Op_Rem                                 |

               N_Op_Rotate_Left                         |

               N_Op_Rotate_Right                        |

               N_Op_Shift_Left                          |

               N_Op_Shift_Right                         |

               N_Op_Shift_Right_Arithmetic              |

               N_Op_Subtract                            |

               N_Op_Xor                                 |

               N_Operator_Symbol                        |

               N_Ordinary_Fixed_Point_Definition        |

               N_Others_Choice                          |

               N_Package_Specification                  |

               N_Parameter_Association                  |

               N_Parameter_Specification                |

               N_Pop_Constraint_Error_Label             |

               N_Pop_Program_Error_Label                |

               N_Pop_Storage_Error_Label                |

               N_Pragma_Argument_Association            |

               N_Procedure_Specification                |

               N_Protected_Definition                   |

               N_Push_Constraint_Error_Label            |

               N_Push_Program_Error_Label               |

               N_Push_Storage_Error_Label               |

               N_Qualified_Expression                   |

               N_Range                                  |

               N_Range_Constraint                       |

               N_Real_Literal                           |

               N_Real_Range_Specification               |

               N_Record_Definition                      |

               N_Reference                              |

               N_Selected_Component                     |

               N_Signed_Integer_Type_Definition         |

               N_Single_Protected_Declaration           |

               N_Slice                                  |

               N_String_Literal                         |

               N_Subprogram_Info                        |

               N_Subtype_Indication                     |

               N_Subunit                                |

               N_Task_Definition                        |

               N_Terminate_Alternative                  |

               N_Triggering_Alternative                 |

               N_Type_Conversion                        |

               N_Unchecked_Expression                   |

               N_Unchecked_Type_Conversion              |

               N_Unconstrained_Array_Definition         |

               N_Unused_At_End                          |

               N_Unused_At_Start                        |

               N_Use_Package_Clause                     |

               N_Use_Type_Clause                        |

               N_Variant                                |

               N_Variant_Part                           |

               N_Validate_Unchecked_Conversion          |

               N_With_Clause

            =>

               null;

         end case;

         --  If we fall through above tests, keep climbing tree

         if Nkind (Parent (P)) = N_Subunit then

            --  This is the proper body corresponding to a stub. Insertion done

            --  at the point of the stub, which is in the declarative part of

            --  the parent unit.

            P := Corresponding_Stub (Parent (P));

         else

            P := Parent (P);

         end if;

      end loop;

      --  SCIL node not found

      return Empty;

   end Find_SCIL_Node;

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

   -- First_Non_SCIL_Node --

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

   function First_Non_SCIL_Node (L : List_Id) return Node_Id is

      N : Node_Id;

   begin

      N := First (L);

      while Nkind (N) in N_SCIL_Node loop

         Next (N);

      end loop;

      return N;

   end First_Non_SCIL_Node;

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

   -- Next_Non_SCIL_Node --

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

   function Next_Non_SCIL_Node (N : Node_Id) return Node_Id is

      Aux_N : Node_Id;

   begin

      Aux_N := Next (N);

      while Nkind (Aux_N) in N_SCIL_Node loop

         Next (Aux_N);

      end loop;

      return Aux_N;

   end Next_Non_SCIL_Node;

end Sem_SCIL;