gcc/ada/par-ch8.adb

   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-2023, 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 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 in Tok_Type | 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
 248 end Ch8;