| 1 | 706 | jeremybenn | ------------------------------------------------------------------------------
 | 
      
         | 2 |  |  | --                                                                          --
 | 
      
         | 3 |  |  | --                         GNAT COMPILER COMPONENTS                         --
 | 
      
         | 4 |  |  | --                                                                          --
 | 
      
         | 5 |  |  | --                              S E M . 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 |  |  | --  This package contains the routines to process package specifications and
 | 
      
         | 27 |  |  | --  bodies. The most important semantic aspects of package processing are the
 | 
      
         | 28 |  |  | --  handling of private and full declarations, and the construction of dispatch
 | 
      
         | 29 |  |  | --  tables for tagged types.
 | 
      
         | 30 |  |  |  
 | 
      
         | 31 |  |  | with Atree;    use Atree;
 | 
      
         | 32 |  |  | with Debug;    use Debug;
 | 
      
         | 33 |  |  | with Einfo;    use Einfo;
 | 
      
         | 34 |  |  | with Elists;   use Elists;
 | 
      
         | 35 |  |  | with Errout;   use Errout;
 | 
      
         | 36 |  |  | with Exp_Disp; use Exp_Disp;
 | 
      
         | 37 |  |  | with Exp_Dist; use Exp_Dist;
 | 
      
         | 38 |  |  | with Exp_Dbug; use Exp_Dbug;
 | 
      
         | 39 |  |  | with Lib;      use Lib;
 | 
      
         | 40 |  |  | with Lib.Xref; use Lib.Xref;
 | 
      
         | 41 |  |  | with Namet;    use Namet;
 | 
      
         | 42 |  |  | with Nmake;    use Nmake;
 | 
      
         | 43 |  |  | with Nlists;   use Nlists;
 | 
      
         | 44 |  |  | with Opt;      use Opt;
 | 
      
         | 45 |  |  | with Output;   use Output;
 | 
      
         | 46 |  |  | with Restrict; use Restrict;
 | 
      
         | 47 |  |  | with Sem;      use Sem;
 | 
      
         | 48 |  |  | with Sem_Aux;  use Sem_Aux;
 | 
      
         | 49 |  |  | with Sem_Cat;  use Sem_Cat;
 | 
      
         | 50 |  |  | with Sem_Ch3;  use Sem_Ch3;
 | 
      
         | 51 |  |  | with Sem_Ch6;  use Sem_Ch6;
 | 
      
         | 52 |  |  | with Sem_Ch8;  use Sem_Ch8;
 | 
      
         | 53 |  |  | with Sem_Ch10; use Sem_Ch10;
 | 
      
         | 54 |  |  | with Sem_Ch12; use Sem_Ch12;
 | 
      
         | 55 |  |  | with Sem_Ch13; use Sem_Ch13;
 | 
      
         | 56 |  |  | with Sem_Disp; use Sem_Disp;
 | 
      
         | 57 |  |  | with Sem_Eval; use Sem_Eval;
 | 
      
         | 58 |  |  | with Sem_Util; use Sem_Util;
 | 
      
         | 59 |  |  | with Sem_Warn; use Sem_Warn;
 | 
      
         | 60 |  |  | with Snames;   use Snames;
 | 
      
         | 61 |  |  | with Stand;    use Stand;
 | 
      
         | 62 |  |  | with Sinfo;    use Sinfo;
 | 
      
         | 63 |  |  | with Sinput;   use Sinput;
 | 
      
         | 64 |  |  | with Style;
 | 
      
         | 65 |  |  | with Uintp;    use Uintp;
 | 
      
         | 66 |  |  |  
 | 
      
         | 67 |  |  | package body Sem_Ch7 is
 | 
      
         | 68 |  |  |  
 | 
      
         | 69 |  |  |    -----------------------------------
 | 
      
         | 70 |  |  |    -- Handling private declarations --
 | 
      
         | 71 |  |  |    -----------------------------------
 | 
      
         | 72 |  |  |  
 | 
      
         | 73 |  |  |    --  The principle that each entity has a single defining occurrence clashes
 | 
      
         | 74 |  |  |    --  with the presence of two separate definitions for private types: the
 | 
      
         | 75 |  |  |    --  first is the private type declaration, and the second is the full type
 | 
      
         | 76 |  |  |    --  declaration. It is important that all references to the type point to
 | 
      
         | 77 |  |  |    --  the same defining occurrence, namely the first one. To enforce the two
 | 
      
         | 78 |  |  |    --  separate views of the entity, the corresponding information is swapped
 | 
      
         | 79 |  |  |    --  between the two declarations. Outside of the package, the defining
 | 
      
         | 80 |  |  |    --  occurrence only contains the private declaration information, while in
 | 
      
         | 81 |  |  |    --  the private part and the body of the package the defining occurrence
 | 
      
         | 82 |  |  |    --  contains the full declaration. To simplify the swap, the defining
 | 
      
         | 83 |  |  |    --  occurrence that currently holds the private declaration points to the
 | 
      
         | 84 |  |  |    --  full declaration. During semantic processing the defining occurrence
 | 
      
         | 85 |  |  |    --  also points to a list of private dependents, that is to say access types
 | 
      
         | 86 |  |  |    --  or composite types whose designated types or component types are
 | 
      
         | 87 |  |  |    --  subtypes or derived types of the private type in question. After the
 | 
      
         | 88 |  |  |    --  full declaration has been seen, the private dependents are updated to
 | 
      
         | 89 |  |  |    --  indicate that they have full definitions.
 | 
      
         | 90 |  |  |  
 | 
      
         | 91 |  |  |    -----------------------
 | 
      
         | 92 |  |  |    -- Local Subprograms --
 | 
      
         | 93 |  |  |    -----------------------
 | 
      
         | 94 |  |  |  
 | 
      
         | 95 |  |  |    procedure Analyze_Package_Body_Helper (N : Node_Id);
 | 
      
         | 96 |  |  |    --  Does all the real work of Analyze_Package_Body
 | 
      
         | 97 |  |  |  
 | 
      
         | 98 |  |  |    procedure Check_Anonymous_Access_Types
 | 
      
         | 99 |  |  |      (Spec_Id : Entity_Id;
 | 
      
         | 100 |  |  |       P_Body  : Node_Id);
 | 
      
         | 101 |  |  |    --  If the spec of a package has a limited_with_clause, it may declare
 | 
      
         | 102 |  |  |    --  anonymous access types whose designated type is a limited view, such an
 | 
      
         | 103 |  |  |    --  anonymous access return type for a function. This access type cannot be
 | 
      
         | 104 |  |  |    --  elaborated in the spec itself, but it may need an itype reference if it
 | 
      
         | 105 |  |  |    --  is used within a nested scope. In that case the itype reference is
 | 
      
         | 106 |  |  |    --  created at the beginning of the corresponding package body and inserted
 | 
      
         | 107 |  |  |    --  before other body declarations.
 | 
      
         | 108 |  |  |  
 | 
      
         | 109 |  |  |    procedure Install_Package_Entity (Id : Entity_Id);
 | 
      
         | 110 |  |  |    --  Supporting procedure for Install_{Visible,Private}_Declarations. Places
 | 
      
         | 111 |  |  |    --  one entity on its visibility chain, and recurses on the visible part if
 | 
      
         | 112 |  |  |    --  the entity is an inner package.
 | 
      
         | 113 |  |  |  
 | 
      
         | 114 |  |  |    function Is_Private_Base_Type (E : Entity_Id) return Boolean;
 | 
      
         | 115 |  |  |    --  True for a private type that is not a subtype
 | 
      
         | 116 |  |  |  
 | 
      
         | 117 |  |  |    function Is_Visible_Dependent (Dep : Entity_Id) return Boolean;
 | 
      
         | 118 |  |  |    --  If the private dependent is a private type whose full view is derived
 | 
      
         | 119 |  |  |    --  from the parent type, its full properties are revealed only if we are in
 | 
      
         | 120 |  |  |    --  the immediate scope of the private dependent. Should this predicate be
 | 
      
         | 121 |  |  |    --  tightened further???
 | 
      
         | 122 |  |  |  
 | 
      
         | 123 |  |  |    procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id);
 | 
      
         | 124 |  |  |    --  Called upon entering the private part of a public child package and the
 | 
      
         | 125 |  |  |    --  body of a nested package, to potentially declare certain inherited
 | 
      
         | 126 |  |  |    --  subprograms that were inherited by types in the visible part, but whose
 | 
      
         | 127 |  |  |    --  declaration was deferred because the parent operation was private and
 | 
      
         | 128 |  |  |    --  not visible at that point. These subprograms are located by traversing
 | 
      
         | 129 |  |  |    --  the visible part declarations looking for non-private type extensions
 | 
      
         | 130 |  |  |    --  and then examining each of the primitive operations of such types to
 | 
      
         | 131 |  |  |    --  find those that were inherited but declared with a special internal
 | 
      
         | 132 |  |  |    --  name. Each such operation is now declared as an operation with a normal
 | 
      
         | 133 |  |  |    --  name (using the name of the parent operation) and replaces the previous
 | 
      
         | 134 |  |  |    --  implicit operation in the primitive operations list of the type. If the
 | 
      
         | 135 |  |  |    --  inherited private operation has been overridden, then it's replaced by
 | 
      
         | 136 |  |  |    --  the overriding operation.
 | 
      
         | 137 |  |  |  
 | 
      
         | 138 |  |  |    --------------------------
 | 
      
         | 139 |  |  |    -- Analyze_Package_Body --
 | 
      
         | 140 |  |  |    --------------------------
 | 
      
         | 141 |  |  |  
 | 
      
         | 142 |  |  |    procedure Analyze_Package_Body (N : Node_Id) is
 | 
      
         | 143 |  |  |       Loc : constant Source_Ptr := Sloc (N);
 | 
      
         | 144 |  |  |  
 | 
      
         | 145 |  |  |    begin
 | 
      
         | 146 |  |  |       if Debug_Flag_C then
 | 
      
         | 147 |  |  |          Write_Str ("==> package body ");
 | 
      
         | 148 |  |  |          Write_Name (Chars (Defining_Entity (N)));
 | 
      
         | 149 |  |  |          Write_Str (" from ");
 | 
      
         | 150 |  |  |          Write_Location (Loc);
 | 
      
         | 151 |  |  |          Write_Eol;
 | 
      
         | 152 |  |  |          Indent;
 | 
      
         | 153 |  |  |       end if;
 | 
      
         | 154 |  |  |  
 | 
      
         | 155 |  |  |       --  The real work is split out into the helper, so it can do "return;"
 | 
      
         | 156 |  |  |       --  without skipping the debug output.
 | 
      
         | 157 |  |  |  
 | 
      
         | 158 |  |  |       Analyze_Package_Body_Helper (N);
 | 
      
         | 159 |  |  |  
 | 
      
         | 160 |  |  |       if Debug_Flag_C then
 | 
      
         | 161 |  |  |          Outdent;
 | 
      
         | 162 |  |  |          Write_Str ("<== package body ");
 | 
      
         | 163 |  |  |          Write_Name (Chars (Defining_Entity (N)));
 | 
      
         | 164 |  |  |          Write_Str (" from ");
 | 
      
         | 165 |  |  |          Write_Location (Loc);
 | 
      
         | 166 |  |  |          Write_Eol;
 | 
      
         | 167 |  |  |       end if;
 | 
      
         | 168 |  |  |    end Analyze_Package_Body;
 | 
      
         | 169 |  |  |  
 | 
      
         | 170 |  |  |    ---------------------------------
 | 
      
         | 171 |  |  |    -- Analyze_Package_Body_Helper --
 | 
      
         | 172 |  |  |    ---------------------------------
 | 
      
         | 173 |  |  |  
 | 
      
         | 174 |  |  |    procedure Analyze_Package_Body_Helper (N : Node_Id) is
 | 
      
         | 175 |  |  |       HSS              : Node_Id;
 | 
      
         | 176 |  |  |       Body_Id          : Entity_Id;
 | 
      
         | 177 |  |  |       Spec_Id          : Entity_Id;
 | 
      
         | 178 |  |  |       Last_Spec_Entity : Entity_Id;
 | 
      
         | 179 |  |  |       New_N            : Node_Id;
 | 
      
         | 180 |  |  |       Pack_Decl        : Node_Id;
 | 
      
         | 181 |  |  |  
 | 
      
         | 182 |  |  |       procedure Install_Composite_Operations (P : Entity_Id);
 | 
      
         | 183 |  |  |       --  Composite types declared in the current scope may depend on types
 | 
      
         | 184 |  |  |       --  that were private at the point of declaration, and whose full view
 | 
      
         | 185 |  |  |       --  is now in scope. Indicate that the corresponding operations on the
 | 
      
         | 186 |  |  |       --  composite type are available.
 | 
      
         | 187 |  |  |  
 | 
      
         | 188 |  |  |       ----------------------------------
 | 
      
         | 189 |  |  |       -- Install_Composite_Operations --
 | 
      
         | 190 |  |  |       ----------------------------------
 | 
      
         | 191 |  |  |  
 | 
      
         | 192 |  |  |       procedure Install_Composite_Operations (P : Entity_Id) is
 | 
      
         | 193 |  |  |          Id : Entity_Id;
 | 
      
         | 194 |  |  |  
 | 
      
         | 195 |  |  |       begin
 | 
      
         | 196 |  |  |          Id := First_Entity (P);
 | 
      
         | 197 |  |  |          while Present (Id) loop
 | 
      
         | 198 |  |  |             if Is_Type (Id)
 | 
      
         | 199 |  |  |               and then (Is_Limited_Composite (Id)
 | 
      
         | 200 |  |  |                          or else Is_Private_Composite (Id))
 | 
      
         | 201 |  |  |               and then No (Private_Component (Id))
 | 
      
         | 202 |  |  |             then
 | 
      
         | 203 |  |  |                Set_Is_Limited_Composite (Id, False);
 | 
      
         | 204 |  |  |                Set_Is_Private_Composite (Id, False);
 | 
      
         | 205 |  |  |             end if;
 | 
      
         | 206 |  |  |  
 | 
      
         | 207 |  |  |             Next_Entity (Id);
 | 
      
         | 208 |  |  |          end loop;
 | 
      
         | 209 |  |  |       end Install_Composite_Operations;
 | 
      
         | 210 |  |  |  
 | 
      
         | 211 |  |  |    --  Start of processing for Analyze_Package_Body_Helper
 | 
      
         | 212 |  |  |  
 | 
      
         | 213 |  |  |    begin
 | 
      
         | 214 |  |  |       --  Find corresponding package specification, and establish the current
 | 
      
         | 215 |  |  |       --  scope. The visible defining entity for the package is the defining
 | 
      
         | 216 |  |  |       --  occurrence in the spec. On exit from the package body, all body
 | 
      
         | 217 |  |  |       --  declarations are attached to the defining entity for the body, but
 | 
      
         | 218 |  |  |       --  the later is never used for name resolution. In this fashion there
 | 
      
         | 219 |  |  |       --  is only one visible entity that denotes the package.
 | 
      
         | 220 |  |  |  
 | 
      
         | 221 |  |  |       --  Set Body_Id. Note that this Will be reset to point to the generic
 | 
      
         | 222 |  |  |       --  copy later on in the generic case.
 | 
      
         | 223 |  |  |  
 | 
      
         | 224 |  |  |       Body_Id := Defining_Entity (N);
 | 
      
         | 225 |  |  |  
 | 
      
         | 226 |  |  |       if Present (Corresponding_Spec (N)) then
 | 
      
         | 227 |  |  |  
 | 
      
         | 228 |  |  |          --  Body is body of package instantiation. Corresponding spec has
 | 
      
         | 229 |  |  |          --  already been set.
 | 
      
         | 230 |  |  |  
 | 
      
         | 231 |  |  |          Spec_Id := Corresponding_Spec (N);
 | 
      
         | 232 |  |  |          Pack_Decl := Unit_Declaration_Node (Spec_Id);
 | 
      
         | 233 |  |  |  
 | 
      
         | 234 |  |  |       else
 | 
      
         | 235 |  |  |          Spec_Id := Current_Entity_In_Scope (Defining_Entity (N));
 | 
      
         | 236 |  |  |  
 | 
      
         | 237 |  |  |          if Present (Spec_Id)
 | 
      
         | 238 |  |  |            and then Is_Package_Or_Generic_Package (Spec_Id)
 | 
      
         | 239 |  |  |          then
 | 
      
         | 240 |  |  |             Pack_Decl := Unit_Declaration_Node (Spec_Id);
 | 
      
         | 241 |  |  |  
 | 
      
         | 242 |  |  |             if Nkind (Pack_Decl) = N_Package_Renaming_Declaration then
 | 
      
         | 243 |  |  |                Error_Msg_N ("cannot supply body for package renaming", N);
 | 
      
         | 244 |  |  |                return;
 | 
      
         | 245 |  |  |  
 | 
      
         | 246 |  |  |             elsif Present (Corresponding_Body (Pack_Decl)) then
 | 
      
         | 247 |  |  |                Error_Msg_N ("redefinition of package body", N);
 | 
      
         | 248 |  |  |                return;
 | 
      
         | 249 |  |  |             end if;
 | 
      
         | 250 |  |  |  
 | 
      
         | 251 |  |  |          else
 | 
      
         | 252 |  |  |             Error_Msg_N ("missing specification for package body", N);
 | 
      
         | 253 |  |  |             return;
 | 
      
         | 254 |  |  |          end if;
 | 
      
         | 255 |  |  |  
 | 
      
         | 256 |  |  |          if Is_Package_Or_Generic_Package (Spec_Id)
 | 
      
         | 257 |  |  |            and then (Scope (Spec_Id) = Standard_Standard
 | 
      
         | 258 |  |  |                       or else Is_Child_Unit (Spec_Id))
 | 
      
         | 259 |  |  |            and then not Unit_Requires_Body (Spec_Id)
 | 
      
         | 260 |  |  |          then
 | 
      
         | 261 |  |  |             if Ada_Version = Ada_83 then
 | 
      
         | 262 |  |  |                Error_Msg_N
 | 
      
         | 263 |  |  |                  ("optional package body (not allowed in Ada 95)?", N);
 | 
      
         | 264 |  |  |             else
 | 
      
         | 265 |  |  |                Error_Msg_N ("spec of this package does not allow a body", N);
 | 
      
         | 266 |  |  |             end if;
 | 
      
         | 267 |  |  |          end if;
 | 
      
         | 268 |  |  |       end if;
 | 
      
         | 269 |  |  |  
 | 
      
         | 270 |  |  |       Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
 | 
      
         | 271 |  |  |       Style.Check_Identifier (Body_Id, Spec_Id);
 | 
      
         | 272 |  |  |  
 | 
      
         | 273 |  |  |       if Is_Child_Unit (Spec_Id) then
 | 
      
         | 274 |  |  |          if Nkind (Parent (N)) /= N_Compilation_Unit then
 | 
      
         | 275 |  |  |             Error_Msg_NE
 | 
      
         | 276 |  |  |               ("body of child unit& cannot be an inner package", N, Spec_Id);
 | 
      
         | 277 |  |  |          end if;
 | 
      
         | 278 |  |  |  
 | 
      
         | 279 |  |  |          Set_Is_Child_Unit (Body_Id);
 | 
      
         | 280 |  |  |       end if;
 | 
      
         | 281 |  |  |  
 | 
      
         | 282 |  |  |       --  Generic package case
 | 
      
         | 283 |  |  |  
 | 
      
         | 284 |  |  |       if Ekind (Spec_Id) = E_Generic_Package then
 | 
      
         | 285 |  |  |  
 | 
      
         | 286 |  |  |          --  Disable expansion and perform semantic analysis on copy. The
 | 
      
         | 287 |  |  |          --  unannotated body will be used in all instantiations.
 | 
      
         | 288 |  |  |  
 | 
      
         | 289 |  |  |          Body_Id := Defining_Entity (N);
 | 
      
         | 290 |  |  |          Set_Ekind (Body_Id, E_Package_Body);
 | 
      
         | 291 |  |  |          Set_Scope (Body_Id, Scope (Spec_Id));
 | 
      
         | 292 |  |  |          Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Spec_Id));
 | 
      
         | 293 |  |  |          Set_Body_Entity (Spec_Id, Body_Id);
 | 
      
         | 294 |  |  |          Set_Spec_Entity (Body_Id, Spec_Id);
 | 
      
         | 295 |  |  |  
 | 
      
         | 296 |  |  |          New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
 | 
      
         | 297 |  |  |          Rewrite (N, New_N);
 | 
      
         | 298 |  |  |  
 | 
      
         | 299 |  |  |          --  Update Body_Id to point to the copied node for the remainder of
 | 
      
         | 300 |  |  |          --  the processing.
 | 
      
         | 301 |  |  |  
 | 
      
         | 302 |  |  |          Body_Id := Defining_Entity (N);
 | 
      
         | 303 |  |  |          Start_Generic;
 | 
      
         | 304 |  |  |       end if;
 | 
      
         | 305 |  |  |  
 | 
      
         | 306 |  |  |       --  The Body_Id is that of the copied node in the generic case, the
 | 
      
         | 307 |  |  |       --  current node otherwise. Note that N was rewritten above, so we must
 | 
      
         | 308 |  |  |       --  be sure to get the latest Body_Id value.
 | 
      
         | 309 |  |  |  
 | 
      
         | 310 |  |  |       Set_Ekind (Body_Id, E_Package_Body);
 | 
      
         | 311 |  |  |       Set_Body_Entity (Spec_Id, Body_Id);
 | 
      
         | 312 |  |  |       Set_Spec_Entity (Body_Id, Spec_Id);
 | 
      
         | 313 |  |  |  
 | 
      
         | 314 |  |  |       --  Defining name for the package body is not a visible entity: Only the
 | 
      
         | 315 |  |  |       --  defining name for the declaration is visible.
 | 
      
         | 316 |  |  |  
 | 
      
         | 317 |  |  |       Set_Etype (Body_Id, Standard_Void_Type);
 | 
      
         | 318 |  |  |       Set_Scope (Body_Id, Scope (Spec_Id));
 | 
      
         | 319 |  |  |       Set_Corresponding_Spec (N, Spec_Id);
 | 
      
         | 320 |  |  |       Set_Corresponding_Body (Pack_Decl, Body_Id);
 | 
      
         | 321 |  |  |  
 | 
      
         | 322 |  |  |       --  The body entity is not used for semantics or code generation, but
 | 
      
         | 323 |  |  |       --  it is attached to the entity list of the enclosing scope to simplify
 | 
      
         | 324 |  |  |       --  the listing of back-annotations for the types it main contain.
 | 
      
         | 325 |  |  |  
 | 
      
         | 326 |  |  |       if Scope (Spec_Id) /= Standard_Standard then
 | 
      
         | 327 |  |  |          Append_Entity (Body_Id, Scope (Spec_Id));
 | 
      
         | 328 |  |  |       end if;
 | 
      
         | 329 |  |  |  
 | 
      
         | 330 |  |  |       --  Indicate that we are currently compiling the body of the package
 | 
      
         | 331 |  |  |  
 | 
      
         | 332 |  |  |       Set_In_Package_Body (Spec_Id);
 | 
      
         | 333 |  |  |       Set_Has_Completion (Spec_Id);
 | 
      
         | 334 |  |  |       Last_Spec_Entity := Last_Entity (Spec_Id);
 | 
      
         | 335 |  |  |  
 | 
      
         | 336 |  |  |       Push_Scope (Spec_Id);
 | 
      
         | 337 |  |  |  
 | 
      
         | 338 |  |  |       Set_Categorization_From_Pragmas (N);
 | 
      
         | 339 |  |  |  
 | 
      
         | 340 |  |  |       Install_Visible_Declarations (Spec_Id);
 | 
      
         | 341 |  |  |       Install_Private_Declarations (Spec_Id);
 | 
      
         | 342 |  |  |       Install_Private_With_Clauses (Spec_Id);
 | 
      
         | 343 |  |  |       Install_Composite_Operations (Spec_Id);
 | 
      
         | 344 |  |  |  
 | 
      
         | 345 |  |  |       Check_Anonymous_Access_Types (Spec_Id, N);
 | 
      
         | 346 |  |  |  
 | 
      
         | 347 |  |  |       if Ekind (Spec_Id) = E_Generic_Package then
 | 
      
         | 348 |  |  |          Set_Use (Generic_Formal_Declarations (Pack_Decl));
 | 
      
         | 349 |  |  |       end if;
 | 
      
         | 350 |  |  |  
 | 
      
         | 351 |  |  |       Set_Use (Visible_Declarations (Specification (Pack_Decl)));
 | 
      
         | 352 |  |  |       Set_Use (Private_Declarations (Specification (Pack_Decl)));
 | 
      
         | 353 |  |  |  
 | 
      
         | 354 |  |  |       --  This is a nested package, so it may be necessary to declare certain
 | 
      
         | 355 |  |  |       --  inherited subprograms that are not yet visible because the parent
 | 
      
         | 356 |  |  |       --  type's subprograms are now visible.
 | 
      
         | 357 |  |  |  
 | 
      
         | 358 |  |  |       if Ekind (Scope (Spec_Id)) = E_Package
 | 
      
         | 359 |  |  |         and then Scope (Spec_Id) /= Standard_Standard
 | 
      
         | 360 |  |  |       then
 | 
      
         | 361 |  |  |          Declare_Inherited_Private_Subprograms (Spec_Id);
 | 
      
         | 362 |  |  |       end if;
 | 
      
         | 363 |  |  |  
 | 
      
         | 364 |  |  |       if Present (Declarations (N)) then
 | 
      
         | 365 |  |  |          Analyze_Declarations (Declarations (N));
 | 
      
         | 366 |  |  |          Inspect_Deferred_Constant_Completion (Declarations (N));
 | 
      
         | 367 |  |  |       end if;
 | 
      
         | 368 |  |  |  
 | 
      
         | 369 |  |  |       --  Analyze_Declarations has caused freezing of all types. Now generate
 | 
      
         | 370 |  |  |       --  bodies for RACW primitives and stream attributes, if any.
 | 
      
         | 371 |  |  |  
 | 
      
         | 372 |  |  |       if Ekind (Spec_Id) = E_Package and then Has_RACW (Spec_Id) then
 | 
      
         | 373 |  |  |  
 | 
      
         | 374 |  |  |          --  Attach subprogram bodies to support RACWs declared in spec
 | 
      
         | 375 |  |  |  
 | 
      
         | 376 |  |  |          Append_RACW_Bodies (Declarations (N), Spec_Id);
 | 
      
         | 377 |  |  |          Analyze_List (Declarations (N));
 | 
      
         | 378 |  |  |       end if;
 | 
      
         | 379 |  |  |  
 | 
      
         | 380 |  |  |       HSS := Handled_Statement_Sequence (N);
 | 
      
         | 381 |  |  |  
 | 
      
         | 382 |  |  |       if Present (HSS) then
 | 
      
         | 383 |  |  |          Process_End_Label (HSS, 't', Spec_Id);
 | 
      
         | 384 |  |  |          Analyze (HSS);
 | 
      
         | 385 |  |  |  
 | 
      
         | 386 |  |  |          --  Check that elaboration code in a preelaborable package body is
 | 
      
         | 387 |  |  |          --  empty other than null statements and labels (RM 10.2.1(6)).
 | 
      
         | 388 |  |  |  
 | 
      
         | 389 |  |  |          Validate_Null_Statement_Sequence (N);
 | 
      
         | 390 |  |  |       end if;
 | 
      
         | 391 |  |  |  
 | 
      
         | 392 |  |  |       Validate_Categorization_Dependency (N, Spec_Id);
 | 
      
         | 393 |  |  |       Check_Completion (Body_Id);
 | 
      
         | 394 |  |  |  
 | 
      
         | 395 |  |  |       --  Generate start of body reference. Note that we do this fairly late,
 | 
      
         | 396 |  |  |       --  because the call will use In_Extended_Main_Source_Unit as a check,
 | 
      
         | 397 |  |  |       --  and we want to make sure that Corresponding_Stub links are set
 | 
      
         | 398 |  |  |  
 | 
      
         | 399 |  |  |       Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
 | 
      
         | 400 |  |  |  
 | 
      
         | 401 |  |  |       --  For a generic package, collect global references and mark them on
 | 
      
         | 402 |  |  |       --  the original body so that they are not resolved again at the point
 | 
      
         | 403 |  |  |       --  of instantiation.
 | 
      
         | 404 |  |  |  
 | 
      
         | 405 |  |  |       if Ekind (Spec_Id) /= E_Package then
 | 
      
         | 406 |  |  |          Save_Global_References (Original_Node (N));
 | 
      
         | 407 |  |  |          End_Generic;
 | 
      
         | 408 |  |  |       end if;
 | 
      
         | 409 |  |  |  
 | 
      
         | 410 |  |  |       --  The entities of the package body have so far been chained onto the
 | 
      
         | 411 |  |  |       --  declaration chain for the spec. That's been fine while we were in the
 | 
      
         | 412 |  |  |       --  body, since we wanted them to be visible, but now that we are leaving
 | 
      
         | 413 |  |  |       --  the package body, they are no longer visible, so we remove them from
 | 
      
         | 414 |  |  |       --  the entity chain of the package spec entity, and copy them to the
 | 
      
         | 415 |  |  |       --  entity chain of the package body entity, where they will never again
 | 
      
         | 416 |  |  |       --  be visible.
 | 
      
         | 417 |  |  |  
 | 
      
         | 418 |  |  |       if Present (Last_Spec_Entity) then
 | 
      
         | 419 |  |  |          Set_First_Entity (Body_Id, Next_Entity (Last_Spec_Entity));
 | 
      
         | 420 |  |  |          Set_Next_Entity (Last_Spec_Entity, Empty);
 | 
      
         | 421 |  |  |          Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
 | 
      
         | 422 |  |  |          Set_Last_Entity (Spec_Id, Last_Spec_Entity);
 | 
      
         | 423 |  |  |  
 | 
      
         | 424 |  |  |       else
 | 
      
         | 425 |  |  |          Set_First_Entity (Body_Id, First_Entity (Spec_Id));
 | 
      
         | 426 |  |  |          Set_Last_Entity  (Body_Id, Last_Entity  (Spec_Id));
 | 
      
         | 427 |  |  |          Set_First_Entity (Spec_Id, Empty);
 | 
      
         | 428 |  |  |          Set_Last_Entity  (Spec_Id, Empty);
 | 
      
         | 429 |  |  |       end if;
 | 
      
         | 430 |  |  |  
 | 
      
         | 431 |  |  |       End_Package_Scope (Spec_Id);
 | 
      
         | 432 |  |  |  
 | 
      
         | 433 |  |  |       --  All entities declared in body are not visible
 | 
      
         | 434 |  |  |  
 | 
      
         | 435 |  |  |       declare
 | 
      
         | 436 |  |  |          E : Entity_Id;
 | 
      
         | 437 |  |  |  
 | 
      
         | 438 |  |  |       begin
 | 
      
         | 439 |  |  |          E := First_Entity (Body_Id);
 | 
      
         | 440 |  |  |          while Present (E) loop
 | 
      
         | 441 |  |  |             Set_Is_Immediately_Visible (E, False);
 | 
      
         | 442 |  |  |             Set_Is_Potentially_Use_Visible (E, False);
 | 
      
         | 443 |  |  |             Set_Is_Hidden (E);
 | 
      
         | 444 |  |  |  
 | 
      
         | 445 |  |  |             --  Child units may appear on the entity list (e.g. if they appear
 | 
      
         | 446 |  |  |             --  in the context of a subunit) but they are not body entities.
 | 
      
         | 447 |  |  |  
 | 
      
         | 448 |  |  |             if not Is_Child_Unit (E) then
 | 
      
         | 449 |  |  |                Set_Is_Package_Body_Entity (E);
 | 
      
         | 450 |  |  |             end if;
 | 
      
         | 451 |  |  |  
 | 
      
         | 452 |  |  |             Next_Entity (E);
 | 
      
         | 453 |  |  |          end loop;
 | 
      
         | 454 |  |  |       end;
 | 
      
         | 455 |  |  |  
 | 
      
         | 456 |  |  |       Check_References (Body_Id);
 | 
      
         | 457 |  |  |  
 | 
      
         | 458 |  |  |       --  For a generic unit, check that the formal parameters are referenced,
 | 
      
         | 459 |  |  |       --  and that local variables are used, as for regular packages.
 | 
      
         | 460 |  |  |  
 | 
      
         | 461 |  |  |       if Ekind (Spec_Id) = E_Generic_Package then
 | 
      
         | 462 |  |  |          Check_References (Spec_Id);
 | 
      
         | 463 |  |  |       end if;
 | 
      
         | 464 |  |  |  
 | 
      
         | 465 |  |  |       --  The processing so far has made all entities of the package body
 | 
      
         | 466 |  |  |       --  public (i.e. externally visible to the linker). This is in general
 | 
      
         | 467 |  |  |       --  necessary, since inlined or generic bodies, for which code is
 | 
      
         | 468 |  |  |       --  generated in other units, may need to see these entities. The
 | 
      
         | 469 |  |  |       --  following loop runs backwards from the end of the entities of the
 | 
      
         | 470 |  |  |       --  package body making these entities invisible until we reach a
 | 
      
         | 471 |  |  |       --  referencer, i.e. a declaration that could reference a previous
 | 
      
         | 472 |  |  |       --  declaration, a generic body or an inlined body, or a stub (which may
 | 
      
         | 473 |  |  |       --  contain either of these). This is of course an approximation, but it
 | 
      
         | 474 |  |  |       --  is conservative and definitely correct.
 | 
      
         | 475 |  |  |  
 | 
      
         | 476 |  |  |       --  We only do this at the outer (library) level non-generic packages.
 | 
      
         | 477 |  |  |       --  The reason is simply to cut down on the number of global symbols
 | 
      
         | 478 |  |  |       --  generated, which has a double effect: (1) to make the compilation
 | 
      
         | 479 |  |  |       --  process more efficient and (2) to give the code generator more
 | 
      
         | 480 |  |  |       --  freedom to optimize within each unit, especially subprograms.
 | 
      
         | 481 |  |  |  
 | 
      
         | 482 |  |  |       if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id))
 | 
      
         | 483 |  |  |         and then not Is_Generic_Unit (Spec_Id)
 | 
      
         | 484 |  |  |         and then Present (Declarations (N))
 | 
      
         | 485 |  |  |       then
 | 
      
         | 486 |  |  |          Make_Non_Public_Where_Possible : declare
 | 
      
         | 487 |  |  |  
 | 
      
         | 488 |  |  |             function Has_Referencer
 | 
      
         | 489 |  |  |               (L     : List_Id;
 | 
      
         | 490 |  |  |                Outer : Boolean) return  Boolean;
 | 
      
         | 491 |  |  |             --  Traverse the given list of declarations in reverse order.
 | 
      
         | 492 |  |  |             --  Return True if a referencer is present. Return False if none is
 | 
      
         | 493 |  |  |             --  found. The Outer parameter is True for the outer level call and
 | 
      
         | 494 |  |  |             --  False for inner level calls for nested packages. If Outer is
 | 
      
         | 495 |  |  |             --  True, then any entities up to the point of hitting a referencer
 | 
      
         | 496 |  |  |             --  get their Is_Public flag cleared, so that the entities will be
 | 
      
         | 497 |  |  |             --  treated as static entities in the C sense, and need not have
 | 
      
         | 498 |  |  |             --  fully qualified names. Furthermore, if the referencer is an
 | 
      
         | 499 |  |  |             --  inlined subprogram that doesn't reference other subprograms,
 | 
      
         | 500 |  |  |             --  we keep clearing the Is_Public flag on subprograms. For inner
 | 
      
         | 501 |  |  |             --  levels, we need all names to be fully qualified to deal with
 | 
      
         | 502 |  |  |             --  the same name appearing in parallel packages (right now this
 | 
      
         | 503 |  |  |             --  is tied to their being external).
 | 
      
         | 504 |  |  |  
 | 
      
         | 505 |  |  |             --------------------
 | 
      
         | 506 |  |  |             -- Has_Referencer --
 | 
      
         | 507 |  |  |             --------------------
 | 
      
         | 508 |  |  |  
 | 
      
         | 509 |  |  |             function Has_Referencer
 | 
      
         | 510 |  |  |               (L     : List_Id;
 | 
      
         | 511 |  |  |                Outer : Boolean) return  Boolean
 | 
      
         | 512 |  |  |             is
 | 
      
         | 513 |  |  |                Has_Referencer_Except_For_Subprograms : Boolean := False;
 | 
      
         | 514 |  |  |  
 | 
      
         | 515 |  |  |                D : Node_Id;
 | 
      
         | 516 |  |  |                E : Entity_Id;
 | 
      
         | 517 |  |  |                K : Node_Kind;
 | 
      
         | 518 |  |  |                S : Entity_Id;
 | 
      
         | 519 |  |  |  
 | 
      
         | 520 |  |  |                function Check_Subprogram_Ref (N : Node_Id)
 | 
      
         | 521 |  |  |                  return Traverse_Result;
 | 
      
         | 522 |  |  |                --  Look for references to subprograms
 | 
      
         | 523 |  |  |  
 | 
      
         | 524 |  |  |                --------------------------
 | 
      
         | 525 |  |  |                -- Check_Subprogram_Ref --
 | 
      
         | 526 |  |  |                --------------------------
 | 
      
         | 527 |  |  |  
 | 
      
         | 528 |  |  |                function Check_Subprogram_Ref (N : Node_Id)
 | 
      
         | 529 |  |  |                  return Traverse_Result
 | 
      
         | 530 |  |  |                is
 | 
      
         | 531 |  |  |                   V : Node_Id;
 | 
      
         | 532 |  |  |  
 | 
      
         | 533 |  |  |                begin
 | 
      
         | 534 |  |  |                   --  Check name of procedure or function calls
 | 
      
         | 535 |  |  |  
 | 
      
         | 536 |  |  |                   if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call)
 | 
      
         | 537 |  |  |                     and then Is_Entity_Name (Name (N))
 | 
      
         | 538 |  |  |                   then
 | 
      
         | 539 |  |  |                      return Abandon;
 | 
      
         | 540 |  |  |                   end if;
 | 
      
         | 541 |  |  |  
 | 
      
         | 542 |  |  |                   --  Check prefix of attribute references
 | 
      
         | 543 |  |  |  
 | 
      
         | 544 |  |  |                   if Nkind (N) = N_Attribute_Reference
 | 
      
         | 545 |  |  |                     and then Is_Entity_Name (Prefix (N))
 | 
      
         | 546 |  |  |                     and then Present (Entity (Prefix (N)))
 | 
      
         | 547 |  |  |                     and then Ekind (Entity (Prefix (N))) in Subprogram_Kind
 | 
      
         | 548 |  |  |                   then
 | 
      
         | 549 |  |  |                      return Abandon;
 | 
      
         | 550 |  |  |                   end if;
 | 
      
         | 551 |  |  |  
 | 
      
         | 552 |  |  |                   --  Check value of constants
 | 
      
         | 553 |  |  |  
 | 
      
         | 554 |  |  |                   if Nkind (N) = N_Identifier
 | 
      
         | 555 |  |  |                     and then Present (Entity (N))
 | 
      
         | 556 |  |  |                     and then Ekind (Entity (N)) = E_Constant
 | 
      
         | 557 |  |  |                   then
 | 
      
         | 558 |  |  |                      V := Constant_Value (Entity (N));
 | 
      
         | 559 |  |  |                      if Present (V)
 | 
      
         | 560 |  |  |                        and then not Compile_Time_Known_Value_Or_Aggr (V)
 | 
      
         | 561 |  |  |                      then
 | 
      
         | 562 |  |  |                         return Abandon;
 | 
      
         | 563 |  |  |                      end if;
 | 
      
         | 564 |  |  |                   end if;
 | 
      
         | 565 |  |  |  
 | 
      
         | 566 |  |  |                   return OK;
 | 
      
         | 567 |  |  |                end Check_Subprogram_Ref;
 | 
      
         | 568 |  |  |  
 | 
      
         | 569 |  |  |                function Check_Subprogram_Refs is
 | 
      
         | 570 |  |  |                  new Traverse_Func (Check_Subprogram_Ref);
 | 
      
         | 571 |  |  |  
 | 
      
         | 572 |  |  |             --  Start of processing for Has_Referencer
 | 
      
         | 573 |  |  |  
 | 
      
         | 574 |  |  |             begin
 | 
      
         | 575 |  |  |                if No (L) then
 | 
      
         | 576 |  |  |                   return False;
 | 
      
         | 577 |  |  |                end if;
 | 
      
         | 578 |  |  |  
 | 
      
         | 579 |  |  |                D := Last (L);
 | 
      
         | 580 |  |  |                while Present (D) loop
 | 
      
         | 581 |  |  |                   K := Nkind (D);
 | 
      
         | 582 |  |  |  
 | 
      
         | 583 |  |  |                   if K in N_Body_Stub then
 | 
      
         | 584 |  |  |                      return True;
 | 
      
         | 585 |  |  |  
 | 
      
         | 586 |  |  |                   --  Processing for subprogram bodies
 | 
      
         | 587 |  |  |  
 | 
      
         | 588 |  |  |                   elsif K = N_Subprogram_Body then
 | 
      
         | 589 |  |  |                      if Acts_As_Spec (D) then
 | 
      
         | 590 |  |  |                         E := Defining_Entity (D);
 | 
      
         | 591 |  |  |  
 | 
      
         | 592 |  |  |                         --  An inlined body acts as a referencer. Note also
 | 
      
         | 593 |  |  |                         --  that we never reset Is_Public for an inlined
 | 
      
         | 594 |  |  |                         --  subprogram. Gigi requires Is_Public to be set.
 | 
      
         | 595 |  |  |  
 | 
      
         | 596 |  |  |                         --  Note that we test Has_Pragma_Inline here rather
 | 
      
         | 597 |  |  |                         --  than Is_Inlined. We are compiling this for a
 | 
      
         | 598 |  |  |                         --  client, and it is the client who will decide if
 | 
      
         | 599 |  |  |                         --  actual inlining should occur, so we need to assume
 | 
      
         | 600 |  |  |                         --  that the procedure could be inlined for the purpose
 | 
      
         | 601 |  |  |                         --  of accessing global entities.
 | 
      
         | 602 |  |  |  
 | 
      
         | 603 |  |  |                         if Has_Pragma_Inline (E) then
 | 
      
         | 604 |  |  |                            if Outer
 | 
      
         | 605 |  |  |                              and then Check_Subprogram_Refs (D) = OK
 | 
      
         | 606 |  |  |                            then
 | 
      
         | 607 |  |  |                               Has_Referencer_Except_For_Subprograms := True;
 | 
      
         | 608 |  |  |                            else
 | 
      
         | 609 |  |  |                               return True;
 | 
      
         | 610 |  |  |                            end if;
 | 
      
         | 611 |  |  |                         else
 | 
      
         | 612 |  |  |                            Set_Is_Public (E, False);
 | 
      
         | 613 |  |  |                         end if;
 | 
      
         | 614 |  |  |  
 | 
      
         | 615 |  |  |                      else
 | 
      
         | 616 |  |  |                         E := Corresponding_Spec (D);
 | 
      
         | 617 |  |  |  
 | 
      
         | 618 |  |  |                         if Present (E) then
 | 
      
         | 619 |  |  |  
 | 
      
         | 620 |  |  |                            --  A generic subprogram body acts as a referencer
 | 
      
         | 621 |  |  |  
 | 
      
         | 622 |  |  |                            if Is_Generic_Unit (E) then
 | 
      
         | 623 |  |  |                               return True;
 | 
      
         | 624 |  |  |                            end if;
 | 
      
         | 625 |  |  |  
 | 
      
         | 626 |  |  |                            if Has_Pragma_Inline (E) or else Is_Inlined (E) then
 | 
      
         | 627 |  |  |                               if Outer
 | 
      
         | 628 |  |  |                                 and then Check_Subprogram_Refs (D) = OK
 | 
      
         | 629 |  |  |                               then
 | 
      
         | 630 |  |  |                                  Has_Referencer_Except_For_Subprograms := True;
 | 
      
         | 631 |  |  |                               else
 | 
      
         | 632 |  |  |                                  return True;
 | 
      
         | 633 |  |  |                               end if;
 | 
      
         | 634 |  |  |                            end if;
 | 
      
         | 635 |  |  |                         end if;
 | 
      
         | 636 |  |  |                      end if;
 | 
      
         | 637 |  |  |  
 | 
      
         | 638 |  |  |                   --  Processing for package bodies
 | 
      
         | 639 |  |  |  
 | 
      
         | 640 |  |  |                   elsif K = N_Package_Body
 | 
      
         | 641 |  |  |                     and then Present (Corresponding_Spec (D))
 | 
      
         | 642 |  |  |                   then
 | 
      
         | 643 |  |  |                      E := Corresponding_Spec (D);
 | 
      
         | 644 |  |  |  
 | 
      
         | 645 |  |  |                      --  Generic package body is a referencer. It would seem
 | 
      
         | 646 |  |  |                      --  that we only have to consider generics that can be
 | 
      
         | 647 |  |  |                      --  exported, i.e. where the corresponding spec is the
 | 
      
         | 648 |  |  |                      --  spec of the current package, but because of nested
 | 
      
         | 649 |  |  |                      --  instantiations, a fully private generic body may
 | 
      
         | 650 |  |  |                      --  export other private body entities. Furthermore,
 | 
      
         | 651 |  |  |                      --  regardless of whether there was a previous inlined
 | 
      
         | 652 |  |  |                      --  subprogram, (an instantiation of) the generic package
 | 
      
         | 653 |  |  |                      --  may reference any entity declared before it.
 | 
      
         | 654 |  |  |  
 | 
      
         | 655 |  |  |                      if Is_Generic_Unit (E) then
 | 
      
         | 656 |  |  |                         return True;
 | 
      
         | 657 |  |  |  
 | 
      
         | 658 |  |  |                      --  For non-generic package body, recurse into body unless
 | 
      
         | 659 |  |  |                      --  this is an instance, we ignore instances since they
 | 
      
         | 660 |  |  |                      --  cannot have references that affect outer entities.
 | 
      
         | 661 |  |  |  
 | 
      
         | 662 |  |  |                      elsif not Is_Generic_Instance (E)
 | 
      
         | 663 |  |  |                        and then not Has_Referencer_Except_For_Subprograms
 | 
      
         | 664 |  |  |                      then
 | 
      
         | 665 |  |  |                         if Has_Referencer
 | 
      
         | 666 |  |  |                              (Declarations (D), Outer => False)
 | 
      
         | 667 |  |  |                         then
 | 
      
         | 668 |  |  |                            return True;
 | 
      
         | 669 |  |  |                         end if;
 | 
      
         | 670 |  |  |                      end if;
 | 
      
         | 671 |  |  |  
 | 
      
         | 672 |  |  |                   --  Processing for package specs, recurse into declarations.
 | 
      
         | 673 |  |  |                   --  Again we skip this for the case of generic instances.
 | 
      
         | 674 |  |  |  
 | 
      
         | 675 |  |  |                   elsif K = N_Package_Declaration
 | 
      
         | 676 |  |  |                     and then not Has_Referencer_Except_For_Subprograms
 | 
      
         | 677 |  |  |                   then
 | 
      
         | 678 |  |  |                      S := Specification (D);
 | 
      
         | 679 |  |  |  
 | 
      
         | 680 |  |  |                      if not Is_Generic_Unit (Defining_Entity (S)) then
 | 
      
         | 681 |  |  |                         if Has_Referencer
 | 
      
         | 682 |  |  |                              (Private_Declarations (S), Outer => False)
 | 
      
         | 683 |  |  |                         then
 | 
      
         | 684 |  |  |                            return True;
 | 
      
         | 685 |  |  |                         elsif Has_Referencer
 | 
      
         | 686 |  |  |                                (Visible_Declarations (S), Outer => False)
 | 
      
         | 687 |  |  |                         then
 | 
      
         | 688 |  |  |                            return True;
 | 
      
         | 689 |  |  |                         end if;
 | 
      
         | 690 |  |  |                      end if;
 | 
      
         | 691 |  |  |  
 | 
      
         | 692 |  |  |                   --  Objects and exceptions need not be public if we have not
 | 
      
         | 693 |  |  |                   --  encountered a referencer so far. We only reset the flag
 | 
      
         | 694 |  |  |                   --  for outer level entities that are not imported/exported,
 | 
      
         | 695 |  |  |                   --  and which have no interface name.
 | 
      
         | 696 |  |  |  
 | 
      
         | 697 |  |  |                   elsif Nkind_In (K, N_Object_Declaration,
 | 
      
         | 698 |  |  |                                      N_Exception_Declaration,
 | 
      
         | 699 |  |  |                                      N_Subprogram_Declaration)
 | 
      
         | 700 |  |  |                   then
 | 
      
         | 701 |  |  |                      E := Defining_Entity (D);
 | 
      
         | 702 |  |  |  
 | 
      
         | 703 |  |  |                      if Outer
 | 
      
         | 704 |  |  |                        and then (not Has_Referencer_Except_For_Subprograms
 | 
      
         | 705 |  |  |                                   or else K = N_Subprogram_Declaration)
 | 
      
         | 706 |  |  |                        and then not Is_Imported (E)
 | 
      
         | 707 |  |  |                        and then not Is_Exported (E)
 | 
      
         | 708 |  |  |                        and then No (Interface_Name (E))
 | 
      
         | 709 |  |  |                      then
 | 
      
         | 710 |  |  |                         Set_Is_Public (E, False);
 | 
      
         | 711 |  |  |                      end if;
 | 
      
         | 712 |  |  |                   end if;
 | 
      
         | 713 |  |  |  
 | 
      
         | 714 |  |  |                   Prev (D);
 | 
      
         | 715 |  |  |                end loop;
 | 
      
         | 716 |  |  |  
 | 
      
         | 717 |  |  |                return Has_Referencer_Except_For_Subprograms;
 | 
      
         | 718 |  |  |             end Has_Referencer;
 | 
      
         | 719 |  |  |  
 | 
      
         | 720 |  |  |          --  Start of processing for Make_Non_Public_Where_Possible
 | 
      
         | 721 |  |  |  
 | 
      
         | 722 |  |  |          begin
 | 
      
         | 723 |  |  |             declare
 | 
      
         | 724 |  |  |                Discard : Boolean;
 | 
      
         | 725 |  |  |                pragma Warnings (Off, Discard);
 | 
      
         | 726 |  |  |  
 | 
      
         | 727 |  |  |             begin
 | 
      
         | 728 |  |  |                Discard := Has_Referencer (Declarations (N), Outer => True);
 | 
      
         | 729 |  |  |             end;
 | 
      
         | 730 |  |  |          end Make_Non_Public_Where_Possible;
 | 
      
         | 731 |  |  |       end if;
 | 
      
         | 732 |  |  |  
 | 
      
         | 733 |  |  |       --  If expander is not active, then here is where we turn off the
 | 
      
         | 734 |  |  |       --  In_Package_Body flag, otherwise it is turned off at the end of the
 | 
      
         | 735 |  |  |       --  corresponding expansion routine. If this is an instance body, we need
 | 
      
         | 736 |  |  |       --  to qualify names of local entities, because the body may have been
 | 
      
         | 737 |  |  |       --  compiled as a preliminary to another instantiation.
 | 
      
         | 738 |  |  |  
 | 
      
         | 739 |  |  |       if not Expander_Active then
 | 
      
         | 740 |  |  |          Set_In_Package_Body (Spec_Id, False);
 | 
      
         | 741 |  |  |  
 | 
      
         | 742 |  |  |          if Is_Generic_Instance (Spec_Id)
 | 
      
         | 743 |  |  |            and then Operating_Mode = Generate_Code
 | 
      
         | 744 |  |  |          then
 | 
      
         | 745 |  |  |             Qualify_Entity_Names (N);
 | 
      
         | 746 |  |  |          end if;
 | 
      
         | 747 |  |  |       end if;
 | 
      
         | 748 |  |  |    end Analyze_Package_Body_Helper;
 | 
      
         | 749 |  |  |  
 | 
      
         | 750 |  |  |    ---------------------------------
 | 
      
         | 751 |  |  |    -- Analyze_Package_Declaration --
 | 
      
         | 752 |  |  |    ---------------------------------
 | 
      
         | 753 |  |  |  
 | 
      
         | 754 |  |  |    procedure Analyze_Package_Declaration (N : Node_Id) is
 | 
      
         | 755 |  |  |       Id : constant Node_Id := Defining_Entity (N);
 | 
      
         | 756 |  |  |  
 | 
      
         | 757 |  |  |       PF : Boolean;
 | 
      
         | 758 |  |  |       --  True when in the context of a declared pure library unit
 | 
      
         | 759 |  |  |  
 | 
      
         | 760 |  |  |       Body_Required : Boolean;
 | 
      
         | 761 |  |  |       --  True when this package declaration requires a corresponding body
 | 
      
         | 762 |  |  |  
 | 
      
         | 763 |  |  |       Comp_Unit : Boolean;
 | 
      
         | 764 |  |  |       --  True when this package declaration is not a nested declaration
 | 
      
         | 765 |  |  |  
 | 
      
         | 766 |  |  |    begin
 | 
      
         | 767 |  |  |       --  Analye aspect specifications immediately, since we need to recognize
 | 
      
         | 768 |  |  |       --  things like Pure early enough to diagnose violations during analysis.
 | 
      
         | 769 |  |  |  
 | 
      
         | 770 |  |  |       if Has_Aspects (N) then
 | 
      
         | 771 |  |  |          Analyze_Aspect_Specifications (N, Id);
 | 
      
         | 772 |  |  |       end if;
 | 
      
         | 773 |  |  |  
 | 
      
         | 774 |  |  |       --  Ada 2005 (AI-217): Check if the package has been erroneously named
 | 
      
         | 775 |  |  |       --  in a limited-with clause of its own context. In this case the error
 | 
      
         | 776 |  |  |       --  has been previously notified by Analyze_Context.
 | 
      
         | 777 |  |  |  
 | 
      
         | 778 |  |  |       --     limited with Pkg; -- ERROR
 | 
      
         | 779 |  |  |       --     package Pkg is ...
 | 
      
         | 780 |  |  |  
 | 
      
         | 781 |  |  |       if From_With_Type (Id) then
 | 
      
         | 782 |  |  |          return;
 | 
      
         | 783 |  |  |       end if;
 | 
      
         | 784 |  |  |  
 | 
      
         | 785 |  |  |       if Debug_Flag_C then
 | 
      
         | 786 |  |  |          Write_Str ("==> package spec ");
 | 
      
         | 787 |  |  |          Write_Name (Chars (Id));
 | 
      
         | 788 |  |  |          Write_Str (" from ");
 | 
      
         | 789 |  |  |          Write_Location (Sloc (N));
 | 
      
         | 790 |  |  |          Write_Eol;
 | 
      
         | 791 |  |  |          Indent;
 | 
      
         | 792 |  |  |       end if;
 | 
      
         | 793 |  |  |  
 | 
      
         | 794 |  |  |       Generate_Definition (Id);
 | 
      
         | 795 |  |  |       Enter_Name (Id);
 | 
      
         | 796 |  |  |       Set_Ekind (Id, E_Package);
 | 
      
         | 797 |  |  |       Set_Etype (Id, Standard_Void_Type);
 | 
      
         | 798 |  |  |  
 | 
      
         | 799 |  |  |       Push_Scope (Id);
 | 
      
         | 800 |  |  |  
 | 
      
         | 801 |  |  |       PF := Is_Pure (Enclosing_Lib_Unit_Entity);
 | 
      
         | 802 |  |  |       Set_Is_Pure (Id, PF);
 | 
      
         | 803 |  |  |  
 | 
      
         | 804 |  |  |       Set_Categorization_From_Pragmas (N);
 | 
      
         | 805 |  |  |  
 | 
      
         | 806 |  |  |       Analyze (Specification (N));
 | 
      
         | 807 |  |  |       Validate_Categorization_Dependency (N, Id);
 | 
      
         | 808 |  |  |  
 | 
      
         | 809 |  |  |       Body_Required := Unit_Requires_Body (Id);
 | 
      
         | 810 |  |  |  
 | 
      
         | 811 |  |  |       --  When this spec does not require an explicit body, we know that there
 | 
      
         | 812 |  |  |       --  are no entities requiring completion in the language sense; we call
 | 
      
         | 813 |  |  |       --  Check_Completion here only to ensure that any nested package
 | 
      
         | 814 |  |  |       --  declaration that requires an implicit body gets one. (In the case
 | 
      
         | 815 |  |  |       --  where a body is required, Check_Completion is called at the end of
 | 
      
         | 816 |  |  |       --  the body's declarative part.)
 | 
      
         | 817 |  |  |  
 | 
      
         | 818 |  |  |       if not Body_Required then
 | 
      
         | 819 |  |  |          Check_Completion;
 | 
      
         | 820 |  |  |       end if;
 | 
      
         | 821 |  |  |  
 | 
      
         | 822 |  |  |       Comp_Unit := Nkind (Parent (N)) = N_Compilation_Unit;
 | 
      
         | 823 |  |  |       if Comp_Unit then
 | 
      
         | 824 |  |  |  
 | 
      
         | 825 |  |  |          --  Set Body_Required indication on the compilation unit node, and
 | 
      
         | 826 |  |  |          --  determine whether elaboration warnings may be meaningful on it.
 | 
      
         | 827 |  |  |  
 | 
      
         | 828 |  |  |          Set_Body_Required (Parent (N), Body_Required);
 | 
      
         | 829 |  |  |  
 | 
      
         | 830 |  |  |          if not Body_Required then
 | 
      
         | 831 |  |  |             Set_Suppress_Elaboration_Warnings (Id);
 | 
      
         | 832 |  |  |          end if;
 | 
      
         | 833 |  |  |  
 | 
      
         | 834 |  |  |       end if;
 | 
      
         | 835 |  |  |  
 | 
      
         | 836 |  |  |       End_Package_Scope (Id);
 | 
      
         | 837 |  |  |  
 | 
      
         | 838 |  |  |       --  For the declaration of a library unit that is a remote types package,
 | 
      
         | 839 |  |  |       --  check legality rules regarding availability of stream attributes for
 | 
      
         | 840 |  |  |       --  types that contain non-remote access values. This subprogram performs
 | 
      
         | 841 |  |  |       --  visibility tests that rely on the fact that we have exited the scope
 | 
      
         | 842 |  |  |       --  of Id.
 | 
      
         | 843 |  |  |  
 | 
      
         | 844 |  |  |       if Comp_Unit then
 | 
      
         | 845 |  |  |          Validate_RT_RAT_Component (N);
 | 
      
         | 846 |  |  |       end if;
 | 
      
         | 847 |  |  |  
 | 
      
         | 848 |  |  |       if Debug_Flag_C then
 | 
      
         | 849 |  |  |          Outdent;
 | 
      
         | 850 |  |  |          Write_Str ("<== package spec ");
 | 
      
         | 851 |  |  |          Write_Name (Chars (Id));
 | 
      
         | 852 |  |  |          Write_Str (" from ");
 | 
      
         | 853 |  |  |          Write_Location (Sloc (N));
 | 
      
         | 854 |  |  |          Write_Eol;
 | 
      
         | 855 |  |  |       end if;
 | 
      
         | 856 |  |  |    end Analyze_Package_Declaration;
 | 
      
         | 857 |  |  |  
 | 
      
         | 858 |  |  |    -----------------------------------
 | 
      
         | 859 |  |  |    -- Analyze_Package_Specification --
 | 
      
         | 860 |  |  |    -----------------------------------
 | 
      
         | 861 |  |  |  
 | 
      
         | 862 |  |  |    --  Note that this code is shared for the analysis of generic package specs
 | 
      
         | 863 |  |  |    --  (see Sem_Ch12.Analyze_Generic_Package_Declaration for details).
 | 
      
         | 864 |  |  |  
 | 
      
         | 865 |  |  |    procedure Analyze_Package_Specification (N : Node_Id) is
 | 
      
         | 866 |  |  |       Id           : constant Entity_Id  := Defining_Entity (N);
 | 
      
         | 867 |  |  |       Orig_Decl    : constant Node_Id    := Original_Node (Parent (N));
 | 
      
         | 868 |  |  |       Vis_Decls    : constant List_Id    := Visible_Declarations (N);
 | 
      
         | 869 |  |  |       Priv_Decls   : constant List_Id    := Private_Declarations (N);
 | 
      
         | 870 |  |  |       E            : Entity_Id;
 | 
      
         | 871 |  |  |       L            : Entity_Id;
 | 
      
         | 872 |  |  |       Public_Child : Boolean;
 | 
      
         | 873 |  |  |  
 | 
      
         | 874 |  |  |       Private_With_Clauses_Installed : Boolean := False;
 | 
      
         | 875 |  |  |       --  In Ada 2005, private with_clauses are visible in the private part
 | 
      
         | 876 |  |  |       --  of a nested package, even if it appears in the public part of the
 | 
      
         | 877 |  |  |       --  enclosing package. This requires a separate step to install these
 | 
      
         | 878 |  |  |       --  private_with_clauses, and remove them at the end of the nested
 | 
      
         | 879 |  |  |       --  package.
 | 
      
         | 880 |  |  |  
 | 
      
         | 881 |  |  |       procedure Check_One_Tagged_Type_Or_Extension_At_Most;
 | 
      
         | 882 |  |  |       --  Issue an error in SPARK mode if a package specification contains
 | 
      
         | 883 |  |  |       --  more than one tagged type or type extension.
 | 
      
         | 884 |  |  |  
 | 
      
         | 885 |  |  |       procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
 | 
      
         | 886 |  |  |       --  Clears constant indications (Never_Set_In_Source, Constant_Value, and
 | 
      
         | 887 |  |  |       --  Is_True_Constant) on all variables that are entities of Id, and on
 | 
      
         | 888 |  |  |       --  the chain whose first element is FE. A recursive call is made for all
 | 
      
         | 889 |  |  |       --  packages and generic packages.
 | 
      
         | 890 |  |  |  
 | 
      
         | 891 |  |  |       procedure Generate_Parent_References;
 | 
      
         | 892 |  |  |       --  For a child unit, generate references to parent units, for
 | 
      
         | 893 |  |  |       --  GPS navigation purposes.
 | 
      
         | 894 |  |  |  
 | 
      
         | 895 |  |  |       function Is_Public_Child (Child, Unit : Entity_Id) return Boolean;
 | 
      
         | 896 |  |  |       --  Child and Unit are entities of compilation units. True if Child
 | 
      
         | 897 |  |  |       --  is a public child of Parent as defined in 10.1.1
 | 
      
         | 898 |  |  |  
 | 
      
         | 899 |  |  |       procedure Inspect_Unchecked_Union_Completion (Decls : List_Id);
 | 
      
         | 900 |  |  |       --  Detects all incomplete or private type declarations having a known
 | 
      
         | 901 |  |  |       --  discriminant part that are completed by an Unchecked_Union. Emits
 | 
      
         | 902 |  |  |       --  the error message "Unchecked_Union may not complete discriminated
 | 
      
         | 903 |  |  |       --  partial view".
 | 
      
         | 904 |  |  |  
 | 
      
         | 905 |  |  |       procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id);
 | 
      
         | 906 |  |  |       --  Given the package entity of a generic package instantiation or
 | 
      
         | 907 |  |  |       --  formal package whose corresponding generic is a child unit, installs
 | 
      
         | 908 |  |  |       --  the private declarations of each of the child unit's parents.
 | 
      
         | 909 |  |  |       --  This has to be done at the point of entering the instance package's
 | 
      
         | 910 |  |  |       --  private part rather than being done in Sem_Ch12.Install_Parent
 | 
      
         | 911 |  |  |       --  (which is where the parents' visible declarations are installed).
 | 
      
         | 912 |  |  |  
 | 
      
         | 913 |  |  |       ------------------------------------------------
 | 
      
         | 914 |  |  |       -- Check_One_Tagged_Type_Or_Extension_At_Most --
 | 
      
         | 915 |  |  |       ------------------------------------------------
 | 
      
         | 916 |  |  |  
 | 
      
         | 917 |  |  |       procedure Check_One_Tagged_Type_Or_Extension_At_Most is
 | 
      
         | 918 |  |  |          Previous : Node_Id;
 | 
      
         | 919 |  |  |  
 | 
      
         | 920 |  |  |          procedure Check_Decls (Decls : List_Id);
 | 
      
         | 921 |  |  |          --  Check that either Previous is Empty and Decls does not contain
 | 
      
         | 922 |  |  |          --  more than one tagged type or type extension, or Previous is
 | 
      
         | 923 |  |  |          --  already set and Decls contains no tagged type or type extension.
 | 
      
         | 924 |  |  |  
 | 
      
         | 925 |  |  |          -----------------
 | 
      
         | 926 |  |  |          -- Check_Decls --
 | 
      
         | 927 |  |  |          -----------------
 | 
      
         | 928 |  |  |  
 | 
      
         | 929 |  |  |          procedure Check_Decls (Decls : List_Id) is
 | 
      
         | 930 |  |  |             Decl : Node_Id;
 | 
      
         | 931 |  |  |  
 | 
      
         | 932 |  |  |          begin
 | 
      
         | 933 |  |  |             Decl := First (Decls);
 | 
      
         | 934 |  |  |             while Present (Decl) loop
 | 
      
         | 935 |  |  |                if Nkind (Decl) = N_Full_Type_Declaration
 | 
      
         | 936 |  |  |                  and then Is_Tagged_Type (Defining_Identifier (Decl))
 | 
      
         | 937 |  |  |                then
 | 
      
         | 938 |  |  |                   if No (Previous) then
 | 
      
         | 939 |  |  |                      Previous := Decl;
 | 
      
         | 940 |  |  |  
 | 
      
         | 941 |  |  |                   else
 | 
      
         | 942 |  |  |                      Error_Msg_Sloc := Sloc (Previous);
 | 
      
         | 943 |  |  |                      Check_SPARK_Restriction
 | 
      
         | 944 |  |  |                        ("at most one tagged type or type extension allowed",
 | 
      
         | 945 |  |  |                         "\\ previous declaration#",
 | 
      
         | 946 |  |  |                         Decl);
 | 
      
         | 947 |  |  |                   end if;
 | 
      
         | 948 |  |  |                end if;
 | 
      
         | 949 |  |  |  
 | 
      
         | 950 |  |  |                Next (Decl);
 | 
      
         | 951 |  |  |             end loop;
 | 
      
         | 952 |  |  |          end Check_Decls;
 | 
      
         | 953 |  |  |  
 | 
      
         | 954 |  |  |       --  Start of processing for Check_One_Tagged_Type_Or_Extension_At_Most
 | 
      
         | 955 |  |  |  
 | 
      
         | 956 |  |  |       begin
 | 
      
         | 957 |  |  |          Previous := Empty;
 | 
      
         | 958 |  |  |          Check_Decls (Vis_Decls);
 | 
      
         | 959 |  |  |  
 | 
      
         | 960 |  |  |          if Present (Priv_Decls) then
 | 
      
         | 961 |  |  |             Check_Decls (Priv_Decls);
 | 
      
         | 962 |  |  |          end if;
 | 
      
         | 963 |  |  |       end Check_One_Tagged_Type_Or_Extension_At_Most;
 | 
      
         | 964 |  |  |  
 | 
      
         | 965 |  |  |       ---------------------
 | 
      
         | 966 |  |  |       -- Clear_Constants --
 | 
      
         | 967 |  |  |       ---------------------
 | 
      
         | 968 |  |  |  
 | 
      
         | 969 |  |  |       procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id) is
 | 
      
         | 970 |  |  |          E : Entity_Id;
 | 
      
         | 971 |  |  |  
 | 
      
         | 972 |  |  |       begin
 | 
      
         | 973 |  |  |          --  Ignore package renamings, not interesting and they can cause self
 | 
      
         | 974 |  |  |          --  referential loops in the code below.
 | 
      
         | 975 |  |  |  
 | 
      
         | 976 |  |  |          if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then
 | 
      
         | 977 |  |  |             return;
 | 
      
         | 978 |  |  |          end if;
 | 
      
         | 979 |  |  |  
 | 
      
         | 980 |  |  |          --  Note: in the loop below, the check for Next_Entity pointing back
 | 
      
         | 981 |  |  |          --  to the package entity may seem odd, but it is needed, because a
 | 
      
         | 982 |  |  |          --  package can contain a renaming declaration to itself, and such
 | 
      
         | 983 |  |  |          --  renamings are generated automatically within package instances.
 | 
      
         | 984 |  |  |  
 | 
      
         | 985 |  |  |          E := FE;
 | 
      
         | 986 |  |  |          while Present (E) and then E /= Id loop
 | 
      
         | 987 |  |  |             if Is_Assignable (E) then
 | 
      
         | 988 |  |  |                Set_Never_Set_In_Source (E, False);
 | 
      
         | 989 |  |  |                Set_Is_True_Constant    (E, False);
 | 
      
         | 990 |  |  |                Set_Current_Value       (E, Empty);
 | 
      
         | 991 |  |  |                Set_Is_Known_Null       (E, False);
 | 
      
         | 992 |  |  |                Set_Last_Assignment     (E, Empty);
 | 
      
         | 993 |  |  |  
 | 
      
         | 994 |  |  |                if not Can_Never_Be_Null (E) then
 | 
      
         | 995 |  |  |                   Set_Is_Known_Non_Null (E, False);
 | 
      
         | 996 |  |  |                end if;
 | 
      
         | 997 |  |  |  
 | 
      
         | 998 |  |  |             elsif Is_Package_Or_Generic_Package (E) then
 | 
      
         | 999 |  |  |                Clear_Constants (E, First_Entity (E));
 | 
      
         | 1000 |  |  |                Clear_Constants (E, First_Private_Entity (E));
 | 
      
         | 1001 |  |  |             end if;
 | 
      
         | 1002 |  |  |  
 | 
      
         | 1003 |  |  |             Next_Entity (E);
 | 
      
         | 1004 |  |  |          end loop;
 | 
      
         | 1005 |  |  |       end Clear_Constants;
 | 
      
         | 1006 |  |  |  
 | 
      
         | 1007 |  |  |       --------------------------------
 | 
      
         | 1008 |  |  |       -- Generate_Parent_References --
 | 
      
         | 1009 |  |  |       --------------------------------
 | 
      
         | 1010 |  |  |  
 | 
      
         | 1011 |  |  |       procedure Generate_Parent_References is
 | 
      
         | 1012 |  |  |          Decl : constant Node_Id := Parent (N);
 | 
      
         | 1013 |  |  |  
 | 
      
         | 1014 |  |  |       begin
 | 
      
         | 1015 |  |  |          if Id = Cunit_Entity (Main_Unit)
 | 
      
         | 1016 |  |  |            or else Parent (Decl) = Library_Unit (Cunit (Main_Unit))
 | 
      
         | 1017 |  |  |          then
 | 
      
         | 1018 |  |  |             Generate_Reference (Id, Scope (Id), 'k', False);
 | 
      
         | 1019 |  |  |  
 | 
      
         | 1020 |  |  |          elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body,
 | 
      
         | 1021 |  |  |                                                        N_Subunit)
 | 
      
         | 1022 |  |  |          then
 | 
      
         | 1023 |  |  |             --  If current unit is an ancestor of main unit, generate a
 | 
      
         | 1024 |  |  |             --  reference to its own parent.
 | 
      
         | 1025 |  |  |  
 | 
      
         | 1026 |  |  |             declare
 | 
      
         | 1027 |  |  |                U         : Node_Id;
 | 
      
         | 1028 |  |  |                Main_Spec : Node_Id := Unit (Cunit (Main_Unit));
 | 
      
         | 1029 |  |  |  
 | 
      
         | 1030 |  |  |             begin
 | 
      
         | 1031 |  |  |                if Nkind (Main_Spec) = N_Package_Body then
 | 
      
         | 1032 |  |  |                   Main_Spec := Unit (Library_Unit (Cunit (Main_Unit)));
 | 
      
         | 1033 |  |  |                end if;
 | 
      
         | 1034 |  |  |  
 | 
      
         | 1035 |  |  |                U := Parent_Spec (Main_Spec);
 | 
      
         | 1036 |  |  |                while Present (U) loop
 | 
      
         | 1037 |  |  |                   if U = Parent (Decl) then
 | 
      
         | 1038 |  |  |                      Generate_Reference (Id, Scope (Id), 'k',  False);
 | 
      
         | 1039 |  |  |                      exit;
 | 
      
         | 1040 |  |  |  
 | 
      
         | 1041 |  |  |                   elsif Nkind (Unit (U)) = N_Package_Body then
 | 
      
         | 1042 |  |  |                      exit;
 | 
      
         | 1043 |  |  |  
 | 
      
         | 1044 |  |  |                   else
 | 
      
         | 1045 |  |  |                      U := Parent_Spec (Unit (U));
 | 
      
         | 1046 |  |  |                   end if;
 | 
      
         | 1047 |  |  |                end loop;
 | 
      
         | 1048 |  |  |             end;
 | 
      
         | 1049 |  |  |          end if;
 | 
      
         | 1050 |  |  |       end Generate_Parent_References;
 | 
      
         | 1051 |  |  |  
 | 
      
         | 1052 |  |  |       ---------------------
 | 
      
         | 1053 |  |  |       -- Is_Public_Child --
 | 
      
         | 1054 |  |  |       ---------------------
 | 
      
         | 1055 |  |  |  
 | 
      
         | 1056 |  |  |       function Is_Public_Child (Child, Unit : Entity_Id) return Boolean is
 | 
      
         | 1057 |  |  |       begin
 | 
      
         | 1058 |  |  |          if not Is_Private_Descendant (Child) then
 | 
      
         | 1059 |  |  |             return True;
 | 
      
         | 1060 |  |  |          else
 | 
      
         | 1061 |  |  |             if Child = Unit then
 | 
      
         | 1062 |  |  |                return not Private_Present (
 | 
      
         | 1063 |  |  |                  Parent (Unit_Declaration_Node (Child)));
 | 
      
         | 1064 |  |  |             else
 | 
      
         | 1065 |  |  |                return Is_Public_Child (Scope (Child), Unit);
 | 
      
         | 1066 |  |  |             end if;
 | 
      
         | 1067 |  |  |          end if;
 | 
      
         | 1068 |  |  |       end Is_Public_Child;
 | 
      
         | 1069 |  |  |  
 | 
      
         | 1070 |  |  |       ----------------------------------------
 | 
      
         | 1071 |  |  |       -- Inspect_Unchecked_Union_Completion --
 | 
      
         | 1072 |  |  |       ----------------------------------------
 | 
      
         | 1073 |  |  |  
 | 
      
         | 1074 |  |  |       procedure Inspect_Unchecked_Union_Completion (Decls : List_Id) is
 | 
      
         | 1075 |  |  |          Decl : Node_Id;
 | 
      
         | 1076 |  |  |  
 | 
      
         | 1077 |  |  |       begin
 | 
      
         | 1078 |  |  |          Decl := First (Decls);
 | 
      
         | 1079 |  |  |          while Present (Decl) loop
 | 
      
         | 1080 |  |  |  
 | 
      
         | 1081 |  |  |             --  We are looking at an incomplete or private type declaration
 | 
      
         | 1082 |  |  |             --  with a known_discriminant_part whose full view is an
 | 
      
         | 1083 |  |  |             --  Unchecked_Union.
 | 
      
         | 1084 |  |  |  
 | 
      
         | 1085 |  |  |             if Nkind_In (Decl, N_Incomplete_Type_Declaration,
 | 
      
         | 1086 |  |  |                                N_Private_Type_Declaration)
 | 
      
         | 1087 |  |  |               and then Has_Discriminants (Defining_Identifier (Decl))
 | 
      
         | 1088 |  |  |               and then Present (Full_View (Defining_Identifier (Decl)))
 | 
      
         | 1089 |  |  |               and then
 | 
      
         | 1090 |  |  |                 Is_Unchecked_Union (Full_View (Defining_Identifier (Decl)))
 | 
      
         | 1091 |  |  |             then
 | 
      
         | 1092 |  |  |                Error_Msg_N
 | 
      
         | 1093 |  |  |                  ("completion of discriminated partial view "
 | 
      
         | 1094 |  |  |                   & "cannot be an Unchecked_Union",
 | 
      
         | 1095 |  |  |                  Full_View (Defining_Identifier (Decl)));
 | 
      
         | 1096 |  |  |             end if;
 | 
      
         | 1097 |  |  |  
 | 
      
         | 1098 |  |  |             Next (Decl);
 | 
      
         | 1099 |  |  |          end loop;
 | 
      
         | 1100 |  |  |       end Inspect_Unchecked_Union_Completion;
 | 
      
         | 1101 |  |  |  
 | 
      
         | 1102 |  |  |       -----------------------------------------
 | 
      
         | 1103 |  |  |       -- Install_Parent_Private_Declarations --
 | 
      
         | 1104 |  |  |       -----------------------------------------
 | 
      
         | 1105 |  |  |  
 | 
      
         | 1106 |  |  |       procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id) is
 | 
      
         | 1107 |  |  |          Inst_Par  : Entity_Id;
 | 
      
         | 1108 |  |  |          Gen_Par   : Entity_Id;
 | 
      
         | 1109 |  |  |          Inst_Node : Node_Id;
 | 
      
         | 1110 |  |  |  
 | 
      
         | 1111 |  |  |       begin
 | 
      
         | 1112 |  |  |          Inst_Par := Inst_Id;
 | 
      
         | 1113 |  |  |  
 | 
      
         | 1114 |  |  |          Gen_Par :=
 | 
      
         | 1115 |  |  |            Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
 | 
      
         | 1116 |  |  |          while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop
 | 
      
         | 1117 |  |  |             Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
 | 
      
         | 1118 |  |  |  
 | 
      
         | 1119 |  |  |             if Nkind_In (Inst_Node, N_Package_Instantiation,
 | 
      
         | 1120 |  |  |                                     N_Formal_Package_Declaration)
 | 
      
         | 1121 |  |  |               and then Nkind (Name (Inst_Node)) = N_Expanded_Name
 | 
      
         | 1122 |  |  |             then
 | 
      
         | 1123 |  |  |                Inst_Par := Entity (Prefix (Name (Inst_Node)));
 | 
      
         | 1124 |  |  |  
 | 
      
         | 1125 |  |  |                if Present (Renamed_Entity (Inst_Par)) then
 | 
      
         | 1126 |  |  |                   Inst_Par := Renamed_Entity (Inst_Par);
 | 
      
         | 1127 |  |  |                end if;
 | 
      
         | 1128 |  |  |  
 | 
      
         | 1129 |  |  |                Gen_Par :=
 | 
      
         | 1130 |  |  |                  Generic_Parent
 | 
      
         | 1131 |  |  |                    (Specification (Unit_Declaration_Node (Inst_Par)));
 | 
      
         | 1132 |  |  |  
 | 
      
         | 1133 |  |  |                --  Install the private declarations and private use clauses
 | 
      
         | 1134 |  |  |                --  of a parent instance of the child instance, unless the
 | 
      
         | 1135 |  |  |                --  parent instance private declarations have already been
 | 
      
         | 1136 |  |  |                --  installed earlier in Analyze_Package_Specification, which
 | 
      
         | 1137 |  |  |                --  happens when a generic child is instantiated, and the
 | 
      
         | 1138 |  |  |                --  instance is a child of the parent instance.
 | 
      
         | 1139 |  |  |  
 | 
      
         | 1140 |  |  |                --  Installing the use clauses of the parent instance twice
 | 
      
         | 1141 |  |  |                --  is both unnecessary and wrong, because it would cause the
 | 
      
         | 1142 |  |  |                --  clauses to be chained to themselves in the use clauses
 | 
      
         | 1143 |  |  |                --  list of the scope stack entry. That in turn would cause
 | 
      
         | 1144 |  |  |                --  an endless loop from End_Use_Clauses upon scope exit.
 | 
      
         | 1145 |  |  |  
 | 
      
         | 1146 |  |  |                --  The parent is now fully visible. It may be a hidden open
 | 
      
         | 1147 |  |  |                --  scope if we are currently compiling some child instance
 | 
      
         | 1148 |  |  |                --  declared within it, but while the current instance is being
 | 
      
         | 1149 |  |  |                --  compiled the parent is immediately visible. In particular
 | 
      
         | 1150 |  |  |                --  its entities must remain visible if a stack save/restore
 | 
      
         | 1151 |  |  |                --  takes place through a call to Rtsfind.
 | 
      
         | 1152 |  |  |  
 | 
      
         | 1153 |  |  |                if Present (Gen_Par) then
 | 
      
         | 1154 |  |  |                   if not In_Private_Part (Inst_Par) then
 | 
      
         | 1155 |  |  |                      Install_Private_Declarations (Inst_Par);
 | 
      
         | 1156 |  |  |                      Set_Use (Private_Declarations
 | 
      
         | 1157 |  |  |                                 (Specification
 | 
      
         | 1158 |  |  |                                    (Unit_Declaration_Node (Inst_Par))));
 | 
      
         | 1159 |  |  |                      Set_Is_Hidden_Open_Scope (Inst_Par, False);
 | 
      
         | 1160 |  |  |                   end if;
 | 
      
         | 1161 |  |  |  
 | 
      
         | 1162 |  |  |                --  If we've reached the end of the generic instance parents,
 | 
      
         | 1163 |  |  |                --  then finish off by looping through the nongeneric parents
 | 
      
         | 1164 |  |  |                --  and installing their private declarations.
 | 
      
         | 1165 |  |  |  
 | 
      
         | 1166 |  |  |                else
 | 
      
         | 1167 |  |  |                   while Present (Inst_Par)
 | 
      
         | 1168 |  |  |                     and then Inst_Par /= Standard_Standard
 | 
      
         | 1169 |  |  |                     and then (not In_Open_Scopes (Inst_Par)
 | 
      
         | 1170 |  |  |                                 or else not In_Private_Part (Inst_Par))
 | 
      
         | 1171 |  |  |                   loop
 | 
      
         | 1172 |  |  |                      Install_Private_Declarations (Inst_Par);
 | 
      
         | 1173 |  |  |                      Set_Use (Private_Declarations
 | 
      
         | 1174 |  |  |                                 (Specification
 | 
      
         | 1175 |  |  |                                    (Unit_Declaration_Node (Inst_Par))));
 | 
      
         | 1176 |  |  |                      Inst_Par := Scope (Inst_Par);
 | 
      
         | 1177 |  |  |                   end loop;
 | 
      
         | 1178 |  |  |  
 | 
      
         | 1179 |  |  |                   exit;
 | 
      
         | 1180 |  |  |                end if;
 | 
      
         | 1181 |  |  |  
 | 
      
         | 1182 |  |  |             else
 | 
      
         | 1183 |  |  |                exit;
 | 
      
         | 1184 |  |  |             end if;
 | 
      
         | 1185 |  |  |          end loop;
 | 
      
         | 1186 |  |  |       end Install_Parent_Private_Declarations;
 | 
      
         | 1187 |  |  |  
 | 
      
         | 1188 |  |  |    --  Start of processing for Analyze_Package_Specification
 | 
      
         | 1189 |  |  |  
 | 
      
         | 1190 |  |  |    begin
 | 
      
         | 1191 |  |  |       if Present (Vis_Decls) then
 | 
      
         | 1192 |  |  |          Analyze_Declarations (Vis_Decls);
 | 
      
         | 1193 |  |  |       end if;
 | 
      
         | 1194 |  |  |  
 | 
      
         | 1195 |  |  |       --  Verify that incomplete types have received full declarations and
 | 
      
         | 1196 |  |  |       --  also build invariant procedures for any types with invariants.
 | 
      
         | 1197 |  |  |  
 | 
      
         | 1198 |  |  |       E := First_Entity (Id);
 | 
      
         | 1199 |  |  |       while Present (E) loop
 | 
      
         | 1200 |  |  |  
 | 
      
         | 1201 |  |  |          --  Check on incomplete types
 | 
      
         | 1202 |  |  |  
 | 
      
         | 1203 |  |  |          --  AI05-0213: A formal incomplete type has no completion
 | 
      
         | 1204 |  |  |  
 | 
      
         | 1205 |  |  |          if Ekind (E) = E_Incomplete_Type
 | 
      
         | 1206 |  |  |            and then No (Full_View (E))
 | 
      
         | 1207 |  |  |            and then not Is_Generic_Type (E)
 | 
      
         | 1208 |  |  |          then
 | 
      
         | 1209 |  |  |             Error_Msg_N ("no declaration in visible part for incomplete}", E);
 | 
      
         | 1210 |  |  |          end if;
 | 
      
         | 1211 |  |  |  
 | 
      
         | 1212 |  |  |          --  Build invariant procedures
 | 
      
         | 1213 |  |  |  
 | 
      
         | 1214 |  |  |          if Is_Type (E) and then Has_Invariants (E) then
 | 
      
         | 1215 |  |  |             Build_Invariant_Procedure (E, N);
 | 
      
         | 1216 |  |  |          end if;
 | 
      
         | 1217 |  |  |  
 | 
      
         | 1218 |  |  |          Next_Entity (E);
 | 
      
         | 1219 |  |  |       end loop;
 | 
      
         | 1220 |  |  |  
 | 
      
         | 1221 |  |  |       if Is_Remote_Call_Interface (Id)
 | 
      
         | 1222 |  |  |          and then Nkind (Parent (Parent (N))) = N_Compilation_Unit
 | 
      
         | 1223 |  |  |       then
 | 
      
         | 1224 |  |  |          Validate_RCI_Declarations (Id);
 | 
      
         | 1225 |  |  |       end if;
 | 
      
         | 1226 |  |  |  
 | 
      
         | 1227 |  |  |       --  Save global references in the visible declarations, before installing
 | 
      
         | 1228 |  |  |       --  private declarations of parent unit if there is one, because the
 | 
      
         | 1229 |  |  |       --  privacy status of types defined in the parent will change. This is
 | 
      
         | 1230 |  |  |       --  only relevant for generic child units, but is done in all cases for
 | 
      
         | 1231 |  |  |       --  uniformity.
 | 
      
         | 1232 |  |  |  
 | 
      
         | 1233 |  |  |       if Ekind (Id) = E_Generic_Package
 | 
      
         | 1234 |  |  |         and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
 | 
      
         | 1235 |  |  |       then
 | 
      
         | 1236 |  |  |          declare
 | 
      
         | 1237 |  |  |             Orig_Spec : constant Node_Id := Specification (Orig_Decl);
 | 
      
         | 1238 |  |  |             Save_Priv : constant List_Id := Private_Declarations (Orig_Spec);
 | 
      
         | 1239 |  |  |          begin
 | 
      
         | 1240 |  |  |             Set_Private_Declarations (Orig_Spec, Empty_List);
 | 
      
         | 1241 |  |  |             Save_Global_References   (Orig_Decl);
 | 
      
         | 1242 |  |  |             Set_Private_Declarations (Orig_Spec, Save_Priv);
 | 
      
         | 1243 |  |  |          end;
 | 
      
         | 1244 |  |  |       end if;
 | 
      
         | 1245 |  |  |  
 | 
      
         | 1246 |  |  |       --  If package is a public child unit, then make the private declarations
 | 
      
         | 1247 |  |  |       --  of the parent visible.
 | 
      
         | 1248 |  |  |  
 | 
      
         | 1249 |  |  |       Public_Child := False;
 | 
      
         | 1250 |  |  |  
 | 
      
         | 1251 |  |  |       declare
 | 
      
         | 1252 |  |  |          Par       : Entity_Id;
 | 
      
         | 1253 |  |  |          Pack_Decl : Node_Id;
 | 
      
         | 1254 |  |  |          Par_Spec  : Node_Id;
 | 
      
         | 1255 |  |  |  
 | 
      
         | 1256 |  |  |       begin
 | 
      
         | 1257 |  |  |          Par := Id;
 | 
      
         | 1258 |  |  |          Par_Spec := Parent_Spec (Parent (N));
 | 
      
         | 1259 |  |  |  
 | 
      
         | 1260 |  |  |          --  If the package is formal package of an enclosing generic, it is
 | 
      
         | 1261 |  |  |          --  transformed into a local generic declaration, and compiled to make
 | 
      
         | 1262 |  |  |          --  its spec available. We need to retrieve the original generic to
 | 
      
         | 1263 |  |  |          --  determine whether it is a child unit, and install its parents.
 | 
      
         | 1264 |  |  |  
 | 
      
         | 1265 |  |  |          if No (Par_Spec)
 | 
      
         | 1266 |  |  |            and then
 | 
      
         | 1267 |  |  |              Nkind (Original_Node (Parent (N))) = N_Formal_Package_Declaration
 | 
      
         | 1268 |  |  |          then
 | 
      
         | 1269 |  |  |             Par := Entity (Name (Original_Node (Parent (N))));
 | 
      
         | 1270 |  |  |             Par_Spec := Parent_Spec (Unit_Declaration_Node (Par));
 | 
      
         | 1271 |  |  |          end if;
 | 
      
         | 1272 |  |  |  
 | 
      
         | 1273 |  |  |          if Present (Par_Spec) then
 | 
      
         | 1274 |  |  |             Generate_Parent_References;
 | 
      
         | 1275 |  |  |  
 | 
      
         | 1276 |  |  |             while Scope (Par) /= Standard_Standard
 | 
      
         | 1277 |  |  |               and then Is_Public_Child (Id, Par)
 | 
      
         | 1278 |  |  |               and then In_Open_Scopes (Par)
 | 
      
         | 1279 |  |  |             loop
 | 
      
         | 1280 |  |  |                Public_Child := True;
 | 
      
         | 1281 |  |  |                Par := Scope (Par);
 | 
      
         | 1282 |  |  |                Install_Private_Declarations (Par);
 | 
      
         | 1283 |  |  |                Install_Private_With_Clauses (Par);
 | 
      
         | 1284 |  |  |                Pack_Decl := Unit_Declaration_Node (Par);
 | 
      
         | 1285 |  |  |                Set_Use (Private_Declarations (Specification (Pack_Decl)));
 | 
      
         | 1286 |  |  |             end loop;
 | 
      
         | 1287 |  |  |          end if;
 | 
      
         | 1288 |  |  |       end;
 | 
      
         | 1289 |  |  |  
 | 
      
         | 1290 |  |  |       if Is_Compilation_Unit (Id) then
 | 
      
         | 1291 |  |  |          Install_Private_With_Clauses (Id);
 | 
      
         | 1292 |  |  |       else
 | 
      
         | 1293 |  |  |  
 | 
      
         | 1294 |  |  |          --  The current compilation unit may include private with_clauses,
 | 
      
         | 1295 |  |  |          --  which are visible in the private part of the current nested
 | 
      
         | 1296 |  |  |          --  package, and have to be installed now. This is not done for
 | 
      
         | 1297 |  |  |          --  nested instantiations, where the private with_clauses of the
 | 
      
         | 1298 |  |  |          --  enclosing unit have no effect once the instantiation info is
 | 
      
         | 1299 |  |  |          --  established and we start analyzing the package declaration.
 | 
      
         | 1300 |  |  |  
 | 
      
         | 1301 |  |  |          declare
 | 
      
         | 1302 |  |  |             Comp_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
 | 
      
         | 1303 |  |  |          begin
 | 
      
         | 1304 |  |  |             if Is_Package_Or_Generic_Package (Comp_Unit)
 | 
      
         | 1305 |  |  |               and then not In_Private_Part (Comp_Unit)
 | 
      
         | 1306 |  |  |               and then not In_Instance
 | 
      
         | 1307 |  |  |             then
 | 
      
         | 1308 |  |  |                Install_Private_With_Clauses (Comp_Unit);
 | 
      
         | 1309 |  |  |                Private_With_Clauses_Installed := True;
 | 
      
         | 1310 |  |  |             end if;
 | 
      
         | 1311 |  |  |          end;
 | 
      
         | 1312 |  |  |       end if;
 | 
      
         | 1313 |  |  |  
 | 
      
         | 1314 |  |  |       --  If this is a package associated with a generic instance or formal
 | 
      
         | 1315 |  |  |       --  package, then the private declarations of each of the generic's
 | 
      
         | 1316 |  |  |       --  parents must be installed at this point.
 | 
      
         | 1317 |  |  |  
 | 
      
         | 1318 |  |  |       if Is_Generic_Instance (Id) then
 | 
      
         | 1319 |  |  |          Install_Parent_Private_Declarations (Id);
 | 
      
         | 1320 |  |  |       end if;
 | 
      
         | 1321 |  |  |  
 | 
      
         | 1322 |  |  |       --  Analyze private part if present. The flag In_Private_Part is reset
 | 
      
         | 1323 |  |  |       --  in End_Package_Scope.
 | 
      
         | 1324 |  |  |  
 | 
      
         | 1325 |  |  |       L := Last_Entity (Id);
 | 
      
         | 1326 |  |  |  
 | 
      
         | 1327 |  |  |       if Present (Priv_Decls) then
 | 
      
         | 1328 |  |  |          Set_In_Private_Part (Id);
 | 
      
         | 1329 |  |  |  
 | 
      
         | 1330 |  |  |          --  Upon entering a public child's private part, it may be necessary
 | 
      
         | 1331 |  |  |          --  to declare subprograms that were derived in the package's visible
 | 
      
         | 1332 |  |  |          --  part but not yet made visible.
 | 
      
         | 1333 |  |  |  
 | 
      
         | 1334 |  |  |          if Public_Child then
 | 
      
         | 1335 |  |  |             Declare_Inherited_Private_Subprograms (Id);
 | 
      
         | 1336 |  |  |          end if;
 | 
      
         | 1337 |  |  |  
 | 
      
         | 1338 |  |  |          Analyze_Declarations (Priv_Decls);
 | 
      
         | 1339 |  |  |  
 | 
      
         | 1340 |  |  |          --  Check the private declarations for incomplete deferred constants
 | 
      
         | 1341 |  |  |  
 | 
      
         | 1342 |  |  |          Inspect_Deferred_Constant_Completion (Priv_Decls);
 | 
      
         | 1343 |  |  |  
 | 
      
         | 1344 |  |  |          --  The first private entity is the immediate follower of the last
 | 
      
         | 1345 |  |  |          --  visible entity, if there was one.
 | 
      
         | 1346 |  |  |  
 | 
      
         | 1347 |  |  |          if Present (L) then
 | 
      
         | 1348 |  |  |             Set_First_Private_Entity (Id, Next_Entity (L));
 | 
      
         | 1349 |  |  |          else
 | 
      
         | 1350 |  |  |             Set_First_Private_Entity (Id, First_Entity (Id));
 | 
      
         | 1351 |  |  |          end if;
 | 
      
         | 1352 |  |  |  
 | 
      
         | 1353 |  |  |       --  There may be inherited private subprograms that need to be declared,
 | 
      
         | 1354 |  |  |       --  even in the absence of an explicit private part.  If there are any
 | 
      
         | 1355 |  |  |       --  public declarations in the package and the package is a public child
 | 
      
         | 1356 |  |  |       --  unit, then an implicit private part is assumed.
 | 
      
         | 1357 |  |  |  
 | 
      
         | 1358 |  |  |       elsif Present (L) and then Public_Child then
 | 
      
         | 1359 |  |  |          Set_In_Private_Part (Id);
 | 
      
         | 1360 |  |  |          Declare_Inherited_Private_Subprograms (Id);
 | 
      
         | 1361 |  |  |          Set_First_Private_Entity (Id, Next_Entity (L));
 | 
      
         | 1362 |  |  |       end if;
 | 
      
         | 1363 |  |  |  
 | 
      
         | 1364 |  |  |       E := First_Entity (Id);
 | 
      
         | 1365 |  |  |       while Present (E) loop
 | 
      
         | 1366 |  |  |  
 | 
      
         | 1367 |  |  |          --  Check rule of 3.6(11), which in general requires waiting till all
 | 
      
         | 1368 |  |  |          --  full types have been seen.
 | 
      
         | 1369 |  |  |  
 | 
      
         | 1370 |  |  |          if Ekind (E) = E_Record_Type or else Ekind (E) = E_Array_Type then
 | 
      
         | 1371 |  |  |             Check_Aliased_Component_Types (E);
 | 
      
         | 1372 |  |  |          end if;
 | 
      
         | 1373 |  |  |  
 | 
      
         | 1374 |  |  |          --  Check preelaborable initialization for full type completing a
 | 
      
         | 1375 |  |  |          --  private type for which pragma Preelaborable_Initialization given.
 | 
      
         | 1376 |  |  |  
 | 
      
         | 1377 |  |  |          if Is_Type (E)
 | 
      
         | 1378 |  |  |            and then Must_Have_Preelab_Init (E)
 | 
      
         | 1379 |  |  |            and then not Has_Preelaborable_Initialization (E)
 | 
      
         | 1380 |  |  |          then
 | 
      
         | 1381 |  |  |             Error_Msg_N
 | 
      
         | 1382 |  |  |               ("full view of & does not have preelaborable initialization", E);
 | 
      
         | 1383 |  |  |          end if;
 | 
      
         | 1384 |  |  |  
 | 
      
         | 1385 |  |  |          --  An invariant may appear on a full view of a type
 | 
      
         | 1386 |  |  |  
 | 
      
         | 1387 |  |  |          if Is_Type (E)
 | 
      
         | 1388 |  |  |            and then Has_Private_Declaration (E)
 | 
      
         | 1389 |  |  |            and then Nkind (Parent (E)) = N_Full_Type_Declaration
 | 
      
         | 1390 |  |  |            and then Has_Aspects (Parent (E))
 | 
      
         | 1391 |  |  |          then
 | 
      
         | 1392 |  |  |             Build_Invariant_Procedure (E, N);
 | 
      
         | 1393 |  |  |          end if;
 | 
      
         | 1394 |  |  |  
 | 
      
         | 1395 |  |  |          Next_Entity (E);
 | 
      
         | 1396 |  |  |       end loop;
 | 
      
         | 1397 |  |  |  
 | 
      
         | 1398 |  |  |       --  Ada 2005 (AI-216): The completion of an incomplete or private type
 | 
      
         | 1399 |  |  |       --  declaration having a known_discriminant_part shall not be an
 | 
      
         | 1400 |  |  |       --  Unchecked_Union type.
 | 
      
         | 1401 |  |  |  
 | 
      
         | 1402 |  |  |       if Present (Vis_Decls) then
 | 
      
         | 1403 |  |  |          Inspect_Unchecked_Union_Completion (Vis_Decls);
 | 
      
         | 1404 |  |  |       end if;
 | 
      
         | 1405 |  |  |  
 | 
      
         | 1406 |  |  |       if Present (Priv_Decls) then
 | 
      
         | 1407 |  |  |          Inspect_Unchecked_Union_Completion (Priv_Decls);
 | 
      
         | 1408 |  |  |       end if;
 | 
      
         | 1409 |  |  |  
 | 
      
         | 1410 |  |  |       if Ekind (Id) = E_Generic_Package
 | 
      
         | 1411 |  |  |         and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
 | 
      
         | 1412 |  |  |         and then Present (Priv_Decls)
 | 
      
         | 1413 |  |  |       then
 | 
      
         | 1414 |  |  |          --  Save global references in private declarations, ignoring the
 | 
      
         | 1415 |  |  |          --  visible declarations that were processed earlier.
 | 
      
         | 1416 |  |  |  
 | 
      
         | 1417 |  |  |          declare
 | 
      
         | 1418 |  |  |             Orig_Spec : constant Node_Id := Specification (Orig_Decl);
 | 
      
         | 1419 |  |  |             Save_Vis  : constant List_Id := Visible_Declarations (Orig_Spec);
 | 
      
         | 1420 |  |  |             Save_Form : constant List_Id :=
 | 
      
         | 1421 |  |  |                           Generic_Formal_Declarations (Orig_Decl);
 | 
      
         | 1422 |  |  |  
 | 
      
         | 1423 |  |  |          begin
 | 
      
         | 1424 |  |  |             Set_Visible_Declarations        (Orig_Spec, Empty_List);
 | 
      
         | 1425 |  |  |             Set_Generic_Formal_Declarations (Orig_Decl, Empty_List);
 | 
      
         | 1426 |  |  |             Save_Global_References          (Orig_Decl);
 | 
      
         | 1427 |  |  |             Set_Generic_Formal_Declarations (Orig_Decl, Save_Form);
 | 
      
         | 1428 |  |  |             Set_Visible_Declarations        (Orig_Spec, Save_Vis);
 | 
      
         | 1429 |  |  |          end;
 | 
      
         | 1430 |  |  |       end if;
 | 
      
         | 1431 |  |  |  
 | 
      
         | 1432 |  |  |       Process_End_Label (N, 'e', Id);
 | 
      
         | 1433 |  |  |  
 | 
      
         | 1434 |  |  |       --  Remove private_with_clauses of enclosing compilation unit, if they
 | 
      
         | 1435 |  |  |       --  were installed.
 | 
      
         | 1436 |  |  |  
 | 
      
         | 1437 |  |  |       if Private_With_Clauses_Installed then
 | 
      
         | 1438 |  |  |          Remove_Private_With_Clauses (Cunit (Current_Sem_Unit));
 | 
      
         | 1439 |  |  |       end if;
 | 
      
         | 1440 |  |  |  
 | 
      
         | 1441 |  |  |       --  For the case of a library level package, we must go through all the
 | 
      
         | 1442 |  |  |       --  entities clearing the indications that the value may be constant and
 | 
      
         | 1443 |  |  |       --  not modified. Why? Because any client of this package may modify
 | 
      
         | 1444 |  |  |       --  these values freely from anywhere. This also applies to any nested
 | 
      
         | 1445 |  |  |       --  packages or generic packages.
 | 
      
         | 1446 |  |  |  
 | 
      
         | 1447 |  |  |       --  For now we unconditionally clear constants for packages that are
 | 
      
         | 1448 |  |  |       --  instances of generic packages. The reason is that we do not have the
 | 
      
         | 1449 |  |  |       --  body yet, and we otherwise think things are unreferenced when they
 | 
      
         | 1450 |  |  |       --  are not. This should be fixed sometime (the effect is not terrible,
 | 
      
         | 1451 |  |  |       --  we just lose some warnings, and also some cases of value propagation)
 | 
      
         | 1452 |  |  |       --  ???
 | 
      
         | 1453 |  |  |  
 | 
      
         | 1454 |  |  |       if Is_Library_Level_Entity (Id)
 | 
      
         | 1455 |  |  |         or else Is_Generic_Instance (Id)
 | 
      
         | 1456 |  |  |       then
 | 
      
         | 1457 |  |  |          Clear_Constants (Id, First_Entity (Id));
 | 
      
         | 1458 |  |  |          Clear_Constants (Id, First_Private_Entity (Id));
 | 
      
         | 1459 |  |  |       end if;
 | 
      
         | 1460 |  |  |  
 | 
      
         | 1461 |  |  |       Check_One_Tagged_Type_Or_Extension_At_Most;
 | 
      
         | 1462 |  |  |    end Analyze_Package_Specification;
 | 
      
         | 1463 |  |  |  
 | 
      
         | 1464 |  |  |    --------------------------------------
 | 
      
         | 1465 |  |  |    -- Analyze_Private_Type_Declaration --
 | 
      
         | 1466 |  |  |    --------------------------------------
 | 
      
         | 1467 |  |  |  
 | 
      
         | 1468 |  |  |    procedure Analyze_Private_Type_Declaration (N : Node_Id) is
 | 
      
         | 1469 |  |  |       PF : constant Boolean   := Is_Pure (Enclosing_Lib_Unit_Entity);
 | 
      
         | 1470 |  |  |       Id : constant Entity_Id := Defining_Identifier (N);
 | 
      
         | 1471 |  |  |  
 | 
      
         | 1472 |  |  |    begin
 | 
      
         | 1473 |  |  |       Generate_Definition (Id);
 | 
      
         | 1474 |  |  |       Set_Is_Pure         (Id, PF);
 | 
      
         | 1475 |  |  |       Init_Size_Align     (Id);
 | 
      
         | 1476 |  |  |  
 | 
      
         | 1477 |  |  |       if not Is_Package_Or_Generic_Package (Current_Scope)
 | 
      
         | 1478 |  |  |         or else In_Private_Part (Current_Scope)
 | 
      
         | 1479 |  |  |       then
 | 
      
         | 1480 |  |  |          Error_Msg_N ("invalid context for private declaration", N);
 | 
      
         | 1481 |  |  |       end if;
 | 
      
         | 1482 |  |  |  
 | 
      
         | 1483 |  |  |       New_Private_Type (N, Id, N);
 | 
      
         | 1484 |  |  |       Set_Depends_On_Private (Id);
 | 
      
         | 1485 |  |  |  
 | 
      
         | 1486 |  |  |       if Has_Aspects (N) then
 | 
      
         | 1487 |  |  |          Analyze_Aspect_Specifications (N, Id);
 | 
      
         | 1488 |  |  |       end if;
 | 
      
         | 1489 |  |  |    end Analyze_Private_Type_Declaration;
 | 
      
         | 1490 |  |  |  
 | 
      
         | 1491 |  |  |    ----------------------------------
 | 
      
         | 1492 |  |  |    -- Check_Anonymous_Access_Types --
 | 
      
         | 1493 |  |  |    ----------------------------------
 | 
      
         | 1494 |  |  |  
 | 
      
         | 1495 |  |  |    procedure Check_Anonymous_Access_Types
 | 
      
         | 1496 |  |  |      (Spec_Id : Entity_Id;
 | 
      
         | 1497 |  |  |       P_Body  : Node_Id)
 | 
      
         | 1498 |  |  |    is
 | 
      
         | 1499 |  |  |       E  : Entity_Id;
 | 
      
         | 1500 |  |  |       IR : Node_Id;
 | 
      
         | 1501 |  |  |  
 | 
      
         | 1502 |  |  |    begin
 | 
      
         | 1503 |  |  |       --  Itype references are only needed by gigi, to force elaboration of
 | 
      
         | 1504 |  |  |       --  itypes. In the absence of code generation, they are not needed.
 | 
      
         | 1505 |  |  |  
 | 
      
         | 1506 |  |  |       if not Expander_Active then
 | 
      
         | 1507 |  |  |          return;
 | 
      
         | 1508 |  |  |       end if;
 | 
      
         | 1509 |  |  |  
 | 
      
         | 1510 |  |  |       E := First_Entity (Spec_Id);
 | 
      
         | 1511 |  |  |       while Present (E) loop
 | 
      
         | 1512 |  |  |          if Ekind (E) = E_Anonymous_Access_Type
 | 
      
         | 1513 |  |  |            and then From_With_Type (E)
 | 
      
         | 1514 |  |  |          then
 | 
      
         | 1515 |  |  |             IR := Make_Itype_Reference (Sloc (P_Body));
 | 
      
         | 1516 |  |  |             Set_Itype (IR, E);
 | 
      
         | 1517 |  |  |  
 | 
      
         | 1518 |  |  |             if No (Declarations (P_Body)) then
 | 
      
         | 1519 |  |  |                Set_Declarations (P_Body, New_List (IR));
 | 
      
         | 1520 |  |  |             else
 | 
      
         | 1521 |  |  |                Prepend (IR, Declarations (P_Body));
 | 
      
         | 1522 |  |  |             end if;
 | 
      
         | 1523 |  |  |          end if;
 | 
      
         | 1524 |  |  |  
 | 
      
         | 1525 |  |  |          Next_Entity (E);
 | 
      
         | 1526 |  |  |       end loop;
 | 
      
         | 1527 |  |  |    end Check_Anonymous_Access_Types;
 | 
      
         | 1528 |  |  |  
 | 
      
         | 1529 |  |  |    -------------------------------------------
 | 
      
         | 1530 |  |  |    -- Declare_Inherited_Private_Subprograms --
 | 
      
         | 1531 |  |  |    -------------------------------------------
 | 
      
         | 1532 |  |  |  
 | 
      
         | 1533 |  |  |    procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
 | 
      
         | 1534 |  |  |  
 | 
      
         | 1535 |  |  |       function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
 | 
      
         | 1536 |  |  |       --  Check whether an inherited subprogram S is an operation of an
 | 
      
         | 1537 |  |  |       --  untagged derived type T.
 | 
      
         | 1538 |  |  |  
 | 
      
         | 1539 |  |  |       ---------------------
 | 
      
         | 1540 |  |  |       -- Is_Primitive_Of --
 | 
      
         | 1541 |  |  |       ---------------------
 | 
      
         | 1542 |  |  |  
 | 
      
         | 1543 |  |  |       function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean is
 | 
      
         | 1544 |  |  |          Formal : Entity_Id;
 | 
      
         | 1545 |  |  |  
 | 
      
         | 1546 |  |  |       begin
 | 
      
         | 1547 |  |  |          --  If the full view is a scalar type, the type is the anonymous base
 | 
      
         | 1548 |  |  |          --  type, but the operation mentions the first subtype, so check the
 | 
      
         | 1549 |  |  |          --  signature against the base type.
 | 
      
         | 1550 |  |  |  
 | 
      
         | 1551 |  |  |          if Base_Type (Etype (S)) = Base_Type (T) then
 | 
      
         | 1552 |  |  |             return True;
 | 
      
         | 1553 |  |  |  
 | 
      
         | 1554 |  |  |          else
 | 
      
         | 1555 |  |  |             Formal := First_Formal (S);
 | 
      
         | 1556 |  |  |             while Present (Formal) loop
 | 
      
         | 1557 |  |  |                if Base_Type (Etype (Formal)) = Base_Type (T) then
 | 
      
         | 1558 |  |  |                   return True;
 | 
      
         | 1559 |  |  |                end if;
 | 
      
         | 1560 |  |  |  
 | 
      
         | 1561 |  |  |                Next_Formal (Formal);
 | 
      
         | 1562 |  |  |             end loop;
 | 
      
         | 1563 |  |  |  
 | 
      
         | 1564 |  |  |             return False;
 | 
      
         | 1565 |  |  |          end if;
 | 
      
         | 1566 |  |  |       end Is_Primitive_Of;
 | 
      
         | 1567 |  |  |  
 | 
      
         | 1568 |  |  |       --  Local variables
 | 
      
         | 1569 |  |  |  
 | 
      
         | 1570 |  |  |       E           : Entity_Id;
 | 
      
         | 1571 |  |  |       Op_List     : Elist_Id;
 | 
      
         | 1572 |  |  |       Op_Elmt     : Elmt_Id;
 | 
      
         | 1573 |  |  |       Op_Elmt_2   : Elmt_Id;
 | 
      
         | 1574 |  |  |       Prim_Op     : Entity_Id;
 | 
      
         | 1575 |  |  |       New_Op      : Entity_Id := Empty;
 | 
      
         | 1576 |  |  |       Parent_Subp : Entity_Id;
 | 
      
         | 1577 |  |  |       Tag         : Entity_Id;
 | 
      
         | 1578 |  |  |  
 | 
      
         | 1579 |  |  |    --  Start of processing for Declare_Inherited_Private_Subprograms
 | 
      
         | 1580 |  |  |  
 | 
      
         | 1581 |  |  |    begin
 | 
      
         | 1582 |  |  |       E := First_Entity (Id);
 | 
      
         | 1583 |  |  |       while Present (E) loop
 | 
      
         | 1584 |  |  |  
 | 
      
         | 1585 |  |  |          --  If the entity is a nonprivate type extension whose parent type
 | 
      
         | 1586 |  |  |          --  is declared in an open scope, then the type may have inherited
 | 
      
         | 1587 |  |  |          --  operations that now need to be made visible. Ditto if the entity
 | 
      
         | 1588 |  |  |          --  is a formal derived type in a child unit.
 | 
      
         | 1589 |  |  |  
 | 
      
         | 1590 |  |  |          if ((Is_Derived_Type (E) and then not Is_Private_Type (E))
 | 
      
         | 1591 |  |  |                or else
 | 
      
         | 1592 |  |  |                  (Nkind (Parent (E)) = N_Private_Extension_Declaration
 | 
      
         | 1593 |  |  |                    and then Is_Generic_Type (E)))
 | 
      
         | 1594 |  |  |            and then In_Open_Scopes (Scope (Etype (E)))
 | 
      
         | 1595 |  |  |            and then Is_Base_Type (E)
 | 
      
         | 1596 |  |  |          then
 | 
      
         | 1597 |  |  |             if Is_Tagged_Type (E) then
 | 
      
         | 1598 |  |  |                Op_List := Primitive_Operations (E);
 | 
      
         | 1599 |  |  |                New_Op  := Empty;
 | 
      
         | 1600 |  |  |                Tag     := First_Tag_Component (E);
 | 
      
         | 1601 |  |  |  
 | 
      
         | 1602 |  |  |                Op_Elmt := First_Elmt (Op_List);
 | 
      
         | 1603 |  |  |                while Present (Op_Elmt) loop
 | 
      
         | 1604 |  |  |                   Prim_Op := Node (Op_Elmt);
 | 
      
         | 1605 |  |  |  
 | 
      
         | 1606 |  |  |                   --  Search primitives that are implicit operations with an
 | 
      
         | 1607 |  |  |                   --  internal name whose parent operation has a normal name.
 | 
      
         | 1608 |  |  |  
 | 
      
         | 1609 |  |  |                   if Present (Alias (Prim_Op))
 | 
      
         | 1610 |  |  |                     and then Find_Dispatching_Type (Alias (Prim_Op)) /= E
 | 
      
         | 1611 |  |  |                     and then not Comes_From_Source (Prim_Op)
 | 
      
         | 1612 |  |  |                     and then Is_Internal_Name (Chars (Prim_Op))
 | 
      
         | 1613 |  |  |                     and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
 | 
      
         | 1614 |  |  |                   then
 | 
      
         | 1615 |  |  |                      Parent_Subp := Alias (Prim_Op);
 | 
      
         | 1616 |  |  |  
 | 
      
         | 1617 |  |  |                      --  Case 1: Check if the type has also an explicit
 | 
      
         | 1618 |  |  |                      --  overriding for this primitive.
 | 
      
         | 1619 |  |  |  
 | 
      
         | 1620 |  |  |                      Op_Elmt_2 := Next_Elmt (Op_Elmt);
 | 
      
         | 1621 |  |  |                      while Present (Op_Elmt_2) loop
 | 
      
         | 1622 |  |  |  
 | 
      
         | 1623 |  |  |                         --  Skip entities with attribute Interface_Alias since
 | 
      
         | 1624 |  |  |                         --  they are not overriding primitives (these entities
 | 
      
         | 1625 |  |  |                         --  link an interface primitive with their covering
 | 
      
         | 1626 |  |  |                         --  primitive)
 | 
      
         | 1627 |  |  |  
 | 
      
         | 1628 |  |  |                         if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
 | 
      
         | 1629 |  |  |                           and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
 | 
      
         | 1630 |  |  |                           and then No (Interface_Alias (Node (Op_Elmt_2)))
 | 
      
         | 1631 |  |  |                         then
 | 
      
         | 1632 |  |  |                            --  The private inherited operation has been
 | 
      
         | 1633 |  |  |                            --  overridden by an explicit subprogram: replace
 | 
      
         | 1634 |  |  |                            --  the former by the latter.
 | 
      
         | 1635 |  |  |  
 | 
      
         | 1636 |  |  |                            New_Op := Node (Op_Elmt_2);
 | 
      
         | 1637 |  |  |                            Replace_Elmt (Op_Elmt, New_Op);
 | 
      
         | 1638 |  |  |                            Remove_Elmt  (Op_List, Op_Elmt_2);
 | 
      
         | 1639 |  |  |                            Set_Overridden_Operation (New_Op, Parent_Subp);
 | 
      
         | 1640 |  |  |  
 | 
      
         | 1641 |  |  |                            --  We don't need to inherit its dispatching slot.
 | 
      
         | 1642 |  |  |                            --  Set_All_DT_Position has previously ensured that
 | 
      
         | 1643 |  |  |                            --  the same slot was assigned to the two primitives
 | 
      
         | 1644 |  |  |  
 | 
      
         | 1645 |  |  |                            if Present (Tag)
 | 
      
         | 1646 |  |  |                              and then Present (DTC_Entity (New_Op))
 | 
      
         | 1647 |  |  |                              and then Present (DTC_Entity (Prim_Op))
 | 
      
         | 1648 |  |  |                            then
 | 
      
         | 1649 |  |  |                               pragma Assert (DT_Position (New_Op)
 | 
      
         | 1650 |  |  |                                               = DT_Position (Prim_Op));
 | 
      
         | 1651 |  |  |                               null;
 | 
      
         | 1652 |  |  |                            end if;
 | 
      
         | 1653 |  |  |  
 | 
      
         | 1654 |  |  |                            goto Next_Primitive;
 | 
      
         | 1655 |  |  |                         end if;
 | 
      
         | 1656 |  |  |  
 | 
      
         | 1657 |  |  |                         Next_Elmt (Op_Elmt_2);
 | 
      
         | 1658 |  |  |                      end loop;
 | 
      
         | 1659 |  |  |  
 | 
      
         | 1660 |  |  |                      --  Case 2: We have not found any explicit overriding and
 | 
      
         | 1661 |  |  |                      --  hence we need to declare the operation (i.e., make it
 | 
      
         | 1662 |  |  |                      --  visible).
 | 
      
         | 1663 |  |  |  
 | 
      
         | 1664 |  |  |                      Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E));
 | 
      
         | 1665 |  |  |  
 | 
      
         | 1666 |  |  |                      --  Inherit the dispatching slot if E is already frozen
 | 
      
         | 1667 |  |  |  
 | 
      
         | 1668 |  |  |                      if Is_Frozen (E)
 | 
      
         | 1669 |  |  |                        and then Present (DTC_Entity (Alias (Prim_Op)))
 | 
      
         | 1670 |  |  |                      then
 | 
      
         | 1671 |  |  |                         Set_DTC_Entity_Value (E, New_Op);
 | 
      
         | 1672 |  |  |                         Set_DT_Position (New_Op,
 | 
      
         | 1673 |  |  |                           DT_Position (Alias (Prim_Op)));
 | 
      
         | 1674 |  |  |                      end if;
 | 
      
         | 1675 |  |  |  
 | 
      
         | 1676 |  |  |                      pragma Assert
 | 
      
         | 1677 |  |  |                        (Is_Dispatching_Operation (New_Op)
 | 
      
         | 1678 |  |  |                          and then Node (Last_Elmt (Op_List)) = New_Op);
 | 
      
         | 1679 |  |  |  
 | 
      
         | 1680 |  |  |                      --  Substitute the new operation for the old one in the
 | 
      
         | 1681 |  |  |                      --  type's primitive operations list. Since the new
 | 
      
         | 1682 |  |  |                      --  operation was also just added to the end of list,
 | 
      
         | 1683 |  |  |                      --  the last element must be removed.
 | 
      
         | 1684 |  |  |  
 | 
      
         | 1685 |  |  |                      --  (Question: is there a simpler way of declaring the
 | 
      
         | 1686 |  |  |                      --  operation, say by just replacing the name of the
 | 
      
         | 1687 |  |  |                      --  earlier operation, reentering it in the in the symbol
 | 
      
         | 1688 |  |  |                      --  table (how?), and marking it as private???)
 | 
      
         | 1689 |  |  |  
 | 
      
         | 1690 |  |  |                      Replace_Elmt (Op_Elmt, New_Op);
 | 
      
         | 1691 |  |  |                      Remove_Last_Elmt (Op_List);
 | 
      
         | 1692 |  |  |                   end if;
 | 
      
         | 1693 |  |  |  
 | 
      
         | 1694 |  |  |                   <<Next_Primitive>>
 | 
      
         | 1695 |  |  |                   Next_Elmt (Op_Elmt);
 | 
      
         | 1696 |  |  |                end loop;
 | 
      
         | 1697 |  |  |  
 | 
      
         | 1698 |  |  |                --  Generate listing showing the contents of the dispatch table
 | 
      
         | 1699 |  |  |  
 | 
      
         | 1700 |  |  |                if Debug_Flag_ZZ then
 | 
      
         | 1701 |  |  |                   Write_DT (E);
 | 
      
         | 1702 |  |  |                end if;
 | 
      
         | 1703 |  |  |  
 | 
      
         | 1704 |  |  |             else
 | 
      
         | 1705 |  |  |                --  Non-tagged type, scan forward to locate inherited hidden
 | 
      
         | 1706 |  |  |                --  operations.
 | 
      
         | 1707 |  |  |  
 | 
      
         | 1708 |  |  |                Prim_Op := Next_Entity (E);
 | 
      
         | 1709 |  |  |                while Present (Prim_Op) loop
 | 
      
         | 1710 |  |  |                   if Is_Subprogram (Prim_Op)
 | 
      
         | 1711 |  |  |                     and then Present (Alias (Prim_Op))
 | 
      
         | 1712 |  |  |                     and then not Comes_From_Source (Prim_Op)
 | 
      
         | 1713 |  |  |                     and then Is_Internal_Name (Chars (Prim_Op))
 | 
      
         | 1714 |  |  |                     and then not Is_Internal_Name (Chars (Alias (Prim_Op)))
 | 
      
         | 1715 |  |  |                     and then Is_Primitive_Of (E, Prim_Op)
 | 
      
         | 1716 |  |  |                   then
 | 
      
         | 1717 |  |  |                      Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E));
 | 
      
         | 1718 |  |  |                   end if;
 | 
      
         | 1719 |  |  |  
 | 
      
         | 1720 |  |  |                   Next_Entity (Prim_Op);
 | 
      
         | 1721 |  |  |                end loop;
 | 
      
         | 1722 |  |  |             end if;
 | 
      
         | 1723 |  |  |          end if;
 | 
      
         | 1724 |  |  |  
 | 
      
         | 1725 |  |  |          Next_Entity (E);
 | 
      
         | 1726 |  |  |       end loop;
 | 
      
         | 1727 |  |  |    end Declare_Inherited_Private_Subprograms;
 | 
      
         | 1728 |  |  |  
 | 
      
         | 1729 |  |  |    -----------------------
 | 
      
         | 1730 |  |  |    -- End_Package_Scope --
 | 
      
         | 1731 |  |  |    -----------------------
 | 
      
         | 1732 |  |  |  
 | 
      
         | 1733 |  |  |    procedure End_Package_Scope (P : Entity_Id) is
 | 
      
         | 1734 |  |  |    begin
 | 
      
         | 1735 |  |  |       Uninstall_Declarations (P);
 | 
      
         | 1736 |  |  |       Pop_Scope;
 | 
      
         | 1737 |  |  |    end End_Package_Scope;
 | 
      
         | 1738 |  |  |  
 | 
      
         | 1739 |  |  |    ---------------------------
 | 
      
         | 1740 |  |  |    -- Exchange_Declarations --
 | 
      
         | 1741 |  |  |    ---------------------------
 | 
      
         | 1742 |  |  |  
 | 
      
         | 1743 |  |  |    procedure Exchange_Declarations (Id : Entity_Id) is
 | 
      
         | 1744 |  |  |       Full_Id : constant Entity_Id := Full_View (Id);
 | 
      
         | 1745 |  |  |       H1      : constant Entity_Id := Homonym (Id);
 | 
      
         | 1746 |  |  |       Next1   : constant Entity_Id := Next_Entity (Id);
 | 
      
         | 1747 |  |  |       H2      : Entity_Id;
 | 
      
         | 1748 |  |  |       Next2   : Entity_Id;
 | 
      
         | 1749 |  |  |  
 | 
      
         | 1750 |  |  |    begin
 | 
      
         | 1751 |  |  |       --  If missing full declaration for type, nothing to exchange
 | 
      
         | 1752 |  |  |  
 | 
      
         | 1753 |  |  |       if No (Full_Id) then
 | 
      
         | 1754 |  |  |          return;
 | 
      
         | 1755 |  |  |       end if;
 | 
      
         | 1756 |  |  |  
 | 
      
         | 1757 |  |  |       --  Otherwise complete the exchange, and preserve semantic links
 | 
      
         | 1758 |  |  |  
 | 
      
         | 1759 |  |  |       Next2 := Next_Entity (Full_Id);
 | 
      
         | 1760 |  |  |       H2    := Homonym (Full_Id);
 | 
      
         | 1761 |  |  |  
 | 
      
         | 1762 |  |  |       --  Reset full declaration pointer to reflect the switched entities and
 | 
      
         | 1763 |  |  |       --  readjust the next entity chains.
 | 
      
         | 1764 |  |  |  
 | 
      
         | 1765 |  |  |       Exchange_Entities (Id, Full_Id);
 | 
      
         | 1766 |  |  |  
 | 
      
         | 1767 |  |  |       Set_Next_Entity (Id, Next1);
 | 
      
         | 1768 |  |  |       Set_Homonym     (Id, H1);
 | 
      
         | 1769 |  |  |  
 | 
      
         | 1770 |  |  |       Set_Full_View   (Full_Id, Id);
 | 
      
         | 1771 |  |  |       Set_Next_Entity (Full_Id, Next2);
 | 
      
         | 1772 |  |  |       Set_Homonym     (Full_Id, H2);
 | 
      
         | 1773 |  |  |    end Exchange_Declarations;
 | 
      
         | 1774 |  |  |  
 | 
      
         | 1775 |  |  |    ----------------------------
 | 
      
         | 1776 |  |  |    -- Install_Package_Entity --
 | 
      
         | 1777 |  |  |    ----------------------------
 | 
      
         | 1778 |  |  |  
 | 
      
         | 1779 |  |  |    procedure Install_Package_Entity (Id : Entity_Id) is
 | 
      
         | 1780 |  |  |    begin
 | 
      
         | 1781 |  |  |       if not Is_Internal (Id) then
 | 
      
         | 1782 |  |  |          if Debug_Flag_E then
 | 
      
         | 1783 |  |  |             Write_Str ("Install: ");
 | 
      
         | 1784 |  |  |             Write_Name (Chars (Id));
 | 
      
         | 1785 |  |  |             Write_Eol;
 | 
      
         | 1786 |  |  |          end if;
 | 
      
         | 1787 |  |  |  
 | 
      
         | 1788 |  |  |          if not Is_Child_Unit (Id) then
 | 
      
         | 1789 |  |  |             Set_Is_Immediately_Visible (Id);
 | 
      
         | 1790 |  |  |          end if;
 | 
      
         | 1791 |  |  |  
 | 
      
         | 1792 |  |  |       end if;
 | 
      
         | 1793 |  |  |    end Install_Package_Entity;
 | 
      
         | 1794 |  |  |  
 | 
      
         | 1795 |  |  |    ----------------------------------
 | 
      
         | 1796 |  |  |    -- Install_Private_Declarations --
 | 
      
         | 1797 |  |  |    ----------------------------------
 | 
      
         | 1798 |  |  |  
 | 
      
         | 1799 |  |  |    procedure Install_Private_Declarations (P : Entity_Id) is
 | 
      
         | 1800 |  |  |       Id        : Entity_Id;
 | 
      
         | 1801 |  |  |       Priv_Elmt : Elmt_Id;
 | 
      
         | 1802 |  |  |       Priv      : Entity_Id;
 | 
      
         | 1803 |  |  |       Full      : Entity_Id;
 | 
      
         | 1804 |  |  |  
 | 
      
         | 1805 |  |  |    begin
 | 
      
         | 1806 |  |  |       --  First exchange declarations for private types, so that the full
 | 
      
         | 1807 |  |  |       --  declaration is visible. For each private type, we check its
 | 
      
         | 1808 |  |  |       --  Private_Dependents list and also exchange any subtypes of or derived
 | 
      
         | 1809 |  |  |       --  types from it. Finally, if this is a Taft amendment type, the
 | 
      
         | 1810 |  |  |       --  incomplete declaration is irrelevant, and we want to link the
 | 
      
         | 1811 |  |  |       --  eventual full declaration with the original private one so we also
 | 
      
         | 1812 |  |  |       --  skip the exchange.
 | 
      
         | 1813 |  |  |  
 | 
      
         | 1814 |  |  |       Id := First_Entity (P);
 | 
      
         | 1815 |  |  |       while Present (Id) and then Id /= First_Private_Entity (P) loop
 | 
      
         | 1816 |  |  |          if Is_Private_Base_Type (Id)
 | 
      
         | 1817 |  |  |            and then Comes_From_Source (Full_View (Id))
 | 
      
         | 1818 |  |  |            and then Present (Full_View (Id))
 | 
      
         | 1819 |  |  |            and then Scope (Full_View (Id)) = Scope (Id)
 | 
      
         | 1820 |  |  |            and then Ekind (Full_View (Id)) /= E_Incomplete_Type
 | 
      
         | 1821 |  |  |          then
 | 
      
         | 1822 |  |  |             --  If there is a use-type clause on the private type, set the
 | 
      
         | 1823 |  |  |             --  full view accordingly.
 | 
      
         | 1824 |  |  |  
 | 
      
         | 1825 |  |  |             Set_In_Use (Full_View (Id), In_Use (Id));
 | 
      
         | 1826 |  |  |             Full := Full_View (Id);
 | 
      
         | 1827 |  |  |  
 | 
      
         | 1828 |  |  |             if Is_Private_Base_Type (Full)
 | 
      
         | 1829 |  |  |               and then Has_Private_Declaration (Full)
 | 
      
         | 1830 |  |  |               and then Nkind (Parent (Full)) = N_Full_Type_Declaration
 | 
      
         | 1831 |  |  |               and then In_Open_Scopes (Scope (Etype (Full)))
 | 
      
         | 1832 |  |  |               and then In_Package_Body (Current_Scope)
 | 
      
         | 1833 |  |  |               and then not Is_Private_Type (Etype (Full))
 | 
      
         | 1834 |  |  |             then
 | 
      
         | 1835 |  |  |                --  This is the completion of a private type by a derivation
 | 
      
         | 1836 |  |  |                --  from another private type which is not private anymore. This
 | 
      
         | 1837 |  |  |                --  can only happen in a package nested within a child package,
 | 
      
         | 1838 |  |  |                --  when the parent type is defined in the parent unit. At this
 | 
      
         | 1839 |  |  |                --  point the current type is not private either, and we have to
 | 
      
         | 1840 |  |  |                --  install the underlying full view, which is now visible. Save
 | 
      
         | 1841 |  |  |                --  the current full view as well, so that all views can be
 | 
      
         | 1842 |  |  |                --  restored on exit. It may seem that after compiling the child
 | 
      
         | 1843 |  |  |                --  body there are not environments to restore, but the back-end
 | 
      
         | 1844 |  |  |                --  expects those links to be valid, and freeze nodes depend on
 | 
      
         | 1845 |  |  |                --  them.
 | 
      
         | 1846 |  |  |  
 | 
      
         | 1847 |  |  |                if No (Full_View (Full))
 | 
      
         | 1848 |  |  |                  and then Present (Underlying_Full_View (Full))
 | 
      
         | 1849 |  |  |                then
 | 
      
         | 1850 |  |  |                   Set_Full_View (Id, Underlying_Full_View (Full));
 | 
      
         | 1851 |  |  |                   Set_Underlying_Full_View (Id, Full);
 | 
      
         | 1852 |  |  |  
 | 
      
         | 1853 |  |  |                   Set_Underlying_Full_View (Full, Empty);
 | 
      
         | 1854 |  |  |                   Set_Is_Frozen (Full_View (Id));
 | 
      
         | 1855 |  |  |                end if;
 | 
      
         | 1856 |  |  |             end if;
 | 
      
         | 1857 |  |  |  
 | 
      
         | 1858 |  |  |             Priv_Elmt := First_Elmt (Private_Dependents (Id));
 | 
      
         | 1859 |  |  |  
 | 
      
         | 1860 |  |  |             Exchange_Declarations (Id);
 | 
      
         | 1861 |  |  |             Set_Is_Immediately_Visible (Id);
 | 
      
         | 1862 |  |  |  
 | 
      
         | 1863 |  |  |             while Present (Priv_Elmt) loop
 | 
      
         | 1864 |  |  |                Priv := Node (Priv_Elmt);
 | 
      
         | 1865 |  |  |  
 | 
      
         | 1866 |  |  |                --  Before the exchange, verify that the presence of the
 | 
      
         | 1867 |  |  |                --  Full_View field. It will be empty if the entity has already
 | 
      
         | 1868 |  |  |                --  been installed due to a previous call.
 | 
      
         | 1869 |  |  |  
 | 
      
         | 1870 |  |  |                if Present (Full_View (Priv))
 | 
      
         | 1871 |  |  |                  and then Is_Visible_Dependent (Priv)
 | 
      
         | 1872 |  |  |                then
 | 
      
         | 1873 |  |  |  
 | 
      
         | 1874 |  |  |                   --  For each subtype that is swapped, we also swap the
 | 
      
         | 1875 |  |  |                   --  reference to it in Private_Dependents, to allow access
 | 
      
         | 1876 |  |  |                   --  to it when we swap them out in End_Package_Scope.
 | 
      
         | 1877 |  |  |  
 | 
      
         | 1878 |  |  |                   Replace_Elmt (Priv_Elmt, Full_View (Priv));
 | 
      
         | 1879 |  |  |                   Exchange_Declarations (Priv);
 | 
      
         | 1880 |  |  |                   Set_Is_Immediately_Visible
 | 
      
         | 1881 |  |  |                     (Priv, In_Open_Scopes (Scope (Priv)));
 | 
      
         | 1882 |  |  |                   Set_Is_Potentially_Use_Visible
 | 
      
         | 1883 |  |  |                     (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt)));
 | 
      
         | 1884 |  |  |                end if;
 | 
      
         | 1885 |  |  |  
 | 
      
         | 1886 |  |  |                Next_Elmt (Priv_Elmt);
 | 
      
         | 1887 |  |  |             end loop;
 | 
      
         | 1888 |  |  |          end if;
 | 
      
         | 1889 |  |  |  
 | 
      
         | 1890 |  |  |          Next_Entity (Id);
 | 
      
         | 1891 |  |  |       end loop;
 | 
      
         | 1892 |  |  |  
 | 
      
         | 1893 |  |  |       --  Next make other declarations in the private part visible as well
 | 
      
         | 1894 |  |  |  
 | 
      
         | 1895 |  |  |       Id := First_Private_Entity (P);
 | 
      
         | 1896 |  |  |       while Present (Id) loop
 | 
      
         | 1897 |  |  |          Install_Package_Entity (Id);
 | 
      
         | 1898 |  |  |          Set_Is_Hidden (Id, False);
 | 
      
         | 1899 |  |  |          Next_Entity (Id);
 | 
      
         | 1900 |  |  |       end loop;
 | 
      
         | 1901 |  |  |  
 | 
      
         | 1902 |  |  |       --  Indicate that the private part is currently visible, so it can be
 | 
      
         | 1903 |  |  |       --  properly reset on exit.
 | 
      
         | 1904 |  |  |  
 | 
      
         | 1905 |  |  |       Set_In_Private_Part (P);
 | 
      
         | 1906 |  |  |    end Install_Private_Declarations;
 | 
      
         | 1907 |  |  |  
 | 
      
         | 1908 |  |  |    ----------------------------------
 | 
      
         | 1909 |  |  |    -- Install_Visible_Declarations --
 | 
      
         | 1910 |  |  |    ----------------------------------
 | 
      
         | 1911 |  |  |  
 | 
      
         | 1912 |  |  |    procedure Install_Visible_Declarations (P : Entity_Id) is
 | 
      
         | 1913 |  |  |       Id          : Entity_Id;
 | 
      
         | 1914 |  |  |       Last_Entity : Entity_Id;
 | 
      
         | 1915 |  |  |  
 | 
      
         | 1916 |  |  |    begin
 | 
      
         | 1917 |  |  |       pragma Assert
 | 
      
         | 1918 |  |  |         (Is_Package_Or_Generic_Package (P) or else Is_Record_Type (P));
 | 
      
         | 1919 |  |  |  
 | 
      
         | 1920 |  |  |       if Is_Package_Or_Generic_Package (P) then
 | 
      
         | 1921 |  |  |          Last_Entity := First_Private_Entity (P);
 | 
      
         | 1922 |  |  |       else
 | 
      
         | 1923 |  |  |          Last_Entity := Empty;
 | 
      
         | 1924 |  |  |       end if;
 | 
      
         | 1925 |  |  |  
 | 
      
         | 1926 |  |  |       Id := First_Entity (P);
 | 
      
         | 1927 |  |  |       while Present (Id) and then Id /= Last_Entity loop
 | 
      
         | 1928 |  |  |          Install_Package_Entity (Id);
 | 
      
         | 1929 |  |  |          Next_Entity (Id);
 | 
      
         | 1930 |  |  |       end loop;
 | 
      
         | 1931 |  |  |    end Install_Visible_Declarations;
 | 
      
         | 1932 |  |  |  
 | 
      
         | 1933 |  |  |    --------------------------
 | 
      
         | 1934 |  |  |    -- Is_Private_Base_Type --
 | 
      
         | 1935 |  |  |    --------------------------
 | 
      
         | 1936 |  |  |  
 | 
      
         | 1937 |  |  |    function Is_Private_Base_Type (E : Entity_Id) return Boolean is
 | 
      
         | 1938 |  |  |    begin
 | 
      
         | 1939 |  |  |       return Ekind (E) = E_Private_Type
 | 
      
         | 1940 |  |  |         or else Ekind (E) = E_Limited_Private_Type
 | 
      
         | 1941 |  |  |         or else Ekind (E) = E_Record_Type_With_Private;
 | 
      
         | 1942 |  |  |    end Is_Private_Base_Type;
 | 
      
         | 1943 |  |  |  
 | 
      
         | 1944 |  |  |    --------------------------
 | 
      
         | 1945 |  |  |    -- Is_Visible_Dependent --
 | 
      
         | 1946 |  |  |    --------------------------
 | 
      
         | 1947 |  |  |  
 | 
      
         | 1948 |  |  |    function Is_Visible_Dependent (Dep : Entity_Id) return Boolean
 | 
      
         | 1949 |  |  |    is
 | 
      
         | 1950 |  |  |       S : constant Entity_Id := Scope (Dep);
 | 
      
         | 1951 |  |  |  
 | 
      
         | 1952 |  |  |    begin
 | 
      
         | 1953 |  |  |       --  Renamings created for actual types have the visibility of the actual
 | 
      
         | 1954 |  |  |  
 | 
      
         | 1955 |  |  |       if Ekind (S) = E_Package
 | 
      
         | 1956 |  |  |         and then Is_Generic_Instance (S)
 | 
      
         | 1957 |  |  |         and then (Is_Generic_Actual_Type (Dep)
 | 
      
         | 1958 |  |  |                    or else Is_Generic_Actual_Type (Full_View (Dep)))
 | 
      
         | 1959 |  |  |       then
 | 
      
         | 1960 |  |  |          return True;
 | 
      
         | 1961 |  |  |  
 | 
      
         | 1962 |  |  |       elsif not (Is_Derived_Type (Dep))
 | 
      
         | 1963 |  |  |         and then Is_Derived_Type (Full_View (Dep))
 | 
      
         | 1964 |  |  |       then
 | 
      
         | 1965 |  |  |          --  When instantiating a package body, the scope stack is empty, so
 | 
      
         | 1966 |  |  |          --  check instead whether the dependent type is defined in the same
 | 
      
         | 1967 |  |  |          --  scope as the instance itself.
 | 
      
         | 1968 |  |  |  
 | 
      
         | 1969 |  |  |          return In_Open_Scopes (S)
 | 
      
         | 1970 |  |  |            or else (Is_Generic_Instance (Current_Scope)
 | 
      
         | 1971 |  |  |               and then Scope (Dep) = Scope (Current_Scope));
 | 
      
         | 1972 |  |  |       else
 | 
      
         | 1973 |  |  |          return True;
 | 
      
         | 1974 |  |  |       end if;
 | 
      
         | 1975 |  |  |    end Is_Visible_Dependent;
 | 
      
         | 1976 |  |  |  
 | 
      
         | 1977 |  |  |    ----------------------------
 | 
      
         | 1978 |  |  |    -- May_Need_Implicit_Body --
 | 
      
         | 1979 |  |  |    ----------------------------
 | 
      
         | 1980 |  |  |  
 | 
      
         | 1981 |  |  |    procedure May_Need_Implicit_Body (E : Entity_Id) is
 | 
      
         | 1982 |  |  |       P     : constant Node_Id := Unit_Declaration_Node (E);
 | 
      
         | 1983 |  |  |       S     : constant Node_Id := Parent (P);
 | 
      
         | 1984 |  |  |       B     : Node_Id;
 | 
      
         | 1985 |  |  |       Decls : List_Id;
 | 
      
         | 1986 |  |  |  
 | 
      
         | 1987 |  |  |    begin
 | 
      
         | 1988 |  |  |       if not Has_Completion (E)
 | 
      
         | 1989 |  |  |         and then Nkind (P) = N_Package_Declaration
 | 
      
         | 1990 |  |  |         and then (Present (Activation_Chain_Entity (P)) or else Has_RACW (E))
 | 
      
         | 1991 |  |  |       then
 | 
      
         | 1992 |  |  |          B :=
 | 
      
         | 1993 |  |  |            Make_Package_Body (Sloc (E),
 | 
      
         | 1994 |  |  |              Defining_Unit_Name => Make_Defining_Identifier (Sloc (E),
 | 
      
         | 1995 |  |  |                Chars => Chars (E)),
 | 
      
         | 1996 |  |  |              Declarations  => New_List);
 | 
      
         | 1997 |  |  |  
 | 
      
         | 1998 |  |  |          if Nkind (S) = N_Package_Specification then
 | 
      
         | 1999 |  |  |             if Present (Private_Declarations (S)) then
 | 
      
         | 2000 |  |  |                Decls := Private_Declarations (S);
 | 
      
         | 2001 |  |  |             else
 | 
      
         | 2002 |  |  |                Decls := Visible_Declarations (S);
 | 
      
         | 2003 |  |  |             end if;
 | 
      
         | 2004 |  |  |          else
 | 
      
         | 2005 |  |  |             Decls := Declarations (S);
 | 
      
         | 2006 |  |  |          end if;
 | 
      
         | 2007 |  |  |  
 | 
      
         | 2008 |  |  |          Append (B, Decls);
 | 
      
         | 2009 |  |  |          Analyze (B);
 | 
      
         | 2010 |  |  |       end if;
 | 
      
         | 2011 |  |  |    end May_Need_Implicit_Body;
 | 
      
         | 2012 |  |  |  
 | 
      
         | 2013 |  |  |    ----------------------
 | 
      
         | 2014 |  |  |    -- New_Private_Type --
 | 
      
         | 2015 |  |  |    ----------------------
 | 
      
         | 2016 |  |  |  
 | 
      
         | 2017 |  |  |    procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id) is
 | 
      
         | 2018 |  |  |    begin
 | 
      
         | 2019 |  |  |       --  For other than Ada 2012, enter the name in the current scope
 | 
      
         | 2020 |  |  |  
 | 
      
         | 2021 |  |  |       if Ada_Version < Ada_2012 then
 | 
      
         | 2022 |  |  |          Enter_Name (Id);
 | 
      
         | 2023 |  |  |  
 | 
      
         | 2024 |  |  |       --  Ada 2012 (AI05-0162): Enter the name in the current scope handling
 | 
      
         | 2025 |  |  |       --  private type that completes an incomplete type.
 | 
      
         | 2026 |  |  |  
 | 
      
         | 2027 |  |  |       else
 | 
      
         | 2028 |  |  |          declare
 | 
      
         | 2029 |  |  |             Prev : Entity_Id;
 | 
      
         | 2030 |  |  |          begin
 | 
      
         | 2031 |  |  |             Prev := Find_Type_Name (N);
 | 
      
         | 2032 |  |  |             pragma Assert (Prev = Id
 | 
      
         | 2033 |  |  |               or else (Ekind (Prev) = E_Incomplete_Type
 | 
      
         | 2034 |  |  |                         and then Present (Full_View (Prev))
 | 
      
         | 2035 |  |  |                         and then Full_View (Prev) = Id));
 | 
      
         | 2036 |  |  |          end;
 | 
      
         | 2037 |  |  |       end if;
 | 
      
         | 2038 |  |  |  
 | 
      
         | 2039 |  |  |       if Limited_Present (Def) then
 | 
      
         | 2040 |  |  |          Set_Ekind (Id, E_Limited_Private_Type);
 | 
      
         | 2041 |  |  |       else
 | 
      
         | 2042 |  |  |          Set_Ekind (Id, E_Private_Type);
 | 
      
         | 2043 |  |  |       end if;
 | 
      
         | 2044 |  |  |  
 | 
      
         | 2045 |  |  |       Set_Etype              (Id, Id);
 | 
      
         | 2046 |  |  |       Set_Has_Delayed_Freeze (Id);
 | 
      
         | 2047 |  |  |       Set_Is_First_Subtype   (Id);
 | 
      
         | 2048 |  |  |       Init_Size_Align        (Id);
 | 
      
         | 2049 |  |  |  
 | 
      
         | 2050 |  |  |       Set_Is_Constrained (Id,
 | 
      
         | 2051 |  |  |         No (Discriminant_Specifications (N))
 | 
      
         | 2052 |  |  |           and then not Unknown_Discriminants_Present (N));
 | 
      
         | 2053 |  |  |  
 | 
      
         | 2054 |  |  |       --  Set tagged flag before processing discriminants, to catch illegal
 | 
      
         | 2055 |  |  |       --  usage.
 | 
      
         | 2056 |  |  |  
 | 
      
         | 2057 |  |  |       Set_Is_Tagged_Type (Id, Tagged_Present (Def));
 | 
      
         | 2058 |  |  |  
 | 
      
         | 2059 |  |  |       Set_Discriminant_Constraint (Id, No_Elist);
 | 
      
         | 2060 |  |  |       Set_Stored_Constraint (Id, No_Elist);
 | 
      
         | 2061 |  |  |  
 | 
      
         | 2062 |  |  |       if Present (Discriminant_Specifications (N)) then
 | 
      
         | 2063 |  |  |          Push_Scope (Id);
 | 
      
         | 2064 |  |  |          Process_Discriminants (N);
 | 
      
         | 2065 |  |  |          End_Scope;
 | 
      
         | 2066 |  |  |  
 | 
      
         | 2067 |  |  |       elsif Unknown_Discriminants_Present (N) then
 | 
      
         | 2068 |  |  |          Set_Has_Unknown_Discriminants (Id);
 | 
      
         | 2069 |  |  |       end if;
 | 
      
         | 2070 |  |  |  
 | 
      
         | 2071 |  |  |       Set_Private_Dependents (Id, New_Elmt_List);
 | 
      
         | 2072 |  |  |  
 | 
      
         | 2073 |  |  |       if Tagged_Present (Def) then
 | 
      
         | 2074 |  |  |          Set_Ekind                       (Id, E_Record_Type_With_Private);
 | 
      
         | 2075 |  |  |          Set_Direct_Primitive_Operations (Id, New_Elmt_List);
 | 
      
         | 2076 |  |  |          Set_Is_Abstract_Type            (Id, Abstract_Present (Def));
 | 
      
         | 2077 |  |  |          Set_Is_Limited_Record           (Id, Limited_Present (Def));
 | 
      
         | 2078 |  |  |          Set_Has_Delayed_Freeze          (Id, True);
 | 
      
         | 2079 |  |  |  
 | 
      
         | 2080 |  |  |          --  Create a class-wide type with the same attributes
 | 
      
         | 2081 |  |  |  
 | 
      
         | 2082 |  |  |          Make_Class_Wide_Type     (Id);
 | 
      
         | 2083 |  |  |  
 | 
      
         | 2084 |  |  |       elsif Abstract_Present (Def) then
 | 
      
         | 2085 |  |  |          Error_Msg_N ("only a tagged type can be abstract", N);
 | 
      
         | 2086 |  |  |       end if;
 | 
      
         | 2087 |  |  |    end New_Private_Type;
 | 
      
         | 2088 |  |  |  
 | 
      
         | 2089 |  |  |    ----------------------------
 | 
      
         | 2090 |  |  |    -- Uninstall_Declarations --
 | 
      
         | 2091 |  |  |    ----------------------------
 | 
      
         | 2092 |  |  |  
 | 
      
         | 2093 |  |  |    procedure Uninstall_Declarations (P : Entity_Id) is
 | 
      
         | 2094 |  |  |       Decl      : constant Node_Id := Unit_Declaration_Node (P);
 | 
      
         | 2095 |  |  |       Id        : Entity_Id;
 | 
      
         | 2096 |  |  |       Full      : Entity_Id;
 | 
      
         | 2097 |  |  |       Priv_Elmt : Elmt_Id;
 | 
      
         | 2098 |  |  |       Priv_Sub  : Entity_Id;
 | 
      
         | 2099 |  |  |  
 | 
      
         | 2100 |  |  |       procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
 | 
      
         | 2101 |  |  |       --  Copy to the private declaration the attributes of the full view that
 | 
      
         | 2102 |  |  |       --  need to be available for the partial view also.
 | 
      
         | 2103 |  |  |  
 | 
      
         | 2104 |  |  |       function Type_In_Use (T : Entity_Id) return Boolean;
 | 
      
         | 2105 |  |  |       --  Check whether type or base type appear in an active use_type clause
 | 
      
         | 2106 |  |  |  
 | 
      
         | 2107 |  |  |       ------------------------------
 | 
      
         | 2108 |  |  |       -- Preserve_Full_Attributes --
 | 
      
         | 2109 |  |  |       ------------------------------
 | 
      
         | 2110 |  |  |  
 | 
      
         | 2111 |  |  |       procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
 | 
      
         | 2112 |  |  |          Priv_Is_Base_Type : constant Boolean := Is_Base_Type (Priv);
 | 
      
         | 2113 |  |  |  
 | 
      
         | 2114 |  |  |       begin
 | 
      
         | 2115 |  |  |          Set_Size_Info (Priv, (Full));
 | 
      
         | 2116 |  |  |          Set_RM_Size                 (Priv, RM_Size (Full));
 | 
      
         | 2117 |  |  |          Set_Size_Known_At_Compile_Time
 | 
      
         | 2118 |  |  |                                      (Priv, Size_Known_At_Compile_Time (Full));
 | 
      
         | 2119 |  |  |          Set_Is_Volatile             (Priv, Is_Volatile                (Full));
 | 
      
         | 2120 |  |  |          Set_Treat_As_Volatile       (Priv, Treat_As_Volatile          (Full));
 | 
      
         | 2121 |  |  |          Set_Is_Ada_2005_Only        (Priv, Is_Ada_2005_Only           (Full));
 | 
      
         | 2122 |  |  |          Set_Is_Ada_2012_Only        (Priv, Is_Ada_2012_Only           (Full));
 | 
      
         | 2123 |  |  |          Set_Has_Pragma_Unmodified   (Priv, Has_Pragma_Unmodified      (Full));
 | 
      
         | 2124 |  |  |          Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced    (Full));
 | 
      
         | 2125 |  |  |          Set_Has_Pragma_Unreferenced_Objects
 | 
      
         | 2126 |  |  |                                      (Priv, Has_Pragma_Unreferenced_Objects
 | 
      
         | 2127 |  |  |                                                                        (Full));
 | 
      
         | 2128 |  |  |          if Is_Unchecked_Union (Full) then
 | 
      
         | 2129 |  |  |             Set_Is_Unchecked_Union (Base_Type (Priv));
 | 
      
         | 2130 |  |  |          end if;
 | 
      
         | 2131 |  |  |          --  Why is atomic not copied here ???
 | 
      
         | 2132 |  |  |  
 | 
      
         | 2133 |  |  |          if Referenced (Full) then
 | 
      
         | 2134 |  |  |             Set_Referenced (Priv);
 | 
      
         | 2135 |  |  |          end if;
 | 
      
         | 2136 |  |  |  
 | 
      
         | 2137 |  |  |          if Priv_Is_Base_Type then
 | 
      
         | 2138 |  |  |             Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full)));
 | 
      
         | 2139 |  |  |             Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only
 | 
      
         | 2140 |  |  |                                                            (Base_Type (Full)));
 | 
      
         | 2141 |  |  |             Set_Has_Task (Priv, Has_Task (Base_Type (Full)));
 | 
      
         | 2142 |  |  |             Set_Has_Controlled_Component (Priv, Has_Controlled_Component
 | 
      
         | 2143 |  |  |                                                            (Base_Type (Full)));
 | 
      
         | 2144 |  |  |          end if;
 | 
      
         | 2145 |  |  |  
 | 
      
         | 2146 |  |  |          Set_Freeze_Node (Priv, Freeze_Node (Full));
 | 
      
         | 2147 |  |  |  
 | 
      
         | 2148 |  |  |          if Is_Tagged_Type (Priv)
 | 
      
         | 2149 |  |  |            and then Is_Tagged_Type (Full)
 | 
      
         | 2150 |  |  |            and then not Error_Posted (Full)
 | 
      
         | 2151 |  |  |          then
 | 
      
         | 2152 |  |  |             if Is_Tagged_Type (Priv) then
 | 
      
         | 2153 |  |  |  
 | 
      
         | 2154 |  |  |                --  If the type is tagged, the tag itself must be available on
 | 
      
         | 2155 |  |  |                --  the partial view, for expansion purposes.
 | 
      
         | 2156 |  |  |  
 | 
      
         | 2157 |  |  |                Set_First_Entity (Priv, First_Entity (Full));
 | 
      
         | 2158 |  |  |  
 | 
      
         | 2159 |  |  |                --  If there are discriminants in the partial view, these remain
 | 
      
         | 2160 |  |  |                --  visible. Otherwise only the tag itself is visible, and there
 | 
      
         | 2161 |  |  |                --  are no nameable components in the partial view.
 | 
      
         | 2162 |  |  |  
 | 
      
         | 2163 |  |  |                if No (Last_Entity (Priv)) then
 | 
      
         | 2164 |  |  |                   Set_Last_Entity (Priv, First_Entity (Priv));
 | 
      
         | 2165 |  |  |                end if;
 | 
      
         | 2166 |  |  |             end if;
 | 
      
         | 2167 |  |  |  
 | 
      
         | 2168 |  |  |             Set_Has_Discriminants (Priv, Has_Discriminants (Full));
 | 
      
         | 2169 |  |  |  
 | 
      
         | 2170 |  |  |             if Has_Discriminants (Full) then
 | 
      
         | 2171 |  |  |                Set_Discriminant_Constraint (Priv,
 | 
      
         | 2172 |  |  |                  Discriminant_Constraint (Full));
 | 
      
         | 2173 |  |  |             end if;
 | 
      
         | 2174 |  |  |          end if;
 | 
      
         | 2175 |  |  |       end Preserve_Full_Attributes;
 | 
      
         | 2176 |  |  |  
 | 
      
         | 2177 |  |  |       -----------------
 | 
      
         | 2178 |  |  |       -- Type_In_Use --
 | 
      
         | 2179 |  |  |       -----------------
 | 
      
         | 2180 |  |  |  
 | 
      
         | 2181 |  |  |       function Type_In_Use (T : Entity_Id) return Boolean is
 | 
      
         | 2182 |  |  |       begin
 | 
      
         | 2183 |  |  |          return Scope (Base_Type (T)) = P
 | 
      
         | 2184 |  |  |            and then (In_Use (T) or else In_Use (Base_Type (T)));
 | 
      
         | 2185 |  |  |       end Type_In_Use;
 | 
      
         | 2186 |  |  |  
 | 
      
         | 2187 |  |  |    --  Start of processing for Uninstall_Declarations
 | 
      
         | 2188 |  |  |  
 | 
      
         | 2189 |  |  |    begin
 | 
      
         | 2190 |  |  |       Id := First_Entity (P);
 | 
      
         | 2191 |  |  |       while Present (Id) and then Id /= First_Private_Entity (P) loop
 | 
      
         | 2192 |  |  |          if Debug_Flag_E then
 | 
      
         | 2193 |  |  |             Write_Str ("unlinking visible entity ");
 | 
      
         | 2194 |  |  |             Write_Int (Int (Id));
 | 
      
         | 2195 |  |  |             Write_Eol;
 | 
      
         | 2196 |  |  |          end if;
 | 
      
         | 2197 |  |  |  
 | 
      
         | 2198 |  |  |          --  On  exit from the package scope, we must preserve the visibility
 | 
      
         | 2199 |  |  |          --  established by use clauses in the current scope. Two cases:
 | 
      
         | 2200 |  |  |  
 | 
      
         | 2201 |  |  |          --  a) If the entity is an operator, it may be a primitive operator of
 | 
      
         | 2202 |  |  |          --  a type for which there is a visible use-type clause.
 | 
      
         | 2203 |  |  |  
 | 
      
         | 2204 |  |  |          --  b) for other entities, their use-visibility is determined by a
 | 
      
         | 2205 |  |  |          --  visible use clause for the package itself. For a generic instance,
 | 
      
         | 2206 |  |  |          --  the instantiation of the formals appears in the visible part,
 | 
      
         | 2207 |  |  |          --  but the formals are private and remain so.
 | 
      
         | 2208 |  |  |  
 | 
      
         | 2209 |  |  |          if Ekind (Id) = E_Function
 | 
      
         | 2210 |  |  |            and then Is_Operator_Symbol_Name (Chars (Id))
 | 
      
         | 2211 |  |  |            and then not Is_Hidden (Id)
 | 
      
         | 2212 |  |  |            and then not Error_Posted (Id)
 | 
      
         | 2213 |  |  |          then
 | 
      
         | 2214 |  |  |             Set_Is_Potentially_Use_Visible (Id,
 | 
      
         | 2215 |  |  |               In_Use (P)
 | 
      
         | 2216 |  |  |               or else Type_In_Use (Etype (Id))
 | 
      
         | 2217 |  |  |               or else Type_In_Use (Etype (First_Formal (Id)))
 | 
      
         | 2218 |  |  |               or else (Present (Next_Formal (First_Formal (Id)))
 | 
      
         | 2219 |  |  |                          and then
 | 
      
         | 2220 |  |  |                            Type_In_Use
 | 
      
         | 2221 |  |  |                              (Etype (Next_Formal (First_Formal (Id))))));
 | 
      
         | 2222 |  |  |          else
 | 
      
         | 2223 |  |  |             if In_Use (P) and then not Is_Hidden (Id) then
 | 
      
         | 2224 |  |  |  
 | 
      
         | 2225 |  |  |                --  A child unit of a use-visible package remains use-visible
 | 
      
         | 2226 |  |  |                --  only if it is itself a visible child unit. Otherwise it
 | 
      
         | 2227 |  |  |                --  would remain visible in other contexts where P is use-
 | 
      
         | 2228 |  |  |                --  visible, because once compiled it stays in the entity list
 | 
      
         | 2229 |  |  |                --  of its parent unit.
 | 
      
         | 2230 |  |  |  
 | 
      
         | 2231 |  |  |                if Is_Child_Unit (Id) then
 | 
      
         | 2232 |  |  |                   Set_Is_Potentially_Use_Visible (Id,
 | 
      
         | 2233 |  |  |                     Is_Visible_Child_Unit (Id));
 | 
      
         | 2234 |  |  |                else
 | 
      
         | 2235 |  |  |                   Set_Is_Potentially_Use_Visible (Id);
 | 
      
         | 2236 |  |  |                end if;
 | 
      
         | 2237 |  |  |  
 | 
      
         | 2238 |  |  |             else
 | 
      
         | 2239 |  |  |                Set_Is_Potentially_Use_Visible (Id, False);
 | 
      
         | 2240 |  |  |             end if;
 | 
      
         | 2241 |  |  |          end if;
 | 
      
         | 2242 |  |  |  
 | 
      
         | 2243 |  |  |          --  Local entities are not immediately visible outside of the package
 | 
      
         | 2244 |  |  |  
 | 
      
         | 2245 |  |  |          Set_Is_Immediately_Visible (Id, False);
 | 
      
         | 2246 |  |  |  
 | 
      
         | 2247 |  |  |          --  If this is a private type with a full view (for example a local
 | 
      
         | 2248 |  |  |          --  subtype of a private type declared elsewhere), ensure that the
 | 
      
         | 2249 |  |  |          --  full view is also removed from visibility: it may be exposed when
 | 
      
         | 2250 |  |  |          --  swapping views in an instantiation.
 | 
      
         | 2251 |  |  |  
 | 
      
         | 2252 |  |  |          if Is_Type (Id)
 | 
      
         | 2253 |  |  |            and then Present (Full_View (Id))
 | 
      
         | 2254 |  |  |          then
 | 
      
         | 2255 |  |  |             Set_Is_Immediately_Visible (Full_View (Id), False);
 | 
      
         | 2256 |  |  |          end if;
 | 
      
         | 2257 |  |  |  
 | 
      
         | 2258 |  |  |          if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
 | 
      
         | 2259 |  |  |             Check_Abstract_Overriding (Id);
 | 
      
         | 2260 |  |  |             Check_Conventions (Id);
 | 
      
         | 2261 |  |  |          end if;
 | 
      
         | 2262 |  |  |  
 | 
      
         | 2263 |  |  |          if (Ekind (Id) = E_Private_Type
 | 
      
         | 2264 |  |  |                or else Ekind (Id) = E_Limited_Private_Type)
 | 
      
         | 2265 |  |  |            and then No (Full_View (Id))
 | 
      
         | 2266 |  |  |            and then not Is_Generic_Type (Id)
 | 
      
         | 2267 |  |  |            and then not Is_Derived_Type (Id)
 | 
      
         | 2268 |  |  |          then
 | 
      
         | 2269 |  |  |             Error_Msg_N ("missing full declaration for private type&", Id);
 | 
      
         | 2270 |  |  |  
 | 
      
         | 2271 |  |  |          elsif Ekind (Id) = E_Record_Type_With_Private
 | 
      
         | 2272 |  |  |            and then not Is_Generic_Type (Id)
 | 
      
         | 2273 |  |  |            and then No (Full_View (Id))
 | 
      
         | 2274 |  |  |          then
 | 
      
         | 2275 |  |  |             if Nkind (Parent (Id)) = N_Private_Type_Declaration then
 | 
      
         | 2276 |  |  |                Error_Msg_N ("missing full declaration for private type&", Id);
 | 
      
         | 2277 |  |  |             else
 | 
      
         | 2278 |  |  |                Error_Msg_N
 | 
      
         | 2279 |  |  |                  ("missing full declaration for private extension", Id);
 | 
      
         | 2280 |  |  |             end if;
 | 
      
         | 2281 |  |  |  
 | 
      
         | 2282 |  |  |          --  Case of constant, check for deferred constant declaration with
 | 
      
         | 2283 |  |  |          --  no full view. Likely just a matter of a missing expression, or
 | 
      
         | 2284 |  |  |          --  accidental use of the keyword constant.
 | 
      
         | 2285 |  |  |  
 | 
      
         | 2286 |  |  |          elsif Ekind (Id) = E_Constant
 | 
      
         | 2287 |  |  |  
 | 
      
         | 2288 |  |  |            --  OK if constant value present
 | 
      
         | 2289 |  |  |  
 | 
      
         | 2290 |  |  |            and then No (Constant_Value (Id))
 | 
      
         | 2291 |  |  |  
 | 
      
         | 2292 |  |  |            --  OK if full view present
 | 
      
         | 2293 |  |  |  
 | 
      
         | 2294 |  |  |            and then No (Full_View (Id))
 | 
      
         | 2295 |  |  |  
 | 
      
         | 2296 |  |  |            --  OK if imported, since that provides the completion
 | 
      
         | 2297 |  |  |  
 | 
      
         | 2298 |  |  |            and then not Is_Imported (Id)
 | 
      
         | 2299 |  |  |  
 | 
      
         | 2300 |  |  |            --  OK if object declaration replaced by renaming declaration as
 | 
      
         | 2301 |  |  |            --  a result of OK_To_Rename processing (e.g. for concatenation)
 | 
      
         | 2302 |  |  |  
 | 
      
         | 2303 |  |  |            and then Nkind (Parent (Id)) /= N_Object_Renaming_Declaration
 | 
      
         | 2304 |  |  |  
 | 
      
         | 2305 |  |  |            --  OK if object declaration with the No_Initialization flag set
 | 
      
         | 2306 |  |  |  
 | 
      
         | 2307 |  |  |            and then not (Nkind (Parent (Id)) = N_Object_Declaration
 | 
      
         | 2308 |  |  |                            and then No_Initialization (Parent (Id)))
 | 
      
         | 2309 |  |  |          then
 | 
      
         | 2310 |  |  |             --  If no private declaration is present, we assume the user did
 | 
      
         | 2311 |  |  |             --  not intend a deferred constant declaration and the problem
 | 
      
         | 2312 |  |  |             --  is simply that the initializing expression is missing.
 | 
      
         | 2313 |  |  |  
 | 
      
         | 2314 |  |  |             if not Has_Private_Declaration (Etype (Id)) then
 | 
      
         | 2315 |  |  |  
 | 
      
         | 2316 |  |  |                --  We assume that the user did not intend a deferred constant
 | 
      
         | 2317 |  |  |                --  declaration, and the expression is just missing.
 | 
      
         | 2318 |  |  |  
 | 
      
         | 2319 |  |  |                Error_Msg_N
 | 
      
         | 2320 |  |  |                  ("constant declaration requires initialization expression",
 | 
      
         | 2321 |  |  |                    Parent (Id));
 | 
      
         | 2322 |  |  |  
 | 
      
         | 2323 |  |  |                if Is_Limited_Type (Etype (Id)) then
 | 
      
         | 2324 |  |  |                   Error_Msg_N
 | 
      
         | 2325 |  |  |                     ("\if variable intended, remove CONSTANT from declaration",
 | 
      
         | 2326 |  |  |                     Parent (Id));
 | 
      
         | 2327 |  |  |                end if;
 | 
      
         | 2328 |  |  |  
 | 
      
         | 2329 |  |  |             --  Otherwise if a private declaration is present, then we are
 | 
      
         | 2330 |  |  |             --  missing the full declaration for the deferred constant.
 | 
      
         | 2331 |  |  |  
 | 
      
         | 2332 |  |  |             else
 | 
      
         | 2333 |  |  |                Error_Msg_N
 | 
      
         | 2334 |  |  |                   ("missing full declaration for deferred constant (RM 7.4)",
 | 
      
         | 2335 |  |  |                      Id);
 | 
      
         | 2336 |  |  |  
 | 
      
         | 2337 |  |  |                if Is_Limited_Type (Etype (Id)) then
 | 
      
         | 2338 |  |  |                   Error_Msg_N
 | 
      
         | 2339 |  |  |                     ("\if variable intended, remove CONSTANT from declaration",
 | 
      
         | 2340 |  |  |                     Parent (Id));
 | 
      
         | 2341 |  |  |                end if;
 | 
      
         | 2342 |  |  |             end if;
 | 
      
         | 2343 |  |  |          end if;
 | 
      
         | 2344 |  |  |  
 | 
      
         | 2345 |  |  |          Next_Entity (Id);
 | 
      
         | 2346 |  |  |       end loop;
 | 
      
         | 2347 |  |  |  
 | 
      
         | 2348 |  |  |       --  If the specification was installed as the parent of a public child
 | 
      
         | 2349 |  |  |       --  unit, the private declarations were not installed, and there is
 | 
      
         | 2350 |  |  |       --  nothing to do.
 | 
      
         | 2351 |  |  |  
 | 
      
         | 2352 |  |  |       if not In_Private_Part (P) then
 | 
      
         | 2353 |  |  |          return;
 | 
      
         | 2354 |  |  |       else
 | 
      
         | 2355 |  |  |          Set_In_Private_Part (P, False);
 | 
      
         | 2356 |  |  |       end if;
 | 
      
         | 2357 |  |  |  
 | 
      
         | 2358 |  |  |       --  Make private entities invisible and exchange full and private
 | 
      
         | 2359 |  |  |       --  declarations for private types. Id is now the first private entity
 | 
      
         | 2360 |  |  |       --  in the package.
 | 
      
         | 2361 |  |  |  
 | 
      
         | 2362 |  |  |       while Present (Id) loop
 | 
      
         | 2363 |  |  |          if Debug_Flag_E then
 | 
      
         | 2364 |  |  |             Write_Str ("unlinking private entity ");
 | 
      
         | 2365 |  |  |             Write_Int (Int (Id));
 | 
      
         | 2366 |  |  |             Write_Eol;
 | 
      
         | 2367 |  |  |          end if;
 | 
      
         | 2368 |  |  |  
 | 
      
         | 2369 |  |  |          if Is_Tagged_Type (Id) and then Ekind (Id) = E_Record_Type then
 | 
      
         | 2370 |  |  |             Check_Abstract_Overriding (Id);
 | 
      
         | 2371 |  |  |             Check_Conventions (Id);
 | 
      
         | 2372 |  |  |          end if;
 | 
      
         | 2373 |  |  |  
 | 
      
         | 2374 |  |  |          Set_Is_Immediately_Visible (Id, False);
 | 
      
         | 2375 |  |  |  
 | 
      
         | 2376 |  |  |          if Is_Private_Base_Type (Id)
 | 
      
         | 2377 |  |  |            and then Present (Full_View (Id))
 | 
      
         | 2378 |  |  |          then
 | 
      
         | 2379 |  |  |             Full := Full_View (Id);
 | 
      
         | 2380 |  |  |  
 | 
      
         | 2381 |  |  |             --  If the partial view is not declared in the visible part of the
 | 
      
         | 2382 |  |  |             --  package (as is the case when it is a type derived from some
 | 
      
         | 2383 |  |  |             --  other private type in the private part of the current package),
 | 
      
         | 2384 |  |  |             --  no exchange takes place.
 | 
      
         | 2385 |  |  |  
 | 
      
         | 2386 |  |  |             if No (Parent (Id))
 | 
      
         | 2387 |  |  |               or else List_Containing (Parent (Id))
 | 
      
         | 2388 |  |  |                 /= Visible_Declarations (Specification (Decl))
 | 
      
         | 2389 |  |  |             then
 | 
      
         | 2390 |  |  |                goto Next_Id;
 | 
      
         | 2391 |  |  |             end if;
 | 
      
         | 2392 |  |  |  
 | 
      
         | 2393 |  |  |             --  The entry in the private part points to the full declaration,
 | 
      
         | 2394 |  |  |             --  which is currently visible. Exchange them so only the private
 | 
      
         | 2395 |  |  |             --  type declaration remains accessible, and link private and full
 | 
      
         | 2396 |  |  |             --  declaration in the opposite direction. Before the actual
 | 
      
         | 2397 |  |  |             --  exchange, we copy back attributes of the full view that must
 | 
      
         | 2398 |  |  |             --  be available to the partial view too.
 | 
      
         | 2399 |  |  |  
 | 
      
         | 2400 |  |  |             Preserve_Full_Attributes (Id, Full);
 | 
      
         | 2401 |  |  |  
 | 
      
         | 2402 |  |  |             Set_Is_Potentially_Use_Visible (Id, In_Use (P));
 | 
      
         | 2403 |  |  |  
 | 
      
         | 2404 |  |  |             if  Is_Indefinite_Subtype (Full)
 | 
      
         | 2405 |  |  |               and then not Is_Indefinite_Subtype (Id)
 | 
      
         | 2406 |  |  |             then
 | 
      
         | 2407 |  |  |                Error_Msg_N
 | 
      
         | 2408 |  |  |                  ("full view of type must be definite subtype", Full);
 | 
      
         | 2409 |  |  |             end if;
 | 
      
         | 2410 |  |  |  
 | 
      
         | 2411 |  |  |             Priv_Elmt := First_Elmt (Private_Dependents (Id));
 | 
      
         | 2412 |  |  |  
 | 
      
         | 2413 |  |  |             --  Swap out the subtypes and derived types of Id that were
 | 
      
         | 2414 |  |  |             --  compiled in this scope, or installed previously by
 | 
      
         | 2415 |  |  |             --  Install_Private_Declarations.
 | 
      
         | 2416 |  |  |  
 | 
      
         | 2417 |  |  |             --  Before we do the swap, we verify the presence of the Full_View
 | 
      
         | 2418 |  |  |             --  field which may be empty due to a swap by a previous call to
 | 
      
         | 2419 |  |  |             --  End_Package_Scope (e.g. from the freezing mechanism).
 | 
      
         | 2420 |  |  |  
 | 
      
         | 2421 |  |  |             while Present (Priv_Elmt) loop
 | 
      
         | 2422 |  |  |                Priv_Sub := Node (Priv_Elmt);
 | 
      
         | 2423 |  |  |  
 | 
      
         | 2424 |  |  |                if Present (Full_View (Priv_Sub)) then
 | 
      
         | 2425 |  |  |  
 | 
      
         | 2426 |  |  |                   if Scope (Priv_Sub) = P
 | 
      
         | 2427 |  |  |                      or else not In_Open_Scopes (Scope (Priv_Sub))
 | 
      
         | 2428 |  |  |                   then
 | 
      
         | 2429 |  |  |                      Set_Is_Immediately_Visible (Priv_Sub, False);
 | 
      
         | 2430 |  |  |                   end if;
 | 
      
         | 2431 |  |  |  
 | 
      
         | 2432 |  |  |                   if Is_Visible_Dependent (Priv_Sub) then
 | 
      
         | 2433 |  |  |                      Preserve_Full_Attributes
 | 
      
         | 2434 |  |  |                        (Priv_Sub, Full_View (Priv_Sub));
 | 
      
         | 2435 |  |  |                      Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub));
 | 
      
         | 2436 |  |  |                      Exchange_Declarations (Priv_Sub);
 | 
      
         | 2437 |  |  |                   end if;
 | 
      
         | 2438 |  |  |                end if;
 | 
      
         | 2439 |  |  |  
 | 
      
         | 2440 |  |  |                Next_Elmt (Priv_Elmt);
 | 
      
         | 2441 |  |  |             end loop;
 | 
      
         | 2442 |  |  |  
 | 
      
         | 2443 |  |  |             --  Now restore the type itself to its private view
 | 
      
         | 2444 |  |  |  
 | 
      
         | 2445 |  |  |             Exchange_Declarations (Id);
 | 
      
         | 2446 |  |  |  
 | 
      
         | 2447 |  |  |             --  If we have installed an underlying full view for a type derived
 | 
      
         | 2448 |  |  |             --  from a private type in a child unit, restore the proper views
 | 
      
         | 2449 |  |  |             --  of private and full view. See corresponding code in
 | 
      
         | 2450 |  |  |             --  Install_Private_Declarations.
 | 
      
         | 2451 |  |  |  
 | 
      
         | 2452 |  |  |             --  After the exchange, Full denotes the private type in the
 | 
      
         | 2453 |  |  |             --  visible part of the package.
 | 
      
         | 2454 |  |  |  
 | 
      
         | 2455 |  |  |             if Is_Private_Base_Type (Full)
 | 
      
         | 2456 |  |  |               and then Present (Full_View (Full))
 | 
      
         | 2457 |  |  |               and then Present (Underlying_Full_View (Full))
 | 
      
         | 2458 |  |  |               and then In_Package_Body (Current_Scope)
 | 
      
         | 2459 |  |  |             then
 | 
      
         | 2460 |  |  |                Set_Full_View (Full, Underlying_Full_View (Full));
 | 
      
         | 2461 |  |  |                Set_Underlying_Full_View (Full, Empty);
 | 
      
         | 2462 |  |  |             end if;
 | 
      
         | 2463 |  |  |  
 | 
      
         | 2464 |  |  |          elsif Ekind (Id) = E_Incomplete_Type
 | 
      
         | 2465 |  |  |            and then Comes_From_Source (Id)
 | 
      
         | 2466 |  |  |            and then No (Full_View (Id))
 | 
      
         | 2467 |  |  |          then
 | 
      
         | 2468 |  |  |             --  Mark Taft amendment types. Verify that there are no primitive
 | 
      
         | 2469 |  |  |             --  operations declared for the type (3.10.1(9)).
 | 
      
         | 2470 |  |  |  
 | 
      
         | 2471 |  |  |             Set_Has_Completion_In_Body (Id);
 | 
      
         | 2472 |  |  |  
 | 
      
         | 2473 |  |  |             declare
 | 
      
         | 2474 |  |  |                Elmt : Elmt_Id;
 | 
      
         | 2475 |  |  |                Subp : Entity_Id;
 | 
      
         | 2476 |  |  |  
 | 
      
         | 2477 |  |  |             begin
 | 
      
         | 2478 |  |  |                Elmt := First_Elmt (Private_Dependents (Id));
 | 
      
         | 2479 |  |  |                while Present (Elmt) loop
 | 
      
         | 2480 |  |  |                   Subp := Node (Elmt);
 | 
      
         | 2481 |  |  |  
 | 
      
         | 2482 |  |  |                   --  Is_Primitive is tested because there can be cases where
 | 
      
         | 2483 |  |  |                   --  nonprimitive subprograms (in nested packages) are added
 | 
      
         | 2484 |  |  |                   --  to the Private_Dependents list.
 | 
      
         | 2485 |  |  |  
 | 
      
         | 2486 |  |  |                   if Is_Overloadable (Subp) and then Is_Primitive (Subp) then
 | 
      
         | 2487 |  |  |                      Error_Msg_NE
 | 
      
         | 2488 |  |  |                        ("type& must be completed in the private part",
 | 
      
         | 2489 |  |  |                          Parent (Subp), Id);
 | 
      
         | 2490 |  |  |  
 | 
      
         | 2491 |  |  |                   --  The result type of an access-to-function type cannot be a
 | 
      
         | 2492 |  |  |                   --  Taft-amendment type, unless the version is Ada 2012 or
 | 
      
         | 2493 |  |  |                   --  later (see AI05-151).
 | 
      
         | 2494 |  |  |  
 | 
      
         | 2495 |  |  |                   elsif Ada_Version < Ada_2012
 | 
      
         | 2496 |  |  |                     and then Ekind (Subp) = E_Subprogram_Type
 | 
      
         | 2497 |  |  |                   then
 | 
      
         | 2498 |  |  |                      if Etype (Subp) = Id
 | 
      
         | 2499 |  |  |                        or else
 | 
      
         | 2500 |  |  |                          (Is_Class_Wide_Type (Etype (Subp))
 | 
      
         | 2501 |  |  |                             and then Etype (Etype (Subp)) = Id)
 | 
      
         | 2502 |  |  |                      then
 | 
      
         | 2503 |  |  |                         Error_Msg_NE
 | 
      
         | 2504 |  |  |                           ("type& must be completed in the private part",
 | 
      
         | 2505 |  |  |                              Associated_Node_For_Itype (Subp), Id);
 | 
      
         | 2506 |  |  |                      end if;
 | 
      
         | 2507 |  |  |                   end if;
 | 
      
         | 2508 |  |  |  
 | 
      
         | 2509 |  |  |                   Next_Elmt (Elmt);
 | 
      
         | 2510 |  |  |                end loop;
 | 
      
         | 2511 |  |  |             end;
 | 
      
         | 2512 |  |  |  
 | 
      
         | 2513 |  |  |          elsif not Is_Child_Unit (Id)
 | 
      
         | 2514 |  |  |            and then (not Is_Private_Type (Id)
 | 
      
         | 2515 |  |  |                       or else No (Full_View (Id)))
 | 
      
         | 2516 |  |  |          then
 | 
      
         | 2517 |  |  |             Set_Is_Hidden (Id);
 | 
      
         | 2518 |  |  |             Set_Is_Potentially_Use_Visible (Id, False);
 | 
      
         | 2519 |  |  |          end if;
 | 
      
         | 2520 |  |  |  
 | 
      
         | 2521 |  |  |          <<Next_Id>>
 | 
      
         | 2522 |  |  |             Next_Entity (Id);
 | 
      
         | 2523 |  |  |       end loop;
 | 
      
         | 2524 |  |  |    end Uninstall_Declarations;
 | 
      
         | 2525 |  |  |  
 | 
      
         | 2526 |  |  |    ------------------------
 | 
      
         | 2527 |  |  |    -- Unit_Requires_Body --
 | 
      
         | 2528 |  |  |    ------------------------
 | 
      
         | 2529 |  |  |  
 | 
      
         | 2530 |  |  |    function Unit_Requires_Body (P : Entity_Id) return Boolean is
 | 
      
         | 2531 |  |  |       E : Entity_Id;
 | 
      
         | 2532 |  |  |  
 | 
      
         | 2533 |  |  |    begin
 | 
      
         | 2534 |  |  |       --  Imported entity never requires body. Right now, only subprograms can
 | 
      
         | 2535 |  |  |       --  be imported, but perhaps in the future we will allow import of
 | 
      
         | 2536 |  |  |       --  packages.
 | 
      
         | 2537 |  |  |  
 | 
      
         | 2538 |  |  |       if Is_Imported (P) then
 | 
      
         | 2539 |  |  |          return False;
 | 
      
         | 2540 |  |  |  
 | 
      
         | 2541 |  |  |       --  Body required if library package with pragma Elaborate_Body
 | 
      
         | 2542 |  |  |  
 | 
      
         | 2543 |  |  |       elsif Has_Pragma_Elaborate_Body (P) then
 | 
      
         | 2544 |  |  |          return True;
 | 
      
         | 2545 |  |  |  
 | 
      
         | 2546 |  |  |       --  Body required if subprogram
 | 
      
         | 2547 |  |  |  
 | 
      
         | 2548 |  |  |       elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
 | 
      
         | 2549 |  |  |          return True;
 | 
      
         | 2550 |  |  |  
 | 
      
         | 2551 |  |  |       --  Treat a block as requiring a body
 | 
      
         | 2552 |  |  |  
 | 
      
         | 2553 |  |  |       elsif Ekind (P) = E_Block then
 | 
      
         | 2554 |  |  |          return True;
 | 
      
         | 2555 |  |  |  
 | 
      
         | 2556 |  |  |       elsif Ekind (P) = E_Package
 | 
      
         | 2557 |  |  |         and then Nkind (Parent (P)) = N_Package_Specification
 | 
      
         | 2558 |  |  |         and then Present (Generic_Parent (Parent (P)))
 | 
      
         | 2559 |  |  |       then
 | 
      
         | 2560 |  |  |          declare
 | 
      
         | 2561 |  |  |             G_P : constant Entity_Id := Generic_Parent (Parent (P));
 | 
      
         | 2562 |  |  |          begin
 | 
      
         | 2563 |  |  |             if Has_Pragma_Elaborate_Body (G_P) then
 | 
      
         | 2564 |  |  |                return True;
 | 
      
         | 2565 |  |  |             end if;
 | 
      
         | 2566 |  |  |          end;
 | 
      
         | 2567 |  |  |       end if;
 | 
      
         | 2568 |  |  |  
 | 
      
         | 2569 |  |  |       --  Otherwise search entity chain for entity requiring completion
 | 
      
         | 2570 |  |  |  
 | 
      
         | 2571 |  |  |       E := First_Entity (P);
 | 
      
         | 2572 |  |  |       while Present (E) loop
 | 
      
         | 2573 |  |  |  
 | 
      
         | 2574 |  |  |          --  Always ignore child units. Child units get added to the entity
 | 
      
         | 2575 |  |  |          --  list of a parent unit, but are not original entities of the
 | 
      
         | 2576 |  |  |          --  parent, and so do not affect whether the parent needs a body.
 | 
      
         | 2577 |  |  |  
 | 
      
         | 2578 |  |  |          if Is_Child_Unit (E) then
 | 
      
         | 2579 |  |  |             null;
 | 
      
         | 2580 |  |  |  
 | 
      
         | 2581 |  |  |          --  Ignore formal packages and their renamings
 | 
      
         | 2582 |  |  |  
 | 
      
         | 2583 |  |  |          elsif Ekind (E) = E_Package
 | 
      
         | 2584 |  |  |            and then Nkind (Original_Node (Unit_Declaration_Node (E))) =
 | 
      
         | 2585 |  |  |                                                 N_Formal_Package_Declaration
 | 
      
         | 2586 |  |  |          then
 | 
      
         | 2587 |  |  |             null;
 | 
      
         | 2588 |  |  |  
 | 
      
         | 2589 |  |  |          --  Otherwise test to see if entity requires a completion.
 | 
      
         | 2590 |  |  |          --  Note that subprogram entities whose declaration does not come
 | 
      
         | 2591 |  |  |          --  from source are ignored here on the basis that we assume the
 | 
      
         | 2592 |  |  |          --  expander will provide an implicit completion at some point.
 | 
      
         | 2593 |  |  |  
 | 
      
         | 2594 |  |  |          elsif (Is_Overloadable (E)
 | 
      
         | 2595 |  |  |                and then Ekind (E) /= E_Enumeration_Literal
 | 
      
         | 2596 |  |  |                and then Ekind (E) /= E_Operator
 | 
      
         | 2597 |  |  |                and then not Is_Abstract_Subprogram (E)
 | 
      
         | 2598 |  |  |                and then not Has_Completion (E)
 | 
      
         | 2599 |  |  |                and then Comes_From_Source (Parent (E)))
 | 
      
         | 2600 |  |  |  
 | 
      
         | 2601 |  |  |            or else
 | 
      
         | 2602 |  |  |              (Ekind (E) = E_Package
 | 
      
         | 2603 |  |  |                and then E /= P
 | 
      
         | 2604 |  |  |                and then not Has_Completion (E)
 | 
      
         | 2605 |  |  |                and then Unit_Requires_Body (E))
 | 
      
         | 2606 |  |  |  
 | 
      
         | 2607 |  |  |            or else
 | 
      
         | 2608 |  |  |              (Ekind (E) = E_Incomplete_Type
 | 
      
         | 2609 |  |  |                and then No (Full_View (E))
 | 
      
         | 2610 |  |  |                and then not Is_Generic_Type (E))
 | 
      
         | 2611 |  |  |  
 | 
      
         | 2612 |  |  |            or else
 | 
      
         | 2613 |  |  |             ((Ekind (E) = E_Task_Type or else
 | 
      
         | 2614 |  |  |               Ekind (E) = E_Protected_Type)
 | 
      
         | 2615 |  |  |                and then not Has_Completion (E))
 | 
      
         | 2616 |  |  |  
 | 
      
         | 2617 |  |  |            or else
 | 
      
         | 2618 |  |  |              (Ekind (E) = E_Generic_Package and then E /= P
 | 
      
         | 2619 |  |  |                and then not Has_Completion (E)
 | 
      
         | 2620 |  |  |                and then Unit_Requires_Body (E))
 | 
      
         | 2621 |  |  |  
 | 
      
         | 2622 |  |  |            or else
 | 
      
         | 2623 |  |  |              (Is_Generic_Subprogram (E)
 | 
      
         | 2624 |  |  |                and then not Has_Completion (E))
 | 
      
         | 2625 |  |  |  
 | 
      
         | 2626 |  |  |          then
 | 
      
         | 2627 |  |  |             return True;
 | 
      
         | 2628 |  |  |  
 | 
      
         | 2629 |  |  |          --  Entity that does not require completion
 | 
      
         | 2630 |  |  |  
 | 
      
         | 2631 |  |  |          else
 | 
      
         | 2632 |  |  |             null;
 | 
      
         | 2633 |  |  |          end if;
 | 
      
         | 2634 |  |  |  
 | 
      
         | 2635 |  |  |          Next_Entity (E);
 | 
      
         | 2636 |  |  |       end loop;
 | 
      
         | 2637 |  |  |  
 | 
      
         | 2638 |  |  |       return False;
 | 
      
         | 2639 |  |  |    end Unit_Requires_Body;
 | 
      
         | 2640 |  |  |  
 | 
      
         | 2641 |  |  | end Sem_Ch7;
 |