------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             S E M _ S C I L                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2009-2021, 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 Einfo.Entities; use Einfo.Entities;
with Einfo.Utils;    use Einfo.Utils;
with Nlists;         use Nlists;
with Rtsfind;        use Rtsfind;
with Sem_Aux;        use Sem_Aux;
with Sinfo;          use Sinfo;
with Sinfo.Nodes;    use Sinfo.Nodes;
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 Nkind (N) not in N_Subprogram_Call then
               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 Is_RTE (Ctrl_Typ, RE_Interface_Tag)
               then
                  null;

               else
                  pragma Assert (Is_RTE (Ctrl_Typ, 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 (Ctrl_Tag) in
                    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 Is_RTE (Ctrl_Typ, 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
                    (Is_RTE (Ctrl_Typ, RE_Tag)
                       or else
                         (Is_Access_Type (Ctrl_Typ)
                            and then
                          Is_RTE
                            (Available_View
                               (Base_Type (Designated_Type (Ctrl_Typ))),
                             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 (N) in
                 N_Identifier | N_And_Then | N_Or_Else |
                 N_Expression_With_Actions | N_Function_Call
              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 (Is_RTE (Etype (Ctrl_Tag), 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;