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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [par-ch7.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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