1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P A R . L A B L --
-- --
-- B o d y --
-- --
-- $Revision: 1.17 $ --
-- --
-- Copyright (C) 1992-1997, 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
separate (Par)
procedure Labl is
Enclosing_Body_Or_Block : Node_Id;
-- Innermost enclosing body or block statement
Label_Decl_Node : Node_Id;
-- Implicit label declaration node
Defining_Ident_Node : Node_Id;
-- Defining identifier node for implicit label declaration
Next_Label_Elmt : Elmt_Id;
-- Next element on label element list
Label_Node : Node_Id;
-- Next label node to process
function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id;
-- Find the innermost body or block that encloses N.
function Find_Enclosing_Body (N : Node_Id) return Node_Id;
-- Find the innermost body that encloses N.
procedure Check_Distinct_Labels;
-- Checks the rule in RM-5.1(11), which requires distinct identifiers
-- for all the labels in a given body.
---------------------------
-- Check_Distinct_Labels --
---------------------------
procedure Check_Distinct_Labels is
Label_Id : constant Node_Id := Identifier (Label_Node);
Enclosing_Body : constant Node_Id :=
Find_Enclosing_Body (Enclosing_Body_Or_Block);
-- Innermost enclosing body
Next_Other_Label_Elmt : Elmt_Id := First_Elmt (Label_List);
-- Next element on label element list
Other_Label : Node_Id;
-- Next label node to process
begin
-- Loop through all the labels, and if we find some other label
-- (i.e. not Label_Node) that has the same identifier,
-- and whose innermost enclosing body is the same,
-- then we have an error.
-- Note that in the worst case, this is quadratic in the number
-- of labels. However, labels are not all that common, and this
-- is only called for explicit labels.
-- ???Nonetheless, the efficiency could be improved. For example,
-- call Labl for each body, rather than once per compilation.
while Present (Next_Other_Label_Elmt) loop
Other_Label := Node (Next_Other_Label_Elmt);
exit when Label_Node = Other_Label;
if Chars (Label_Id) = Chars (Identifier (Other_Label))
and then Enclosing_Body = Find_Enclosing_Body (Other_Label)
then
Error_Msg_Sloc := Sloc (Other_Label);
Error_Msg_N ("& conflicts with label#", Label_Id);
exit;
end if;
Next_Other_Label_Elmt := Next_Elmt (Next_Other_Label_Elmt);
end loop;
end Check_Distinct_Labels;
-------------------------
-- Find_Enclosing_Body --
-------------------------
function Find_Enclosing_Body (N : Node_Id) return Node_Id is
Result : Node_Id := N;
begin
-- This is the same as Find_Enclosing_Body_Or_Block, except
-- that we skip block statements and accept statements, instead
-- of stopping at them.
while Present (Result)
and then Nkind (Result) /= N_Entry_Body
and then Nkind (Result) /= N_Task_Body
and then Nkind (Result) /= N_Package_Body
and then Nkind (Result) /= N_Subprogram_Body
loop
Result := Parent (Result);
end loop;
return Result;
end Find_Enclosing_Body;
----------------------------------
-- Find_Enclosing_Body_Or_Block --
----------------------------------
function Find_Enclosing_Body_Or_Block (N : Node_Id) return Node_Id is
Result : Node_Id := Parent (N);
begin
-- Climb up the parent chain until we find a body or block.
while Present (Result)
and then Nkind (Result) /= N_Accept_Statement
and then Nkind (Result) /= N_Entry_Body
and then Nkind (Result) /= N_Task_Body
and then Nkind (Result) /= N_Package_Body
and then Nkind (Result) /= N_Subprogram_Body
and then Nkind (Result) /= N_Block_Statement
loop
Result := Parent (Result);
end loop;
return Result;
end Find_Enclosing_Body_Or_Block;
-- Start of processing for Par.Labl
begin
Next_Label_Elmt := First_Elmt (Label_List);
while Present (Next_Label_Elmt) loop
Label_Node := Node (Next_Label_Elmt);
if not Comes_From_Source (Label_Node) then
goto Next_Label;
end if;
-- Find the innermost enclosing body or block, which is where
-- we need to implicitly declare this label
Enclosing_Body_Or_Block := Find_Enclosing_Body_Or_Block (Label_Node);
-- If we didn't find a parent, then the label in question never got
-- hooked into a reasonable declarative part. This happens only in
-- error situations, and we simply ignore the entry (we aren't going
-- to get into the semantics in any case given the error).
if Present (Enclosing_Body_Or_Block) then
Check_Distinct_Labels;
-- Now create the implicit label declaration node and its
-- corresponding defining identifier. Note that the defining
-- occurrence of a label is the implicit label declaration that
-- we are creating. The label itself is an applied occurrence.
Label_Decl_Node :=
New_Node (N_Implicit_Label_Declaration, Sloc (Label_Node));
Defining_Ident_Node :=
New_Entity (N_Defining_Identifier, Sloc (Identifier (Label_Node)));
Set_Chars (Defining_Ident_Node, Chars (Identifier (Label_Node)));
Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node);
Set_Label_Construct (Label_Decl_Node, Label_Node);
-- Now attach the implicit label declaration to the appropriate
-- declarative region, creating a declaration list if none exists
if not Present (Declarations (Enclosing_Body_Or_Block)) then
Set_Declarations (Enclosing_Body_Or_Block, New_List);
end if;
Append (Label_Decl_Node, Declarations (Enclosing_Body_Or_Block));
end if;
<<Next_Label>>
Next_Label_Elmt := Next_Elmt (Next_Label_Elmt);
end loop;
end Labl;
|
