1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                              P A R . C H 7                               --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2001 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 2,  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 COPYING.  If not, write --
19-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, USA.                                                      --
21--                                                                          --
22-- GNAT was originally developed  by the GNAT team at  New York University. --
23-- Extensive contributions were provided by Ada Core Technologies Inc.      --
24--                                                                          --
25------------------------------------------------------------------------------
26
27pragma Style_Checks (All_Checks);
28--  Turn off subprogram body ordering check. Subprograms are in order
29--  by RM section rather than alphabetical
30
31separate (Par)
32package body Ch7 is
33
34   ---------------------------------------------
35   -- 7.1  Package (also 8.5.3, 10.1.3, 12.3) --
36   ---------------------------------------------
37
38   --  This routine scans out a package declaration, package body, or a
39   --  renaming declaration or generic instantiation starting with PACKAGE
40
41   --  PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION;
42
43   --  PACKAGE_SPECIFICATION ::=
44   --    package DEFINING_PROGRAM_UNIT_NAME is
45   --      {BASIC_DECLARATIVE_ITEM}
46   --    [private
47   --      {BASIC_DECLARATIVE_ITEM}]
48   --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
49
50   --  PACKAGE_BODY ::=
51   --    package body DEFINING_PROGRAM_UNIT_NAME is
52   --      DECLARATIVE_PART
53   --    [begin
54   --      HANDLED_SEQUENCE_OF_STATEMENTS]
55   --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
56
57   --  PACKAGE_RENAMING_DECLARATION ::=
58   --    package DEFINING_IDENTIFIER renames package_NAME;
59
60   --  PACKAGE_BODY_STUB ::=
61   --    package body DEFINING_IDENTIFIER is separate;
62
63   --  The value in Pf_Flags indicates which of these possible declarations
64   --  is acceptable to the caller:
65
66   --    Pf_Flags.Spcn                 Set if specification OK
67   --    Pf_Flags.Decl                 Set if declaration OK
68   --    Pf_Flags.Gins                 Set if generic instantiation OK
69   --    Pf_Flags.Pbod                 Set if proper body OK
70   --    Pf_Flags.Rnam                 Set if renaming declaration OK
71   --    Pf_Flags.Stub                 Set if body stub OK
72
73   --  If an inappropriate form is encountered, it is scanned out but an
74   --  error message indicating that it is appearing in an inappropriate
75   --  context is issued. The only possible settings for Pf_Flags are those
76   --  defined as constants in package Par.
77
78   --  Note: in all contexts where a package specification is required, there
79   --  is a terminating semicolon. This semicolon is scanned out in the case
80   --  where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
81   --  of the package specification (it's just too much trouble, and really
82   --  quite unnecessary, to deal with scanning out an END where the semicolon
83   --  after the END is not considered to be part of the END.
84
85   --  The caller has checked that the initial token is PACKAGE
86
87   --  Error recovery: cannot raise Error_Resync
88
89   function P_Package (Pf_Flags : Pf_Rec) return Node_Id is
90      Package_Node       : Node_Id;
91      Specification_Node : Node_Id;
92      Name_Node          : Node_Id;
93      Package_Sloc       : Source_Ptr;
94
95   begin
96      Push_Scope_Stack;
97      Scope.Table (Scope.Last).Etyp := E_Name;
98      Scope.Table (Scope.Last).Ecol := Start_Column;
99      Scope.Table (Scope.Last).Lreq := False;
100
101      Package_Sloc := Token_Ptr;
102      Scan; -- past PACKAGE
103
104      if Token = Tok_Type then
105         Error_Msg_SC ("TYPE not allowed here");
106         Scan; -- past TYPE
107      end if;
108
109      --  Case of package body. Note that we demand a package body if that
110      --  is the only possibility (even if the BODY keyword is not present)
111
112      if Token = Tok_Body or else Pf_Flags = Pf_Pbod then
113         if not Pf_Flags.Pbod then
114            Error_Msg_SC ("package body cannot appear here!");
115         end if;
116
117         T_Body;
118         Name_Node := P_Defining_Program_Unit_Name;
119         Scope.Table (Scope.Last).Labl := Name_Node;
120         TF_Is;
121
122         if Separate_Present then
123            if not Pf_Flags.Stub then
124               Error_Msg_SC ("body stub cannot appear here!");
125            end if;
126
127            Scan; -- past SEPARATE
128            TF_Semicolon;
129            Pop_Scope_Stack;
130
131            Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc);
132            Set_Defining_Identifier (Package_Node, Name_Node);
133
134         else
135            Package_Node := New_Node (N_Package_Body, Package_Sloc);
136            Set_Defining_Unit_Name (Package_Node, Name_Node);
137            Parse_Decls_Begin_End (Package_Node);
138         end if;
139
140         return Package_Node;
141
142      --  Cases other than Package_Body
143
144      else
145         Name_Node := P_Defining_Program_Unit_Name;
146         Scope.Table (Scope.Last).Labl := Name_Node;
147
148         --  Case of renaming declaration
149
150         Check_Misspelling_Of (Tok_Renames);
151
152         if Token = Tok_Renames then
153            if not Pf_Flags.Rnam then
154               Error_Msg_SC ("renaming declaration cannot appear here!");
155            end if;
156
157            Scan; -- past RENAMES;
158
159            Package_Node :=
160              New_Node (N_Package_Renaming_Declaration, Package_Sloc);
161            Set_Defining_Unit_Name (Package_Node, Name_Node);
162            Set_Name (Package_Node, P_Qualified_Simple_Name);
163
164            No_Constraint;
165            TF_Semicolon;
166            Pop_Scope_Stack;
167            return Package_Node;
168
169         else
170            TF_Is;
171
172            --  Case of generic instantiation
173
174            if Token = Tok_New then
175               if not Pf_Flags.Gins then
176                  Error_Msg_SC
177                     ("generic instantiation cannot appear here!");
178               end if;
179
180               Scan; -- past NEW
181
182               Package_Node :=
183                  New_Node (N_Package_Instantiation, Package_Sloc);
184               Set_Defining_Unit_Name (Package_Node, Name_Node);
185               Set_Name (Package_Node, P_Qualified_Simple_Name);
186               Set_Generic_Associations
187                 (Package_Node, P_Generic_Actual_Part_Opt);
188               TF_Semicolon;
189               Pop_Scope_Stack;
190
191            --  Case of package declaration or package specification
192
193            else
194               Specification_Node :=
195                 New_Node (N_Package_Specification, Package_Sloc);
196
197               Set_Defining_Unit_Name (Specification_Node, Name_Node);
198               Set_Visible_Declarations
199                 (Specification_Node, P_Basic_Declarative_Items);
200
201               if Token = Tok_Private then
202                  Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
203
204                  if Style.RM_Column_Check then
205                     if Token_Is_At_Start_Of_Line
206                       and then Start_Column /= Error_Msg_Col
207                     then
208                        Error_Msg_SC
209                          ("(style) PRIVATE in wrong column, should be@");
210                     end if;
211                  end if;
212
213                  Scan; -- past PRIVATE
214                  Set_Private_Declarations
215                    (Specification_Node, P_Basic_Declarative_Items);
216
217                  --  Deal gracefully with multiple PRIVATE parts
218
219                  while Token = Tok_Private loop
220                     Error_Msg_SC
221                       ("only one private part allowed per package");
222                     Scan; -- past PRIVATE
223                     Append_List (P_Basic_Declarative_Items,
224                       Private_Declarations (Specification_Node));
225                  end loop;
226               end if;
227
228               if Pf_Flags = Pf_Spcn then
229                  Package_Node := Specification_Node;
230               else
231                  Package_Node :=
232                    New_Node (N_Package_Declaration, Package_Sloc);
233                  Set_Specification (Package_Node, Specification_Node);
234               end if;
235
236               if Token = Tok_Begin then
237                  Error_Msg_SC ("begin block not allowed in package spec");
238                  Scan; -- past BEGIN
239                  Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
240               end if;
241
242               End_Statements (Specification_Node);
243            end if;
244
245            return Package_Node;
246         end if;
247      end if;
248   end P_Package;
249
250   ------------------------------
251   -- 7.1  Package Declaration --
252   ------------------------------
253
254   --  Parsed by P_Package (7.1)
255
256   --------------------------------
257   -- 7.1  Package Specification --
258   --------------------------------
259
260   --  Parsed by P_Package (7.1)
261
262   -----------------------
263   -- 7.1  Package Body --
264   -----------------------
265
266   --  Parsed by P_Package (7.1)
267
268   -----------------------------------
269   -- 7.3  Private Type Declaration --
270   -----------------------------------
271
272   --  Parsed by P_Type_Declaration (3.2.1)
273
274   ----------------------------------------
275   -- 7.3  Private Extension Declaration --
276   ----------------------------------------
277
278   --  Parsed by P_Type_Declaration (3.2.1)
279
280end Ch7;
281