obtained gcc-4.6.4.tar.bz2 from upstream website;upstream

verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.

downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.

if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.

1 files changed, 223 insertions, 0 deletions

diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb
new file mode 100644
index 000000000..a069a0a63
--- /dev/null
+++ b/gcc/ada/sem_scil.adb
@@ -0,0 +1,223 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ S C I L                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--          Copyright (C) 2009-2010, 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 Nlists;  use Nlists;
+with Rtsfind; use Rtsfind;
+with Sem_Aux; use Sem_Aux;
+with Sinfo;   use Sinfo;
+with Stand;   use Stand;
+with SCIL_LL; use SCIL_LL;
+
+package body Sem_SCIL is
+
+   ---------------------
+   -- Check_SCIL_Node --
+   ---------------------
+
+   function Check_SCIL_Node (N : Node_Id) return Traverse_Result is
+      SCIL_Node : constant Node_Id := Get_SCIL_Node (N);
+      Ctrl_Tag  : Node_Id;
+      Ctrl_Typ  : Entity_Id;
+
+   begin
+      --  For nodes that do not have SCIL node continue traversing the tree
+
+      if No (SCIL_Node) then
+         return OK;
+      end if;
+
+      case Nkind (SCIL_Node) is
+         when N_SCIL_Dispatch_Table_Tag_Init =>
+            pragma Assert (Nkind (N) = N_Object_Declaration);
+            null;
+
+         when N_SCIL_Dispatching_Call =>
+            Ctrl_Tag := SCIL_Controlling_Tag (SCIL_Node);
+
+            --  Parent of SCIL dispatching call nodes MUST be a subprogram call
+
+            if not Nkind_In (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;
+
+         when N_SCIL_Membership_Test =>
+
+            --  Check contents of the boolean expression associated with the
+            --  membership test.
+
+            pragma Assert (Nkind_In (N, N_Identifier,
+                                        N_And_Then,
+                                        N_Or_Else,
+                                        N_Expression_With_Actions)
+              and then Etype (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 uniformly locate the full-view we use
+            --    attribute Underlying_Type.
+
+            pragma Assert
+              (Is_Tagged_Type (Underlying_Type (SCIL_Entity (SCIL_Node))));
+
+            --  Interface types are unsupported
+
+            pragma Assert
+              (not Is_Interface (Underlying_Type (SCIL_Entity (SCIL_Node))));
+
+            --  Check the decoration of the expression that denotes the tag
+            --  value being tested
+
+            Ctrl_Tag := SCIL_Tag_Value (SCIL_Node);
+
+            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;
+
+         when others =>
+            pragma Assert (False);
+            raise Program_Error;
+      end case;
+
+      return Skip;
+   end Check_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;