8sa1-gcc/gcc/ada/sem_scil.adb

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