Subversion Repositories openrisc

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

--                                                                          --

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