1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                              P A R . C H 8                               --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2019, 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
26pragma Style_Checks (All_Checks);
27--  Turn off subprogram body ordering check. Subprograms are in order
28--  by RM section rather than alphabetical
29
30separate (Par)
31package body Ch8 is
32
33   -----------------------
34   -- Local Subprograms --
35   -----------------------
36
37   procedure Append_Use_Clause
38     (Item_List : List_Id;
39      Use_Node  : Node_Id;
40      Is_First  : in out Boolean;
41      Is_Last   : in out Boolean);
42   --  Append a use_clause to the Item_List, appropriately setting the Prev_Ids
43   --  and More_Ids flags for each split use node. The flags Is_First and
44   --  Is_Last track position of subtype_marks or names within the original
45   --  use_clause.
46
47   procedure P_Use_Package_Clause (Item_List : List_Id);
48   procedure P_Use_Type_Clause    (Item_List : List_Id);
49
50   -----------------------
51   -- Append_Use_Clause --
52   -----------------------
53
54   procedure Append_Use_Clause
55     (Item_List : List_Id;
56      Use_Node  : Node_Id;
57      Is_First  : in out Boolean;
58      Is_Last   : in out Boolean)
59   is
60   begin
61      if Token /= Tok_Comma then
62         if not Is_First then
63            Set_Prev_Ids (Use_Node);
64         end if;
65
66         Append (Use_Node, Item_List);
67         Is_Last := True;
68
69      else
70         Set_More_Ids (Use_Node);
71
72         if not Is_First then
73            Set_Prev_Ids (Use_Node);
74         else
75            Is_First := False;
76         end if;
77
78         Append (Use_Node, Item_List);
79         Scan; --  Past comma
80      end if;
81   end Append_Use_Clause;
82
83   ---------------------
84   -- 8.4  Use Clause --
85   ---------------------
86
87   --  USE_CLAUSE ::= USE_PACKAGE_CLAUSE | USE_TYPE_CLAUSE
88
89   --  The caller has checked that the initial token is USE
90
91   --  Error recovery: cannot raise Error_Resync
92
93   procedure P_Use_Clause (Item_List : List_Id) is
94   begin
95      Scan; -- past USE
96
97      if Token = Tok_Type or else Token = Tok_All then
98         P_Use_Type_Clause (Item_List);
99      else
100         P_Use_Package_Clause (Item_List);
101      end if;
102   end P_Use_Clause;
103
104   -----------------------------
105   -- 8.4  Use Package Clause --
106   -----------------------------
107
108   --  USE_PACKAGE_CLAUSE ::= use package_NAME {, package_NAME};
109
110   --  The caller has scanned out the USE keyword
111
112   --  Error recovery: cannot raise Error_Resync
113
114   procedure P_Use_Package_Clause (Item_List : List_Id) is
115      Is_First : Boolean := True;
116      Is_Last  : Boolean := False;
117      Use_Node : Node_Id;
118      Use_Sloc : constant Source_Ptr := Prev_Token_Ptr;
119
120   begin
121      if Token = Tok_Package then
122         Error_Msg_SC ("PACKAGE should not appear here");
123         Scan; --  Past PACKAGE
124      end if;
125
126      --  Loop through names in a single use_package_clause, generating an
127      --  N_Use_Package_Clause node for each name encountered.
128
129      loop
130         Use_Node := New_Node (N_Use_Package_Clause, Use_Sloc);
131         Set_Name (Use_Node, P_Qualified_Simple_Name);
132
133         --  Locally chain each name's use-package node
134
135         Append_Use_Clause (Item_List, Use_Node, Is_First, Is_Last);
136         exit when Is_Last;
137      end loop;
138
139      TF_Semicolon;
140   end P_Use_Package_Clause;
141
142   --------------------------
143   -- 8.4  Use Type Clause --
144   --------------------------
145
146   --  USE_TYPE_CLAUSE ::= use [ALL] type SUBTYPE_MARK {, SUBTYPE_MARK};
147
148   --  The caller has checked that the initial token is USE, scanned it out
149   --  and that the current token is either ALL or TYPE.
150
151   --  Note: Use of ALL is an Ada 2012 feature
152
153   --  Error recovery: cannot raise Error_Resync
154
155   procedure P_Use_Type_Clause (Item_List : List_Id) is
156      Use_Sloc : constant Source_Ptr := Prev_Token_Ptr;
157
158      All_Present : Boolean;
159      Is_First    : Boolean := True;
160      Is_Last     : Boolean := False;
161      Use_Node    : Node_Id;
162
163   begin
164      if Token = Tok_All then
165         Error_Msg_Ada_2012_Feature ("|`USE ALL TYPE`", Token_Ptr);
166         All_Present := True;
167         Scan; --  Past ALL
168
169         if Token /= Tok_Type then
170            Error_Msg_SC ("TYPE expected");
171         end if;
172
173      else
174         pragma Assert (Token = Tok_Type);
175         All_Present := False;
176      end if;
177
178      if Ada_Version = Ada_83 then
179         Error_Msg_SC ("(Ada 83) use type not allowed!");
180      end if;
181
182      Scan; --  Past TYPE
183
184      --  Loop through subtype_marks in one use_type_clause, generating a
185      --  separate N_Use_Type_Clause node for each subtype_mark encountered.
186
187      loop
188         Use_Node := New_Node (N_Use_Type_Clause, Use_Sloc);
189         Set_All_Present (Use_Node, All_Present);
190         Set_Used_Operations (Use_Node, No_Elist);
191
192         Set_Subtype_Mark (Use_Node, P_Subtype_Mark);
193
194         No_Constraint;
195
196         --  Locally chain each subtype_mark's use-type node
197
198         Append_Use_Clause (Item_List, Use_Node, Is_First, Is_Last);
199         exit when Is_Last;
200      end loop;
201
202      TF_Semicolon;
203   end P_Use_Type_Clause;
204
205   -------------------------------
206   -- 8.5  Renaming Declaration --
207   -------------------------------
208
209   --  Object renaming declarations and exception renaming declarations
210   --  are parsed by P_Identifier_Declaration (3.3.1)
211
212   --  Subprogram renaming declarations are parsed by P_Subprogram (6.1)
213
214   --  Package renaming declarations are parsed by P_Package (7.1)
215
216   --  Generic renaming declarations are parsed by P_Generic (12.1)
217
218   ----------------------------------------
219   -- 8.5.1  Object Renaming Declaration --
220   ----------------------------------------
221
222   --  Parsed by P_Identifier_Declarations (3.3.1)
223
224   -------------------------------------------
225   -- 8.5.2  Exception Renaming Declaration --
226   -------------------------------------------
227
228   --  Parsed by P_Identifier_Declarations (3.3.1)
229
230   -----------------------------------------
231   -- 8.5.3  Package Renaming Declaration --
232   -----------------------------------------
233
234   --  Parsed by P_Package (7.1)
235
236   --------------------------------------------
237   -- 8.5.4  Subprogram Renaming Declaration --
238   --------------------------------------------
239
240   --  Parsed by P_Subprogram (6.1)
241
242   -----------------------------------------
243   -- 8.5.2  Generic Renaming Declaration --
244   -----------------------------------------
245
246   --  Parsed by P_Generic (12.1)
247
248end Ch8;
249