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-2012, 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
26with Einfo;   use Einfo;
27with Nlists;  use Nlists;
28with Rtsfind; use Rtsfind;
29with Sem_Aux; use Sem_Aux;
30with Sinfo;   use Sinfo;
31with Stand;   use Stand;
32with SCIL_LL; use SCIL_LL;
33
34package 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
220end Sem_SCIL;
221