1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2009-2010, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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
;
34 package body Sem_SCIL
is
40 function Check_SCIL_Node
(N
: Node_Id
) return Traverse_Result
is
41 SCIL_Node
: constant Node_Id
:= Get_SCIL_Node
(N
);
46 -- For nodes that do not have SCIL node continue traversing the tree
48 if No
(SCIL_Node
) then
52 case Nkind
(SCIL_Node
) is
53 when N_SCIL_Dispatch_Table_Tag_Init
=>
54 pragma Assert
(Nkind
(N
) = N_Object_Declaration
);
57 when N_SCIL_Dispatching_Call
=>
58 Ctrl_Tag
:= SCIL_Controlling_Tag
(SCIL_Node
);
60 -- Parent of SCIL dispatching call nodes MUST be a subprogram call
62 if not Nkind_In
(N
, N_Function_Call
,
63 N_Procedure_Call_Statement
)
65 pragma Assert
(False);
68 -- In simple cases the controlling tag is the tag of the
69 -- controlling argument (i.e. Obj.Tag).
71 elsif Nkind
(Ctrl_Tag
) = N_Selected_Component
then
72 Ctrl_Typ
:= Etype
(Ctrl_Tag
);
74 -- Interface types are unsupported
76 if Is_Interface
(Ctrl_Typ
)
77 or else (RTE_Available
(RE_Interface_Tag
)
78 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
83 pragma Assert
(Ctrl_Typ
= RTE
(RE_Tag
));
87 -- When the controlling tag of a dispatching call is an identifier
88 -- the SCIL_Controlling_Tag attribute references the corresponding
89 -- object or parameter declaration. Interface types are still
92 elsif Nkind_In
(Ctrl_Tag
, N_Object_Declaration
,
93 N_Parameter_Specification
)
95 Ctrl_Typ
:= Etype
(Defining_Identifier
(Ctrl_Tag
));
97 -- Interface types are unsupported.
99 if Is_Interface
(Ctrl_Typ
)
100 or else (RTE_Available
(RE_Interface_Tag
)
101 and then Ctrl_Typ
= RTE
(RE_Interface_Tag
))
102 or else (Is_Access_Type
(Ctrl_Typ
)
106 (Base_Type
(Designated_Type
(Ctrl_Typ
)))))
112 (Ctrl_Typ
= RTE
(RE_Tag
)
114 (Is_Access_Type
(Ctrl_Typ
)
115 and then Available_View
116 (Base_Type
(Designated_Type
(Ctrl_Typ
)))
121 -- Interface types are unsupported
123 elsif Is_Interface
(Etype
(Ctrl_Tag
)) then
127 pragma Assert
(False);
133 when N_SCIL_Membership_Test
=>
135 -- Check contents of the boolean expression associated with the
138 pragma Assert
(Nkind_In
(N
, N_Identifier
,
141 N_Expression_With_Actions
)
142 and then Etype
(N
) = Standard_Boolean
);
144 -- Check the entity identifier of the associated tagged type (that
145 -- is, in testing for membership in T'Class, the entity id of the
148 -- Note: When the SCIL node is generated the private and full-view
149 -- of the tagged types may have been swapped and hence the node
150 -- referenced by attribute SCIL_Entity may be the private view.
151 -- Therefore, in order to uniformly locate the full-view we use
152 -- attribute Underlying_Type.
155 (Is_Tagged_Type
(Underlying_Type
(SCIL_Entity
(SCIL_Node
))));
157 -- Interface types are unsupported
160 (not Is_Interface
(Underlying_Type
(SCIL_Entity
(SCIL_Node
))));
162 -- Check the decoration of the expression that denotes the tag
163 -- value being tested
165 Ctrl_Tag
:= SCIL_Tag_Value
(SCIL_Node
);
167 case Nkind
(Ctrl_Tag
) is
169 -- For class-wide membership tests the SCIL tag value is the
170 -- tag of the tested object (i.e. Obj.Tag).
172 when N_Selected_Component
=>
173 pragma Assert
(Etype
(Ctrl_Tag
) = RTE
(RE_Tag
));
177 pragma Assert
(False);
184 pragma Assert
(False);
191 -------------------------
192 -- First_Non_SCIL_Node --
193 -------------------------
195 function First_Non_SCIL_Node
(L
: List_Id
) return Node_Id
is
200 while Nkind
(N
) in N_SCIL_Node
loop
205 end First_Non_SCIL_Node
;
207 ------------------------
208 -- Next_Non_SCIL_Node --
209 ------------------------
211 function Next_Non_SCIL_Node
(N
: Node_Id
) return Node_Id
is
216 while Nkind
(Aux_N
) in N_SCIL_Node
loop
221 end Next_Non_SCIL_Node
;