1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
30 Enclosing_Body_Or_Block
: Node_Id
;
31 -- Innermost enclosing body or block statement
33 Label_Decl_Node
: Node_Id
;
34 -- Implicit label declaration node
36 Defining_Ident_Node
: Node_Id
;
37 -- Defining identifier node for implicit label declaration
39 Next_Label_Elmt
: Elmt_Id
;
40 -- Next element on label element list
43 -- Next label node to process
45 function Find_Enclosing_Body_Or_Block
(N
: Node_Id
) return Node_Id
;
46 -- Find the innermost body or block that encloses N.
48 function Find_Enclosing_Body
(N
: Node_Id
) return Node_Id
;
49 -- Find the innermost body that encloses N.
51 procedure Check_Distinct_Labels
;
52 -- Checks the rule in RM-5.1(11), which requires distinct identifiers
53 -- for all the labels in a given body.
55 ---------------------------
56 -- Check_Distinct_Labels --
57 ---------------------------
59 procedure Check_Distinct_Labels
is
60 Label_Id
: constant Node_Id
:= Identifier
(Label_Node
);
62 Enclosing_Body
: constant Node_Id
:=
63 Find_Enclosing_Body
(Enclosing_Body_Or_Block
);
64 -- Innermost enclosing body
66 Next_Other_Label_Elmt
: Elmt_Id
:= First_Elmt
(Label_List
);
67 -- Next element on label element list
69 Other_Label
: Node_Id
;
70 -- Next label node to process
73 -- Loop through all the labels, and if we find some other label
74 -- (i.e. not Label_Node) that has the same identifier,
75 -- and whose innermost enclosing body is the same,
76 -- then we have an error.
78 -- Note that in the worst case, this is quadratic in the number
79 -- of labels. However, labels are not all that common, and this
80 -- is only called for explicit labels.
81 -- ???Nonetheless, the efficiency could be improved. For example,
82 -- call Labl for each body, rather than once per compilation.
84 while Present
(Next_Other_Label_Elmt
) loop
85 Other_Label
:= Node
(Next_Other_Label_Elmt
);
87 exit when Label_Node
= Other_Label
;
89 if Chars
(Label_Id
) = Chars
(Identifier
(Other_Label
))
90 and then Enclosing_Body
= Find_Enclosing_Body
(Other_Label
)
92 Error_Msg_Sloc
:= Sloc
(Other_Label
);
93 Error_Msg_N
("& conflicts with label#", Label_Id
);
97 Next_Elmt
(Next_Other_Label_Elmt
);
99 end Check_Distinct_Labels
;
101 -------------------------
102 -- Find_Enclosing_Body --
103 -------------------------
105 function Find_Enclosing_Body
(N
: Node_Id
) return Node_Id
is
106 Result
: Node_Id
:= N
;
109 -- This is the same as Find_Enclosing_Body_Or_Block, except
110 -- that we skip block statements and accept statements, instead
111 -- of stopping at them.
113 while Present
(Result
)
114 and then Nkind
(Result
) /= N_Entry_Body
115 and then Nkind
(Result
) /= N_Task_Body
116 and then Nkind
(Result
) /= N_Package_Body
117 and then Nkind
(Result
) /= N_Subprogram_Body
119 Result
:= Parent
(Result
);
123 end Find_Enclosing_Body
;
125 ----------------------------------
126 -- Find_Enclosing_Body_Or_Block --
127 ----------------------------------
129 function Find_Enclosing_Body_Or_Block
(N
: Node_Id
) return Node_Id
is
130 Result
: Node_Id
:= Parent
(N
);
133 -- Climb up the parent chain until we find a body or block.
135 while Present
(Result
)
136 and then Nkind
(Result
) /= N_Accept_Statement
137 and then Nkind
(Result
) /= N_Entry_Body
138 and then Nkind
(Result
) /= N_Task_Body
139 and then Nkind
(Result
) /= N_Package_Body
140 and then Nkind
(Result
) /= N_Subprogram_Body
141 and then Nkind
(Result
) /= N_Block_Statement
143 Result
:= Parent
(Result
);
147 end Find_Enclosing_Body_Or_Block
;
149 -- Start of processing for Par.Labl
152 Next_Label_Elmt
:= First_Elmt
(Label_List
);
154 while Present
(Next_Label_Elmt
) loop
155 Label_Node
:= Node
(Next_Label_Elmt
);
157 if not Comes_From_Source
(Label_Node
) then
161 -- Find the innermost enclosing body or block, which is where
162 -- we need to implicitly declare this label
164 Enclosing_Body_Or_Block
:= Find_Enclosing_Body_Or_Block
(Label_Node
);
166 -- If we didn't find a parent, then the label in question never got
167 -- hooked into a reasonable declarative part. This happens only in
168 -- error situations, and we simply ignore the entry (we aren't going
169 -- to get into the semantics in any case given the error).
171 if Present
(Enclosing_Body_Or_Block
) then
172 Check_Distinct_Labels
;
174 -- Now create the implicit label declaration node and its
175 -- corresponding defining identifier. Note that the defining
176 -- occurrence of a label is the implicit label declaration that
177 -- we are creating. The label itself is an applied occurrence.
180 New_Node
(N_Implicit_Label_Declaration
, Sloc
(Label_Node
));
181 Defining_Ident_Node
:=
182 New_Entity
(N_Defining_Identifier
, Sloc
(Identifier
(Label_Node
)));
183 Set_Chars
(Defining_Ident_Node
, Chars
(Identifier
(Label_Node
)));
184 Set_Defining_Identifier
(Label_Decl_Node
, Defining_Ident_Node
);
185 Set_Label_Construct
(Label_Decl_Node
, Label_Node
);
187 -- Now attach the implicit label declaration to the appropriate
188 -- declarative region, creating a declaration list if none exists
190 if not Present
(Declarations
(Enclosing_Body_Or_Block
)) then
191 Set_Declarations
(Enclosing_Body_Or_Block
, New_List
);
194 Append
(Label_Decl_Node
, Declarations
(Enclosing_Body_Or_Block
));
198 Next_Elmt
(Next_Label_Elmt
);