OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [par-ch7.adb] - Blame information for rev 717

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                              P A R . C H 7                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2011, 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
 
26
pragma Style_Checks (All_Checks);
27
--  Turn off subprogram body ordering check. Subprograms are in order
28
--  by RM section rather than alphabetical
29
 
30
separate (Par)
31
package body Ch7 is
32
 
33
   ---------------------------------------------
34
   -- 7.1  Package (also 8.5.3, 10.1.3, 12.3) --
35
   ---------------------------------------------
36
 
37
   --  This routine scans out a package declaration, package body, or a
38
   --  renaming declaration or generic instantiation starting with PACKAGE
39
 
40
   --  PACKAGE_DECLARATION ::=
41
   --    PACKAGE_SPECIFICATION
42
   --      [ASPECT_SPECIFICATIONS];
43
 
44
   --  PACKAGE_SPECIFICATION ::=
45
   --    package DEFINING_PROGRAM_UNIT_NAME is
46
   --      {BASIC_DECLARATIVE_ITEM}
47
   --    [private
48
   --      {BASIC_DECLARATIVE_ITEM}]
49
   --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
50
 
51
   --  PACKAGE_BODY ::=
52
   --    package body DEFINING_PROGRAM_UNIT_NAME is
53
   --      DECLARATIVE_PART
54
   --    [begin
55
   --      HANDLED_SEQUENCE_OF_STATEMENTS]
56
   --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
57
 
58
   --  PACKAGE_RENAMING_DECLARATION ::=
59
   --    package DEFINING_IDENTIFIER renames package_NAME;
60
 
61
   --  PACKAGE_BODY_STUB ::=
62
   --    package body DEFINING_IDENTIFIER is separate;
63
 
64
   --  PACKAGE_INSTANTIATION ::=
65
   --    package DEFINING_PROGRAM_UNIT_NAME is
66
   --      new generic_package_NAME [GENERIC_ACTUAL_PART]
67
   --        [ASPECT_SPECIFICATIONS];
68
 
69
   --  The value in Pf_Flags indicates which of these possible declarations
70
   --  is acceptable to the caller:
71
 
72
   --    Pf_Flags.Spcn                 Set if specification OK
73
   --    Pf_Flags.Decl                 Set if declaration OK
74
   --    Pf_Flags.Gins                 Set if generic instantiation OK
75
   --    Pf_Flags.Pbod                 Set if proper body OK
76
   --    Pf_Flags.Rnam                 Set if renaming declaration OK
77
   --    Pf_Flags.Stub                 Set if body stub OK
78
 
79
   --  If an inappropriate form is encountered, it is scanned out but an error
80
   --  message indicating that it is appearing in an inappropriate context is
81
   --  issued. The only possible settings for Pf_Flags are those defined as
82
   --  constants in package Par.
83
 
84
   --  Note: in all contexts where a package specification is required, there
85
   --  is a terminating semicolon. This semicolon is scanned out in the case
86
   --  where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
87
   --  of the package specification (it's just too much trouble, and really
88
   --  quite unnecessary, to deal with scanning out an END where the semicolon
89
   --  after the END is not considered to be part of the END.
90
 
91
   --  The caller has checked that the initial token is PACKAGE
92
 
93
   --  Error recovery: cannot raise Error_Resync
94
 
95
   function P_Package (Pf_Flags : Pf_Rec) return Node_Id is
96
      Package_Node       : Node_Id;
97
      Specification_Node : Node_Id;
98
      Name_Node          : Node_Id;
99
      Package_Sloc       : Source_Ptr;
100
 
101
      Aspect_Sloc : Source_Ptr := No_Location;
102
      --  Save location of WITH for scanned aspects. Left set to No_Location
103
      --  if no aspects scanned before the IS keyword.
104
 
105
      Is_Sloc : Source_Ptr;
106
      --  Save location of IS token for package declaration
107
 
108
      Dummy_Node : constant Node_Id :=
109
                     New_Node (N_Package_Specification, Token_Ptr);
110
      --  Dummy node to attach aspect specifications to until we properly
111
      --  figure out where they eventually belong.
112
 
113
      Body_Is_Hidden_In_SPARK         : Boolean;
114
      Private_Part_Is_Hidden_In_SPARK : Boolean;
115
      Hidden_Region_Start             : Source_Ptr;
116
 
117
   begin
118
      Push_Scope_Stack;
119
      Scope.Table (Scope.Last).Etyp := E_Name;
120
      Scope.Table (Scope.Last).Ecol := Start_Column;
121
      Scope.Table (Scope.Last).Lreq := False;
122
 
123
      Package_Sloc := Token_Ptr;
124
      Scan; -- past PACKAGE
125
 
126
      if Token = Tok_Type then
127
         Error_Msg_SC -- CODEFIX
128
           ("TYPE not allowed here");
129
         Scan; -- past TYPE
130
      end if;
131
 
132
      --  Case of package body. Note that we demand a package body if that
133
      --  is the only possibility (even if the BODY keyword is not present)
134
 
135
      if Token = Tok_Body or else Pf_Flags = Pf_Pbod_Pexp then
136
         if not Pf_Flags.Pbod then
137
            Error_Msg_SC ("package body cannot appear here!");
138
         end if;
139
 
140
         T_Body;
141
         Name_Node := P_Defining_Program_Unit_Name;
142
         Scope.Table (Scope.Last).Labl := Name_Node;
143
         TF_Is;
144
 
145
         if Separate_Present then
146
            if not Pf_Flags.Stub then
147
               Error_Msg_SC ("body stub cannot appear here!");
148
            end if;
149
 
150
            Scan; -- past SEPARATE
151
            TF_Semicolon;
152
            Pop_Scope_Stack;
153
 
154
            Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc);
155
            Set_Defining_Identifier (Package_Node, Name_Node);
156
 
157
         else
158
            Package_Node := New_Node (N_Package_Body, Package_Sloc);
159
            Set_Defining_Unit_Name (Package_Node, Name_Node);
160
 
161
            --  In SPARK, a HIDE directive can be placed at the beginning of a
162
            --  package implementation, thus hiding the package body from SPARK
163
            --  tool-set. No violation of the SPARK restriction should be
164
            --  issued on nodes in a hidden part, which is obtained by marking
165
            --  such hidden parts.
166
 
167
            if Token = Tok_SPARK_Hide then
168
               Body_Is_Hidden_In_SPARK := True;
169
               Hidden_Region_Start     := Token_Ptr;
170
               Scan; -- past HIDE directive
171
            else
172
               Body_Is_Hidden_In_SPARK := False;
173
            end if;
174
 
175
            Parse_Decls_Begin_End (Package_Node);
176
 
177
            if Body_Is_Hidden_In_SPARK then
178
               Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
179
            end if;
180
         end if;
181
 
182
      --  Cases other than Package_Body
183
 
184
      else
185
         Name_Node := P_Defining_Program_Unit_Name;
186
         Scope.Table (Scope.Last).Labl := Name_Node;
187
 
188
         --  Case of renaming declaration
189
 
190
         Check_Misspelling_Of (Tok_Renames);
191
 
192
         if Token = Tok_Renames then
193
            if not Pf_Flags.Rnam then
194
               Error_Msg_SC ("renaming declaration cannot appear here!");
195
            end if;
196
 
197
            Scan; -- past RENAMES;
198
 
199
            Package_Node :=
200
              New_Node (N_Package_Renaming_Declaration, Package_Sloc);
201
            Set_Defining_Unit_Name (Package_Node, Name_Node);
202
            Set_Name (Package_Node, P_Qualified_Simple_Name);
203
 
204
            No_Constraint;
205
            TF_Semicolon;
206
            Pop_Scope_Stack;
207
 
208
         --  Generic package instantiation or package declaration
209
 
210
         else
211
            if Aspect_Specifications_Present then
212
               Aspect_Sloc := Token_Ptr;
213
               P_Aspect_Specifications (Dummy_Node, Semicolon => False);
214
            end if;
215
 
216
            Is_Sloc := Token_Ptr;
217
            TF_Is;
218
 
219
            --  Case of generic instantiation
220
 
221
            if Token = Tok_New then
222
               if not Pf_Flags.Gins then
223
                  Error_Msg_SC
224
                     ("generic instantiation cannot appear here!");
225
               end if;
226
 
227
               if Aspect_Sloc /= No_Location then
228
                  Error_Msg
229
                    ("misplaced aspects for package instantiation",
230
                     Aspect_Sloc);
231
               end if;
232
 
233
               Scan; -- past NEW
234
 
235
               Package_Node :=
236
                 New_Node (N_Package_Instantiation, Package_Sloc);
237
               Set_Defining_Unit_Name (Package_Node, Name_Node);
238
               Set_Name (Package_Node, P_Qualified_Simple_Name);
239
               Set_Generic_Associations
240
                 (Package_Node, P_Generic_Actual_Part_Opt);
241
 
242
               if Aspect_Sloc /= No_Location
243
                 and then not Aspect_Specifications_Present
244
               then
245
                  Error_Msg_SC ("\info: aspect specifications belong here");
246
                  Move_Aspects (From => Dummy_Node, To => Package_Node);
247
               end if;
248
 
249
               P_Aspect_Specifications (Package_Node);
250
               Pop_Scope_Stack;
251
 
252
            --  Case of package declaration or package specification
253
 
254
            else
255
               Specification_Node :=
256
                 New_Node (N_Package_Specification, Package_Sloc);
257
 
258
               Set_Defining_Unit_Name (Specification_Node, Name_Node);
259
               Set_Visible_Declarations
260
                 (Specification_Node, P_Basic_Declarative_Items);
261
 
262
               if Token = Tok_Private then
263
                  Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
264
 
265
                  if RM_Column_Check then
266
                     if Token_Is_At_Start_Of_Line
267
                       and then Start_Column /= Error_Msg_Col
268
                     then
269
                        Error_Msg_SC
270
                          ("(style) PRIVATE in wrong column, should be@");
271
                     end if;
272
                  end if;
273
 
274
                  Scan; -- past PRIVATE
275
 
276
                  if Token = Tok_SPARK_Hide then
277
                     Private_Part_Is_Hidden_In_SPARK := True;
278
                     Hidden_Region_Start             := Token_Ptr;
279
                     Scan; -- past HIDE directive
280
                  else
281
                     Private_Part_Is_Hidden_In_SPARK := False;
282
                  end if;
283
 
284
                  Set_Private_Declarations
285
                    (Specification_Node, P_Basic_Declarative_Items);
286
 
287
                  --  In SPARK, a HIDE directive can be placed at the beginning
288
                  --  of a private part, thus hiding all declarations in the
289
                  --  private part from SPARK tool-set. No violation of the
290
                  --  SPARK restriction should be issued on nodes in a hidden
291
                  --  part, which is obtained by marking such hidden parts.
292
 
293
                  if Private_Part_Is_Hidden_In_SPARK then
294
                     Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
295
                  end if;
296
 
297
                  --  Deal gracefully with multiple PRIVATE parts
298
 
299
                  while Token = Tok_Private loop
300
                     Error_Msg_SC
301
                       ("only one private part allowed per package");
302
                     Scan; -- past PRIVATE
303
                     Append_List (P_Basic_Declarative_Items,
304
                       Private_Declarations (Specification_Node));
305
                  end loop;
306
               end if;
307
 
308
               if Pf_Flags = Pf_Spcn then
309
                  Package_Node := Specification_Node;
310
               else
311
                  Package_Node :=
312
                    New_Node (N_Package_Declaration, Package_Sloc);
313
                  Set_Specification (Package_Node, Specification_Node);
314
               end if;
315
 
316
               if Token = Tok_Begin then
317
                  Error_Msg_SC ("begin block not allowed in package spec");
318
                  Scan; -- past BEGIN
319
                  Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
320
               end if;
321
 
322
               End_Statements (Specification_Node, Empty, Is_Sloc);
323
               Move_Aspects (From => Dummy_Node, To => Package_Node);
324
            end if;
325
         end if;
326
      end if;
327
 
328
      return Package_Node;
329
   end P_Package;
330
 
331
   ------------------------------
332
   -- 7.1  Package Declaration --
333
   ------------------------------
334
 
335
   --  Parsed by P_Package (7.1)
336
 
337
   --------------------------------
338
   -- 7.1  Package Specification --
339
   --------------------------------
340
 
341
   --  Parsed by P_Package (7.1)
342
 
343
   -----------------------
344
   -- 7.1  Package Body --
345
   -----------------------
346
 
347
   --  Parsed by P_Package (7.1)
348
 
349
   -----------------------------------
350
   -- 7.3  Private Type Declaration --
351
   -----------------------------------
352
 
353
   --  Parsed by P_Type_Declaration (3.2.1)
354
 
355
   ----------------------------------------
356
   -- 7.3  Private Extension Declaration --
357
   ----------------------------------------
358
 
359
   --  Parsed by P_Type_Declaration (3.2.1)
360
 
361
end Ch7;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.