gcc/ada/sem_scil.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ S C I L                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2009-2018, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Einfo;   use Einfo;
  27 with Nlists;  use Nlists;
  28 with Rtsfind; use Rtsfind;
  29 with Sem_Aux; use Sem_Aux;
  30 with Sinfo;   use Sinfo;
  31 with Stand;   use Stand;
  32 with SCIL_LL; use SCIL_LL;
  33
  34 package body Sem_SCIL is
  35
  36    ---------------------
  37    -- Check_SCIL_Node --
  38    ---------------------
  39
  40    function Check_SCIL_Node (N : Node_Id) return Traverse_Result is
  41       SCIL_Node : constant Node_Id := Get_SCIL_Node (N);
  42       Ctrl_Tag  : Node_Id;
  43       Ctrl_Typ  : Entity_Id;
  44
  45    begin
  46       --  For nodes that do not have SCIL node continue traversing the tree
  47
  48       if No (SCIL_Node) then
  49          return OK;
  50       end if;
  51
  52       case Nkind (SCIL_Node) is
  53          when N_SCIL_Dispatch_Table_Tag_Init =>
  54             pragma Assert (Nkind (N) = N_Object_Declaration);
  55             null;
  56
  57          when N_SCIL_Dispatching_Call =>
  58             Ctrl_Tag := SCIL_Controlling_Tag (SCIL_Node);
  59
  60             --  Parent of SCIL dispatching call nodes MUST be a subprogram call
  61
  62             if Nkind (N) not in N_Subprogram_Call then
  63                raise Program_Error;
  64
  65             --  In simple cases the controlling tag is the tag of the
  66             --  controlling argument (i.e. Obj.Tag).
  67
  68             elsif Nkind (Ctrl_Tag) = N_Selected_Component then
  69                Ctrl_Typ := Etype (Ctrl_Tag);
  70
  71                --  Interface types are unsupported
  72
  73                if Is_Interface (Ctrl_Typ)
  74                  or else (RTE_Available (RE_Interface_Tag)
  75                             and then Ctrl_Typ = RTE (RE_Interface_Tag))
  76                then
  77                   null;
  78
  79                else
  80                   pragma Assert (Ctrl_Typ = RTE (RE_Tag));
  81                   null;
  82                end if;
  83
  84             --  When the controlling tag of a dispatching call is an identifier
  85             --  the SCIL_Controlling_Tag attribute references the corresponding
  86             --  object or parameter declaration. Interface types are still
  87             --  unsupported.
  88
  89             elsif Nkind_In (Ctrl_Tag, N_Object_Declaration,
  90                                       N_Parameter_Specification)
  91             then
  92                Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag));
  93
  94                --  Interface types are unsupported.
  95
  96                if Is_Interface (Ctrl_Typ)
  97                  or else (RTE_Available (RE_Interface_Tag)
  98                            and then Ctrl_Typ = RTE (RE_Interface_Tag))
  99                  or else (Is_Access_Type (Ctrl_Typ)
 100                            and then
 101                              Is_Interface
 102                                (Available_View
 103                                  (Base_Type (Designated_Type (Ctrl_Typ)))))
 104                then
 105                   null;
 106
 107                else
 108                   pragma Assert
 109                     (Ctrl_Typ = RTE (RE_Tag)
 110                        or else
 111                          (Is_Access_Type (Ctrl_Typ)
 112                            and then Available_View
 113                                       (Base_Type (Designated_Type (Ctrl_Typ)))
 114                                         = RTE (RE_Tag)));
 115                   null;
 116                end if;
 117
 118             --  Interface types are unsupported
 119
 120             elsif Is_Interface (Etype (Ctrl_Tag)) then
 121                null;
 122
 123             else
 124                pragma Assert (False);
 125                raise Program_Error;
 126             end if;
 127
 128             return Skip;
 129
 130          when N_SCIL_Membership_Test =>
 131
 132             --  Check contents of the boolean expression associated with the
 133             --  membership test.
 134
 135             pragma Assert (Nkind_In (N, N_Identifier,
 136                                         N_And_Then,
 137                                         N_Or_Else,
 138                                         N_Expression_With_Actions)
 139               and then Etype (N) = Standard_Boolean);
 140
 141             --  Check the entity identifier of the associated tagged type (that
 142             --  is, in testing for membership in T'Class, the entity id of the
 143             --  specific type T).
 144
 145             --  Note: When the SCIL node is generated the private and full-view
 146             --    of the tagged types may have been swapped and hence the node
 147             --    referenced by attribute SCIL_Entity may be the private view.
 148             --    Therefore, in order to uniformly locate the full-view we use
 149             --    attribute Underlying_Type.
 150
 151             pragma Assert
 152               (Is_Tagged_Type (Underlying_Type (SCIL_Entity (SCIL_Node))));
 153
 154             --  Interface types are unsupported
 155
 156             pragma Assert
 157               (not Is_Interface (Underlying_Type (SCIL_Entity (SCIL_Node))));
 158
 159             --  Check the decoration of the expression that denotes the tag
 160             --  value being tested
 161
 162             Ctrl_Tag := SCIL_Tag_Value (SCIL_Node);
 163
 164             case Nkind (Ctrl_Tag) is
 165
 166                --  For class-wide membership tests the SCIL tag value is the
 167                --  tag of the tested object (i.e. Obj.Tag).
 168
 169                when N_Selected_Component =>
 170                   pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag));
 171                   null;
 172
 173                when others =>
 174                   pragma Assert (False);
 175                   null;
 176             end case;
 177
 178             return Skip;
 179
 180          when others =>
 181             pragma Assert (False);
 182             raise Program_Error;
 183       end case;
 184
 185       return Skip;
 186    end Check_SCIL_Node;
 187
 188    -------------------------
 189    -- First_Non_SCIL_Node --
 190    -------------------------
 191
 192    function First_Non_SCIL_Node (L : List_Id) return Node_Id is
 193       N : Node_Id;
 194
 195    begin
 196       N := First (L);
 197       while Nkind (N) in N_SCIL_Node loop
 198          Next (N);
 199       end loop;
 200
 201       return N;
 202    end First_Non_SCIL_Node;
 203
 204    ------------------------
 205    -- Next_Non_SCIL_Node --
 206    ------------------------
 207
 208    function Next_Non_SCIL_Node (N : Node_Id) return Node_Id is
 209       Aux_N : Node_Id;
 210
 211    begin
 212       Aux_N := Next (N);
 213       while Nkind (Aux_N) in N_SCIL_Node loop
 214          Next (Aux_N);
 215       end loop;
 216
 217       return Aux_N;
 218    end Next_Non_SCIL_Node;
 219
 220 end Sem_SCIL;