2009-07-31 Basile Starynkevitch <basile@starynkevitch.net>

	MELT branch merged with trunk rev 150307
	added manually libstdc++-v3/include/std/chrono from trunk.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@150308 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 649 insertions, 0 deletions

diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb
new file mode 100644
index 00000000000..f47d1288f81
--- /dev/null
+++ b/gcc/ada/sem_scil.adb
@@ -0,0 +1,649 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         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 (Old_Node) = N_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 --
+   ---------------------
+
+   --  Is this a good name for the function, given it only deals with
+   --  N_SCIL_Dispatching_Call case ???
+
+   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_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;
+
+            --  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_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_Handled_Sequence_Of_Statements         |
+               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;