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-2023, 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 Einfo.Entities; use Einfo.Entities;
  28 with Einfo.Utils;    use Einfo.Utils;
  29 with Nlists;         use Nlists;
  30 with Rtsfind;        use Rtsfind;
  31 with Sem_Aux;        use Sem_Aux;
  32 with Sinfo;          use Sinfo;
  33 with Sinfo.Nodes;    use Sinfo.Nodes;
  34 with Stand;          use Stand;
  35 with SCIL_LL;        use SCIL_LL;
  36
  37 package body Sem_SCIL is
  38
  39    ---------------------
  40    -- Check_SCIL_Node --
  41    ---------------------
  42
  43    function Check_SCIL_Node (N : Node_Id) return Traverse_Result is
  44       SCIL_Node : constant Node_Id := Get_SCIL_Node (N);
  45       Ctrl_Tag  : Node_Id;
  46       Ctrl_Typ  : Entity_Id;
  47
  48    begin
  49       --  For nodes that do not have SCIL node continue traversing the tree
  50
  51       if No (SCIL_Node) then
  52          return OK;
  53       end if;
  54
  55       case Nkind (SCIL_Node) is
  56          when N_SCIL_Dispatch_Table_Tag_Init =>
  57             pragma Assert (Nkind (N) = N_Object_Declaration);
  58             null;
  59
  60          when N_SCIL_Dispatching_Call =>
  61             Ctrl_Tag := SCIL_Controlling_Tag (SCIL_Node);
  62
  63             --  Parent of SCIL dispatching call nodes MUST be a subprogram call
  64
  65             if Nkind (N) not in N_Subprogram_Call then
  66                raise Program_Error;
  67
  68             --  In simple cases the controlling tag is the tag of the
  69             --  controlling argument (i.e. Obj.Tag).
  70
  71             elsif Nkind (Ctrl_Tag) = N_Selected_Component then
  72                Ctrl_Typ := Etype (Ctrl_Tag);
  73
  74                --  Interface types are unsupported
  75
  76                if Is_Interface (Ctrl_Typ)
  77                  or else Is_RTE (Ctrl_Typ, RE_Interface_Tag)
  78                then
  79                   null;
  80
  81                else
  82                   pragma Assert (Is_RTE (Ctrl_Typ, RE_Tag));
  83                   null;
  84                end if;
  85
  86             --  When the controlling tag of a dispatching call is an identifier
  87             --  the SCIL_Controlling_Tag attribute references the corresponding
  88             --  object or parameter declaration. Interface types are still
  89             --  unsupported.
  90
  91             elsif Nkind (Ctrl_Tag) in N_Object_Renaming_Declaration
  92                                     | N_Object_Declaration
  93                                     | N_Parameter_Specification
  94                                     | N_Discriminant_Specification
  95             then
  96                Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag));
  97
  98                --  Interface types are unsupported.
  99
 100                if Is_Interface (Ctrl_Typ)
 101                  or else From_Limited_With (Ctrl_Typ)
 102                  or else Is_RTE (Ctrl_Typ, RE_Interface_Tag)
 103                  or else (Is_Access_Type (Ctrl_Typ)
 104                            and then
 105                              Is_Interface
 106                                (Available_View
 107                                  (Base_Type (Designated_Type (Ctrl_Typ)))))
 108                then
 109                   null;
 110
 111                else
 112                   pragma Assert
 113                     (Is_RTE (Ctrl_Typ, RE_Tag)
 114                        or else
 115                          (Is_Access_Type (Ctrl_Typ)
 116                             and then
 117                           Is_RTE
 118                             (Available_View
 119                                (Base_Type (Designated_Type (Ctrl_Typ))),
 120                              RE_Tag)));
 121                   null;
 122                end if;
 123
 124             --  Interface types are unsupported
 125
 126             elsif Is_Interface (Etype (Ctrl_Tag)) then
 127                null;
 128
 129             else
 130                pragma Assert (False);
 131                raise Program_Error;
 132             end if;
 133
 134             return Skip;
 135
 136          when N_SCIL_Membership_Test =>
 137
 138             --  Check contents of the boolean expression associated with the
 139             --  membership test.
 140
 141             pragma Assert
 142               (Nkind (N) in
 143                  N_Identifier | N_And_Then | N_Or_Else |
 144                  N_Expression_With_Actions | N_Function_Call
 145               and then Etype (N) = Standard_Boolean);
 146
 147             --  Check the entity identifier of the associated tagged type (that
 148             --  is, in testing for membership in T'Class, the entity id of the
 149             --  specific type T).
 150
 151             --  Note: When the SCIL node is generated the private and full-view
 152             --    of the tagged types may have been swapped and hence the node
 153             --    referenced by attribute SCIL_Entity may be the private view.
 154             --    Therefore, in order to uniformly locate the full-view we use
 155             --    attribute Underlying_Type.
 156
 157             pragma Assert
 158               (Is_Tagged_Type (Underlying_Type (SCIL_Entity (SCIL_Node))));
 159
 160             --  Interface types are unsupported
 161
 162             pragma Assert
 163               (not Is_Interface (Underlying_Type (SCIL_Entity (SCIL_Node))));
 164
 165             --  Check the decoration of the expression that denotes the tag
 166             --  value being tested
 167
 168             Ctrl_Tag := SCIL_Tag_Value (SCIL_Node);
 169
 170             case Nkind (Ctrl_Tag) is
 171
 172                --  For class-wide membership tests the SCIL tag value is the
 173                --  tag of the tested object (i.e. Obj.Tag).
 174
 175                when N_Selected_Component =>
 176                   pragma Assert (Is_RTE (Etype (Ctrl_Tag), RE_Tag));
 177                   null;
 178
 179                when others =>
 180                   pragma Assert (False);
 181                   null;
 182             end case;
 183
 184             return Skip;
 185
 186          when others =>
 187             pragma Assert (False);
 188             raise Program_Error;
 189       end case;
 190
 191       return Skip;
 192    end Check_SCIL_Node;
 193
 194    -------------------------
 195    -- First_Non_SCIL_Node --
 196    -------------------------
 197
 198    function First_Non_SCIL_Node (L : List_Id) return Node_Id is
 199       N : Node_Id;
 200
 201    begin
 202       N := First (L);
 203       while Nkind (N) in N_SCIL_Node loop
 204          Next (N);
 205       end loop;
 206
 207       return N;
 208    end First_Non_SCIL_Node;
 209
 210    ------------------------
 211    -- Next_Non_SCIL_Node --
 212    ------------------------
 213
 214    function Next_Non_SCIL_Node (N : Node_Id) return Node_Id is
 215       Aux_N : Node_Id;
 216
 217    begin
 218       Aux_N := Next (N);
 219       while Nkind (Aux_N) in N_SCIL_Node loop
 220          Next (Aux_N);
 221       end loop;
 222
 223       return Aux_N;
 224    end Next_Non_SCIL_Node;
 225
 226 end Sem_SCIL;