1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ C H 3 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2021, 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 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Contracts; use Contracts; 30with Debug; use Debug; 31with Elists; use Elists; 32with Einfo; use Einfo; 33with Einfo.Entities; use Einfo.Entities; 34with Einfo.Utils; use Einfo.Utils; 35with Errout; use Errout; 36with Eval_Fat; use Eval_Fat; 37with Exp_Ch3; use Exp_Ch3; 38with Exp_Ch9; use Exp_Ch9; 39with Exp_Disp; use Exp_Disp; 40with Exp_Dist; use Exp_Dist; 41with Exp_Tss; use Exp_Tss; 42with Exp_Util; use Exp_Util; 43with Freeze; use Freeze; 44with Ghost; use Ghost; 45with Itypes; use Itypes; 46with Layout; use Layout; 47with Lib; use Lib; 48with Lib.Xref; use Lib.Xref; 49with Namet; use Namet; 50with Nlists; use Nlists; 51with Nmake; use Nmake; 52with Opt; use Opt; 53with Restrict; use Restrict; 54with Rident; use Rident; 55with Rtsfind; use Rtsfind; 56with Sem; use Sem; 57with Sem_Aux; use Sem_Aux; 58with Sem_Case; use Sem_Case; 59with Sem_Cat; use Sem_Cat; 60with Sem_Ch6; use Sem_Ch6; 61with Sem_Ch7; use Sem_Ch7; 62with Sem_Ch8; use Sem_Ch8; 63with Sem_Ch13; use Sem_Ch13; 64with Sem_Dim; use Sem_Dim; 65with Sem_Disp; use Sem_Disp; 66with Sem_Dist; use Sem_Dist; 67with Sem_Elab; use Sem_Elab; 68with Sem_Elim; use Sem_Elim; 69with Sem_Eval; use Sem_Eval; 70with Sem_Mech; use Sem_Mech; 71with Sem_Res; use Sem_Res; 72with Sem_Smem; use Sem_Smem; 73with Sem_Type; use Sem_Type; 74with Sem_Util; use Sem_Util; 75with Sem_Warn; use Sem_Warn; 76with Stand; use Stand; 77with Sinfo; use Sinfo; 78with Sinfo.Nodes; use Sinfo.Nodes; 79with Sinfo.Utils; use Sinfo.Utils; 80with Sinput; use Sinput; 81with Snames; use Snames; 82with Strub; use Strub; 83with Targparm; use Targparm; 84with Tbuild; use Tbuild; 85with Ttypes; use Ttypes; 86with Uintp; use Uintp; 87with Urealp; use Urealp; 88 89package body Sem_Ch3 is 90 91 ----------------------- 92 -- Local Subprograms -- 93 ----------------------- 94 95 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id); 96 -- Ada 2005 (AI-251): Add the tag components corresponding to all the 97 -- abstract interface types implemented by a record type or a derived 98 -- record type. 99 100 procedure Build_Access_Subprogram_Wrapper (Decl : Node_Id); 101 -- When an access-to-subprogram type has pre/postconditions, we build a 102 -- subprogram that includes these contracts and is invoked by an indirect 103 -- call through the corresponding access type. 104 105 procedure Build_Derived_Type 106 (N : Node_Id; 107 Parent_Type : Entity_Id; 108 Derived_Type : Entity_Id; 109 Is_Completion : Boolean; 110 Derive_Subps : Boolean := True); 111 -- Create and decorate a Derived_Type given the Parent_Type entity. N is 112 -- the N_Full_Type_Declaration node containing the derived type definition. 113 -- Parent_Type is the entity for the parent type in the derived type 114 -- definition and Derived_Type the actual derived type. Is_Completion must 115 -- be set to False if Derived_Type is the N_Defining_Identifier node in N 116 -- (i.e. Derived_Type = Defining_Identifier (N)). In this case N is not the 117 -- completion of a private type declaration. If Is_Completion is set to 118 -- True, N is the completion of a private type declaration and Derived_Type 119 -- is different from the defining identifier inside N (i.e. Derived_Type /= 120 -- Defining_Identifier (N)). Derive_Subps indicates whether the parent 121 -- subprograms should be derived. The only case where this parameter is 122 -- False is when Build_Derived_Type is recursively called to process an 123 -- implicit derived full type for a type derived from a private type (in 124 -- that case the subprograms must only be derived for the private view of 125 -- the type). 126 -- 127 -- ??? These flags need a bit of re-examination and re-documentation: 128 -- ??? are they both necessary (both seem related to the recursion)? 129 130 procedure Build_Derived_Access_Type 131 (N : Node_Id; 132 Parent_Type : Entity_Id; 133 Derived_Type : Entity_Id); 134 -- Subsidiary procedure to Build_Derived_Type. For a derived access type, 135 -- create an implicit base if the parent type is constrained or if the 136 -- subtype indication has a constraint. 137 138 procedure Build_Derived_Array_Type 139 (N : Node_Id; 140 Parent_Type : Entity_Id; 141 Derived_Type : Entity_Id); 142 -- Subsidiary procedure to Build_Derived_Type. For a derived array type, 143 -- create an implicit base if the parent type is constrained or if the 144 -- subtype indication has a constraint. 145 146 procedure Build_Derived_Concurrent_Type 147 (N : Node_Id; 148 Parent_Type : Entity_Id; 149 Derived_Type : Entity_Id); 150 -- Subsidiary procedure to Build_Derived_Type. For a derived task or 151 -- protected type, inherit entries and protected subprograms, check 152 -- legality of discriminant constraints if any. 153 154 procedure Build_Derived_Enumeration_Type 155 (N : Node_Id; 156 Parent_Type : Entity_Id; 157 Derived_Type : Entity_Id); 158 -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration 159 -- type, we must create a new list of literals. Types derived from 160 -- Character and [Wide_]Wide_Character are special-cased. 161 162 procedure Build_Derived_Numeric_Type 163 (N : Node_Id; 164 Parent_Type : Entity_Id; 165 Derived_Type : Entity_Id); 166 -- Subsidiary procedure to Build_Derived_Type. For numeric types, create 167 -- an anonymous base type, and propagate constraint to subtype if needed. 168 169 procedure Build_Derived_Private_Type 170 (N : Node_Id; 171 Parent_Type : Entity_Id; 172 Derived_Type : Entity_Id; 173 Is_Completion : Boolean; 174 Derive_Subps : Boolean := True); 175 -- Subsidiary procedure to Build_Derived_Type. This procedure is complex 176 -- because the parent may or may not have a completion, and the derivation 177 -- may itself be a completion. 178 179 procedure Build_Derived_Record_Type 180 (N : Node_Id; 181 Parent_Type : Entity_Id; 182 Derived_Type : Entity_Id; 183 Derive_Subps : Boolean := True); 184 -- Subsidiary procedure used for tagged and untagged record types 185 -- by Build_Derived_Type and Analyze_Private_Extension_Declaration. 186 -- All parameters are as in Build_Derived_Type except that N, in 187 -- addition to being an N_Full_Type_Declaration node, can also be an 188 -- N_Private_Extension_Declaration node. See the definition of this routine 189 -- for much more info. Derive_Subps indicates whether subprograms should be 190 -- derived from the parent type. The only case where Derive_Subps is False 191 -- is for an implicit derived full type for a type derived from a private 192 -- type (see Build_Derived_Type). 193 194 procedure Build_Discriminal (Discrim : Entity_Id); 195 -- Create the discriminal corresponding to discriminant Discrim, that is 196 -- the parameter corresponding to Discrim to be used in initialization 197 -- procedures for the type where Discrim is a discriminant. Discriminals 198 -- are not used during semantic analysis, and are not fully defined 199 -- entities until expansion. Thus they are not given a scope until 200 -- initialization procedures are built. 201 202 function Build_Discriminant_Constraints 203 (T : Entity_Id; 204 Def : Node_Id; 205 Derived_Def : Boolean := False) return Elist_Id; 206 -- Validate discriminant constraints and return the list of the constraints 207 -- in order of discriminant declarations, where T is the discriminated 208 -- unconstrained type. Def is the N_Subtype_Indication node where the 209 -- discriminants constraints for T are specified. Derived_Def is True 210 -- when building the discriminant constraints in a derived type definition 211 -- of the form "type D (...) is new T (xxx)". In this case T is the parent 212 -- type and Def is the constraint "(xxx)" on T and this routine sets the 213 -- Corresponding_Discriminant field of the discriminants in the derived 214 -- type D to point to the corresponding discriminants in the parent type T. 215 216 procedure Build_Discriminated_Subtype 217 (T : Entity_Id; 218 Def_Id : Entity_Id; 219 Elist : Elist_Id; 220 Related_Nod : Node_Id; 221 For_Access : Boolean := False); 222 -- Subsidiary procedure to Constrain_Discriminated_Type and to 223 -- Process_Incomplete_Dependents. Given 224 -- 225 -- T (a possibly discriminated base type) 226 -- Def_Id (a very partially built subtype for T), 227 -- 228 -- the call completes Def_Id to be the appropriate E_*_Subtype. 229 -- 230 -- The Elist is the list of discriminant constraints if any (it is set 231 -- to No_Elist if T is not a discriminated type, and to an empty list if 232 -- T has discriminants but there are no discriminant constraints). The 233 -- Related_Nod is the same as Decl_Node in Create_Constrained_Components. 234 -- The For_Access says whether or not this subtype is really constraining 235 -- an access type. 236 237 function Build_Scalar_Bound 238 (Bound : Node_Id; 239 Par_T : Entity_Id; 240 Der_T : Entity_Id) return Node_Id; 241 -- The bounds of a derived scalar type are conversions of the bounds of 242 -- the parent type. Optimize the representation if the bounds are literals. 243 -- Needs a more complete spec--what are the parameters exactly, and what 244 -- exactly is the returned value, and how is Bound affected??? 245 246 procedure Check_Access_Discriminant_Requires_Limited 247 (D : Node_Id; 248 Loc : Node_Id); 249 -- Check the restriction that the type to which an access discriminant 250 -- belongs must be a concurrent type or a descendant of a type with 251 -- the reserved word 'limited' in its declaration. 252 253 procedure Check_Anonymous_Access_Component 254 (Typ_Decl : Node_Id; 255 Typ : Entity_Id; 256 Prev : Entity_Id; 257 Comp_Def : Node_Id; 258 Access_Def : Node_Id); 259 -- Ada 2005 AI-382: an access component in a record definition can refer to 260 -- the enclosing record, in which case it denotes the type itself, and not 261 -- the current instance of the type. We create an anonymous access type for 262 -- the component, and flag it as an access to a component, so accessibility 263 -- checks are properly performed on it. The declaration of the access type 264 -- is placed ahead of that of the record to prevent order-of-elaboration 265 -- circularity issues in Gigi. We create an incomplete type for the record 266 -- declaration, which is the designated type of the anonymous access. 267 268 procedure Check_Anonymous_Access_Components 269 (Typ_Decl : Node_Id; 270 Typ : Entity_Id; 271 Prev : Entity_Id; 272 Comp_List : Node_Id); 273 -- Call Check_Anonymous_Access_Component on Comp_List 274 275 procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id); 276 -- Check that, if a new discriminant is used in a constraint defining the 277 -- parent subtype of a derivation, its subtype is statically compatible 278 -- with the subtype of the corresponding parent discriminant (RM 3.7(15)). 279 280 procedure Check_Delta_Expression (E : Node_Id); 281 -- Check that the expression represented by E is suitable for use as a 282 -- delta expression, i.e. it is of real type and is static. 283 284 procedure Check_Digits_Expression (E : Node_Id); 285 -- Check that the expression represented by E is suitable for use as a 286 -- digits expression, i.e. it is of integer type, positive and static. 287 288 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id); 289 -- Validate the initialization of an object declaration. T is the required 290 -- type, and Exp is the initialization expression. 291 292 procedure Check_Interfaces (N : Node_Id; Def : Node_Id); 293 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) 294 295 procedure Check_Or_Process_Discriminants 296 (N : Node_Id; 297 T : Entity_Id; 298 Prev : Entity_Id := Empty); 299 -- If N is the full declaration of the completion T of an incomplete or 300 -- private type, check its discriminants (which are already known to be 301 -- conformant with those of the partial view, see Find_Type_Name), 302 -- otherwise process them. Prev is the entity of the partial declaration, 303 -- if any. 304 305 procedure Check_Real_Bound (Bound : Node_Id); 306 -- Check given bound for being of real type and static. If not, post an 307 -- appropriate message, and rewrite the bound with the real literal zero. 308 309 procedure Constant_Redeclaration 310 (Id : Entity_Id; 311 N : Node_Id; 312 T : out Entity_Id); 313 -- Various checks on legality of full declaration of deferred constant. 314 -- Id is the entity for the redeclaration, N is the N_Object_Declaration, 315 -- node. The caller has not yet set any attributes of this entity. 316 317 function Contain_Interface 318 (Iface : Entity_Id; 319 Ifaces : Elist_Id) return Boolean; 320 -- Ada 2005: Determine whether Iface is present in the list Ifaces 321 322 procedure Convert_Scalar_Bounds 323 (N : Node_Id; 324 Parent_Type : Entity_Id; 325 Derived_Type : Entity_Id; 326 Loc : Source_Ptr); 327 -- For derived scalar types, convert the bounds in the type definition to 328 -- the derived type, and complete their analysis. Given a constraint of the 329 -- form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with 330 -- T'Base, the parent_type. The bounds of the derived type (the anonymous 331 -- base) are copies of Lo and Hi. Finally, the bounds of the derived 332 -- subtype are conversions of those bounds to the derived_type, so that 333 -- their typing is consistent. 334 335 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id); 336 -- Copies attributes from array base type T2 to array base type T1. Copies 337 -- only attributes that apply to base types, but not subtypes. 338 339 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id); 340 -- Copies attributes from array subtype T2 to array subtype T1. Copies 341 -- attributes that apply to both subtypes and base types. 342 343 procedure Create_Constrained_Components 344 (Subt : Entity_Id; 345 Decl_Node : Node_Id; 346 Typ : Entity_Id; 347 Constraints : Elist_Id); 348 -- Build the list of entities for a constrained discriminated record 349 -- subtype. If a component depends on a discriminant, replace its subtype 350 -- using the discriminant values in the discriminant constraint. Subt 351 -- is the defining identifier for the subtype whose list of constrained 352 -- entities we will create. Decl_Node is the type declaration node where 353 -- we will attach all the itypes created. Typ is the base discriminated 354 -- type for the subtype Subt. Constraints is the list of discriminant 355 -- constraints for Typ. 356 357 function Constrain_Component_Type 358 (Comp : Entity_Id; 359 Constrained_Typ : Entity_Id; 360 Related_Node : Node_Id; 361 Typ : Entity_Id; 362 Constraints : Elist_Id) return Entity_Id; 363 -- Given a discriminated base type Typ, a list of discriminant constraints, 364 -- Constraints, for Typ and a component Comp of Typ, create and return the 365 -- type corresponding to Etype (Comp) where all discriminant references 366 -- are replaced with the corresponding constraint. If Etype (Comp) contains 367 -- no discriminant references then it is returned as-is. Constrained_Typ 368 -- is the final constrained subtype to which the constrained component 369 -- belongs. Related_Node is the node where we attach all created itypes. 370 371 procedure Constrain_Access 372 (Def_Id : in out Entity_Id; 373 S : Node_Id; 374 Related_Nod : Node_Id); 375 -- Apply a list of constraints to an access type. If Def_Id is empty, it is 376 -- an anonymous type created for a subtype indication. In that case it is 377 -- created in the procedure and attached to Related_Nod. 378 379 procedure Constrain_Array 380 (Def_Id : in out Entity_Id; 381 SI : Node_Id; 382 Related_Nod : Node_Id; 383 Related_Id : Entity_Id; 384 Suffix : Character); 385 -- Apply a list of index constraints to an unconstrained array type. The 386 -- first parameter is the entity for the resulting subtype. A value of 387 -- Empty for Def_Id indicates that an implicit type must be created, but 388 -- creation is delayed (and must be done by this procedure) because other 389 -- subsidiary implicit types must be created first (which is why Def_Id 390 -- is an in/out parameter). The second parameter is a subtype indication 391 -- node for the constrained array to be created (e.g. something of the 392 -- form string (1 .. 10)). Related_Nod gives the place where this type 393 -- has to be inserted in the tree. The Related_Id and Suffix parameters 394 -- are used to build the associated Implicit type name. 395 396 procedure Constrain_Concurrent 397 (Def_Id : in out Entity_Id; 398 SI : Node_Id; 399 Related_Nod : Node_Id; 400 Related_Id : Entity_Id; 401 Suffix : Character); 402 -- Apply list of discriminant constraints to an unconstrained concurrent 403 -- type. 404 -- 405 -- SI is the N_Subtype_Indication node containing the constraint and 406 -- the unconstrained type to constrain. 407 -- 408 -- Def_Id is the entity for the resulting constrained subtype. A value 409 -- of Empty for Def_Id indicates that an implicit type must be created, 410 -- but creation is delayed (and must be done by this procedure) because 411 -- other subsidiary implicit types must be created first (which is why 412 -- Def_Id is an in/out parameter). 413 -- 414 -- Related_Nod gives the place where this type has to be inserted 415 -- in the tree. 416 -- 417 -- The last two arguments are used to create its external name if needed. 418 419 function Constrain_Corresponding_Record 420 (Prot_Subt : Entity_Id; 421 Corr_Rec : Entity_Id; 422 Related_Nod : Node_Id) return Entity_Id; 423 -- When constraining a protected type or task type with discriminants, 424 -- constrain the corresponding record with the same discriminant values. 425 426 procedure Constrain_Decimal (Def_Id : Entity_Id; S : Node_Id); 427 -- Constrain a decimal fixed point type with a digits constraint and/or a 428 -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity. 429 430 procedure Constrain_Discriminated_Type 431 (Def_Id : Entity_Id; 432 S : Node_Id; 433 Related_Nod : Node_Id; 434 For_Access : Boolean := False); 435 -- Process discriminant constraints of composite type. Verify that values 436 -- have been provided for all discriminants, that the original type is 437 -- unconstrained, and that the types of the supplied expressions match 438 -- the discriminant types. The first three parameters are like in routine 439 -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation 440 -- of For_Access. 441 442 procedure Constrain_Enumeration (Def_Id : Entity_Id; S : Node_Id); 443 -- Constrain an enumeration type with a range constraint. This is identical 444 -- to Constrain_Integer, but for the Ekind of the resulting subtype. 445 446 procedure Constrain_Float (Def_Id : Entity_Id; S : Node_Id); 447 -- Constrain a floating point type with either a digits constraint 448 -- and/or a range constraint, building a E_Floating_Point_Subtype. 449 450 procedure Constrain_Index 451 (Index : Node_Id; 452 S : Node_Id; 453 Related_Nod : Node_Id; 454 Related_Id : Entity_Id; 455 Suffix : Character; 456 Suffix_Index : Pos); 457 -- Process an index constraint S in a constrained array declaration. The 458 -- constraint can be a subtype name, or a range with or without an explicit 459 -- subtype mark. The index is the corresponding index of the unconstrained 460 -- array. The Related_Id and Suffix parameters are used to build the 461 -- associated Implicit type name. 462 463 procedure Constrain_Integer (Def_Id : Entity_Id; S : Node_Id); 464 -- Build subtype of a signed or modular integer type 465 466 procedure Constrain_Ordinary_Fixed (Def_Id : Entity_Id; S : Node_Id); 467 -- Constrain an ordinary fixed point type with a range constraint, and 468 -- build an E_Ordinary_Fixed_Point_Subtype entity. 469 470 procedure Copy_And_Swap (Priv, Full : Entity_Id); 471 -- Copy the Priv entity into the entity of its full declaration then swap 472 -- the two entities in such a manner that the former private type is now 473 -- seen as a full type. 474 475 procedure Decimal_Fixed_Point_Type_Declaration 476 (T : Entity_Id; 477 Def : Node_Id); 478 -- Create a new decimal fixed point type, and apply the constraint to 479 -- obtain a subtype of this new type. 480 481 procedure Complete_Private_Subtype 482 (Priv : Entity_Id; 483 Full : Entity_Id; 484 Full_Base : Entity_Id; 485 Related_Nod : Node_Id); 486 -- Complete the implicit full view of a private subtype by setting the 487 -- appropriate semantic fields. If the full view of the parent is a record 488 -- type, build constrained components of subtype. 489 490 procedure Derive_Progenitor_Subprograms 491 (Parent_Type : Entity_Id; 492 Tagged_Type : Entity_Id); 493 -- Ada 2005 (AI-251): To complete type derivation, collect the primitive 494 -- operations of progenitors of Tagged_Type, and replace the subsidiary 495 -- subtypes with Tagged_Type, to build the specs of the inherited interface 496 -- primitives. The derived primitives are aliased to those of the 497 -- interface. This routine takes care also of transferring to the full view 498 -- subprograms associated with the partial view of Tagged_Type that cover 499 -- interface primitives. 500 501 procedure Derived_Standard_Character 502 (N : Node_Id; 503 Parent_Type : Entity_Id; 504 Derived_Type : Entity_Id); 505 -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles 506 -- derivations from types Standard.Character and Standard.Wide_Character. 507 508 procedure Derived_Type_Declaration 509 (T : Entity_Id; 510 N : Node_Id; 511 Is_Completion : Boolean); 512 -- Process a derived type declaration. Build_Derived_Type is invoked 513 -- to process the actual derived type definition. Parameters N and 514 -- Is_Completion have the same meaning as in Build_Derived_Type. 515 -- T is the N_Defining_Identifier for the entity defined in the 516 -- N_Full_Type_Declaration node N, that is T is the derived type. 517 518 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id); 519 -- Insert each literal in symbol table, as an overloadable identifier. Each 520 -- enumeration type is mapped into a sequence of integers, and each literal 521 -- is defined as a constant with integer value. If any of the literals are 522 -- character literals, the type is a character type, which means that 523 -- strings are legal aggregates for arrays of components of the type. 524 525 function Expand_To_Stored_Constraint 526 (Typ : Entity_Id; 527 Constraint : Elist_Id) return Elist_Id; 528 -- Given a constraint (i.e. a list of expressions) on the discriminants of 529 -- Typ, expand it into a constraint on the stored discriminants and return 530 -- the new list of expressions constraining the stored discriminants. 531 532 function Find_Type_Of_Object 533 (Obj_Def : Node_Id; 534 Related_Nod : Node_Id) return Entity_Id; 535 -- Get type entity for object referenced by Obj_Def, attaching the implicit 536 -- types generated to Related_Nod. 537 538 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id); 539 -- Create a new float and apply the constraint to obtain subtype of it 540 541 function Has_Range_Constraint (N : Node_Id) return Boolean; 542 -- Given an N_Subtype_Indication node N, return True if a range constraint 543 -- is present, either directly, or as part of a digits or delta constraint. 544 -- In addition, a digits constraint in the decimal case returns True, since 545 -- it establishes a default range if no explicit range is present. 546 547 function Inherit_Components 548 (N : Node_Id; 549 Parent_Base : Entity_Id; 550 Derived_Base : Entity_Id; 551 Is_Tagged : Boolean; 552 Inherit_Discr : Boolean; 553 Discs : Elist_Id) return Elist_Id; 554 -- Called from Build_Derived_Record_Type to inherit the components of 555 -- Parent_Base (a base type) into the Derived_Base (the derived base type). 556 -- For more information on derived types and component inheritance please 557 -- consult the comment above the body of Build_Derived_Record_Type. 558 -- 559 -- N is the original derived type declaration 560 -- 561 -- Is_Tagged is set if we are dealing with tagged types 562 -- 563 -- If Inherit_Discr is set, Derived_Base inherits its discriminants from 564 -- Parent_Base, otherwise no discriminants are inherited. 565 -- 566 -- Discs gives the list of constraints that apply to Parent_Base in the 567 -- derived type declaration. If Discs is set to No_Elist, then we have 568 -- the following situation: 569 -- 570 -- type Parent (D1..Dn : ..) is [tagged] record ...; 571 -- type Derived is new Parent [with ...]; 572 -- 573 -- which gets treated as 574 -- 575 -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...]; 576 -- 577 -- For untagged types the returned value is an association list. The list 578 -- starts from the association (Parent_Base => Derived_Base), and then it 579 -- contains a sequence of the associations of the form 580 -- 581 -- (Old_Component => New_Component), 582 -- 583 -- where Old_Component is the Entity_Id of a component in Parent_Base and 584 -- New_Component is the Entity_Id of the corresponding component in 585 -- Derived_Base. For untagged records, this association list is needed when 586 -- copying the record declaration for the derived base. In the tagged case 587 -- the value returned is irrelevant. 588 589 function Is_EVF_Procedure (Subp : Entity_Id) return Boolean; 590 -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram. 591 -- Determine whether subprogram Subp is a procedure subject to pragma 592 -- Extensions_Visible with value False and has at least one controlling 593 -- parameter of mode OUT. 594 595 function Is_Private_Primitive (Prim : Entity_Id) return Boolean; 596 -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram. 597 -- When applied to a primitive subprogram Prim, returns True if Prim is 598 -- declared as a private operation within a package or generic package, 599 -- and returns False otherwise. 600 601 function Is_Valid_Constraint_Kind 602 (T_Kind : Type_Kind; 603 Constraint_Kind : Node_Kind) return Boolean; 604 -- Returns True if it is legal to apply the given kind of constraint to the 605 -- given kind of type (index constraint to an array type, for example). 606 607 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id); 608 -- Create new modular type. Verify that modulus is in bounds 609 610 procedure New_Concatenation_Op (Typ : Entity_Id); 611 -- Create an abbreviated declaration for an operator in order to 612 -- materialize concatenation on array types. 613 614 procedure Ordinary_Fixed_Point_Type_Declaration 615 (T : Entity_Id; 616 Def : Node_Id); 617 -- Create a new ordinary fixed point type, and apply the constraint to 618 -- obtain subtype of it. 619 620 procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id); 621 -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that 622 -- In_Default_Expr can be properly adjusted. 623 624 procedure Prepare_Private_Subtype_Completion 625 (Id : Entity_Id; 626 Related_Nod : Node_Id); 627 -- Id is a subtype of some private type. Creates the full declaration 628 -- associated with Id whenever possible, i.e. when the full declaration 629 -- of the base type is already known. Records each subtype into 630 -- Private_Dependents of the base type. 631 632 procedure Process_Incomplete_Dependents 633 (N : Node_Id; 634 Full_T : Entity_Id; 635 Inc_T : Entity_Id); 636 -- Process all entities that depend on an incomplete type. There include 637 -- subtypes, subprogram types that mention the incomplete type in their 638 -- profiles, and subprogram with access parameters that designate the 639 -- incomplete type. 640 641 -- Inc_T is the defining identifier of an incomplete type declaration, its 642 -- Ekind is E_Incomplete_Type. 643 -- 644 -- N is the corresponding N_Full_Type_Declaration for Inc_T. 645 -- 646 -- Full_T is N's defining identifier. 647 -- 648 -- Subtypes of incomplete types with discriminants are completed when the 649 -- parent type is. This is simpler than private subtypes, because they can 650 -- only appear in the same scope, and there is no need to exchange views. 651 -- Similarly, access_to_subprogram types may have a parameter or a return 652 -- type that is an incomplete type, and that must be replaced with the 653 -- full type. 654 -- 655 -- If the full type is tagged, subprogram with access parameters that 656 -- designated the incomplete may be primitive operations of the full type, 657 -- and have to be processed accordingly. 658 659 procedure Process_Real_Range_Specification (Def : Node_Id); 660 -- Given the type definition for a real type, this procedure processes and 661 -- checks the real range specification of this type definition if one is 662 -- present. If errors are found, error messages are posted, and the 663 -- Real_Range_Specification of Def is reset to Empty. 664 665 procedure Record_Type_Declaration 666 (T : Entity_Id; 667 N : Node_Id; 668 Prev : Entity_Id); 669 -- Process a record type declaration (for both untagged and tagged 670 -- records). Parameters T and N are exactly like in procedure 671 -- Derived_Type_Declaration, except that no flag Is_Completion is needed 672 -- for this routine. If this is the completion of an incomplete type 673 -- declaration, Prev is the entity of the incomplete declaration, used for 674 -- cross-referencing. Otherwise Prev = T. 675 676 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id); 677 -- This routine is used to process the actual record type definition (both 678 -- for untagged and tagged records). Def is a record type definition node. 679 -- This procedure analyzes the components in this record type definition. 680 -- Prev_T is the entity for the enclosing record type. It is provided so 681 -- that its Has_Task flag can be set if any of the component have Has_Task 682 -- set. If the declaration is the completion of an incomplete type 683 -- declaration, Prev_T is the original incomplete type, whose full view is 684 -- the record type. 685 686 procedure Replace_Discriminants (Typ : Entity_Id; Decl : Node_Id); 687 -- Subsidiary to Build_Derived_Record_Type. For untagged record types, we 688 -- first create the list of components for the derived type from that of 689 -- the parent by means of Inherit_Components and then build a copy of the 690 -- declaration tree of the parent with the help of the mapping returned by 691 -- Inherit_Components, which will for example be used to validate record 692 -- representation clauses given for the derived type. If the parent type 693 -- is private and has discriminants, the ancestor discriminants used in the 694 -- inheritance are that of the private declaration, whereas the ancestor 695 -- discriminants present in the declaration tree of the parent are that of 696 -- the full declaration; as a consequence, the remapping done during the 697 -- copy will leave the references to the ancestor discriminants unchanged 698 -- in the declaration tree and they need to be fixed up. If the derived 699 -- type has a known discriminant part, then the remapping done during the 700 -- copy will only create references to the stored discriminants and they 701 -- need to be replaced with references to the non-stored discriminants. 702 703 procedure Set_Fixed_Range 704 (E : Entity_Id; 705 Loc : Source_Ptr; 706 Lo : Ureal; 707 Hi : Ureal); 708 -- Build a range node with the given bounds and set it as the Scalar_Range 709 -- of the given fixed-point type entity. Loc is the source location used 710 -- for the constructed range. See body for further details. 711 712 procedure Set_Scalar_Range_For_Subtype 713 (Def_Id : Entity_Id; 714 R : Node_Id; 715 Subt : Entity_Id); 716 -- This routine is used to set the scalar range field for a subtype given 717 -- Def_Id, the entity for the subtype, and R, the range expression for the 718 -- scalar range. Subt provides the parent subtype to be used to analyze, 719 -- resolve, and check the given range. 720 721 procedure Set_Default_SSO (T : Entity_Id); 722 -- T is the entity for an array or record being declared. This procedure 723 -- sets the flags SSO_Set_Low_By_Default/SSO_Set_High_By_Default according 724 -- to the setting of Opt.Default_SSO. 725 726 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id); 727 -- Create a new signed integer entity, and apply the constraint to obtain 728 -- the required first named subtype of this type. 729 730 procedure Set_Stored_Constraint_From_Discriminant_Constraint 731 (E : Entity_Id); 732 -- E is some record type. This routine computes E's Stored_Constraint 733 -- from its Discriminant_Constraint. 734 735 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id); 736 -- Check that an entity in a list of progenitors is an interface, 737 -- emit error otherwise. 738 739 ----------------------- 740 -- Access_Definition -- 741 ----------------------- 742 743 function Access_Definition 744 (Related_Nod : Node_Id; 745 N : Node_Id) return Entity_Id 746 is 747 Anon_Type : Entity_Id; 748 Anon_Scope : Entity_Id; 749 Desig_Type : Entity_Id; 750 Enclosing_Prot_Type : Entity_Id := Empty; 751 752 begin 753 if Is_Entry (Current_Scope) 754 and then Is_Task_Type (Etype (Scope (Current_Scope))) 755 then 756 Error_Msg_N ("task entries cannot have access parameters", N); 757 return Empty; 758 end if; 759 760 -- Ada 2005: For an object declaration the corresponding anonymous 761 -- type is declared in the current scope. 762 763 -- If the access definition is the return type of another access to 764 -- function, scope is the current one, because it is the one of the 765 -- current type declaration, except for the pathological case below. 766 767 if Nkind (Related_Nod) in 768 N_Object_Declaration | N_Access_Function_Definition 769 then 770 Anon_Scope := Current_Scope; 771 772 -- A pathological case: function returning access functions that 773 -- return access functions, etc. Each anonymous access type created 774 -- is in the enclosing scope of the outermost function. 775 776 declare 777 Par : Node_Id; 778 779 begin 780 Par := Related_Nod; 781 while Nkind (Par) in 782 N_Access_Function_Definition | N_Access_Definition 783 loop 784 Par := Parent (Par); 785 end loop; 786 787 if Nkind (Par) = N_Function_Specification then 788 Anon_Scope := Scope (Defining_Entity (Par)); 789 end if; 790 end; 791 792 -- For the anonymous function result case, retrieve the scope of the 793 -- function specification's associated entity rather than using the 794 -- current scope. The current scope will be the function itself if the 795 -- formal part is currently being analyzed, but will be the parent scope 796 -- in the case of a parameterless function, and we always want to use 797 -- the function's parent scope. Finally, if the function is a child 798 -- unit, we must traverse the tree to retrieve the proper entity. 799 800 elsif Nkind (Related_Nod) = N_Function_Specification 801 and then Nkind (Parent (N)) /= N_Parameter_Specification 802 then 803 -- If the current scope is a protected type, the anonymous access 804 -- is associated with one of the protected operations, and must 805 -- be available in the scope that encloses the protected declaration. 806 -- Otherwise the type is in the scope enclosing the subprogram. 807 808 -- If the function has formals, the return type of a subprogram 809 -- declaration is analyzed in the scope of the subprogram (see 810 -- Process_Formals) and thus the protected type, if present, is 811 -- the scope of the current function scope. 812 813 if Ekind (Current_Scope) = E_Protected_Type then 814 Enclosing_Prot_Type := Current_Scope; 815 816 elsif Ekind (Current_Scope) = E_Function 817 and then Ekind (Scope (Current_Scope)) = E_Protected_Type 818 then 819 Enclosing_Prot_Type := Scope (Current_Scope); 820 end if; 821 822 if Present (Enclosing_Prot_Type) then 823 Anon_Scope := Scope (Enclosing_Prot_Type); 824 825 else 826 Anon_Scope := Scope (Defining_Entity (Related_Nod)); 827 end if; 828 829 -- For an access type definition, if the current scope is a child 830 -- unit it is the scope of the type. 831 832 elsif Is_Compilation_Unit (Current_Scope) then 833 Anon_Scope := Current_Scope; 834 835 -- For access formals, access components, and access discriminants, the 836 -- scope is that of the enclosing declaration, 837 838 else 839 Anon_Scope := Scope (Current_Scope); 840 end if; 841 842 Anon_Type := 843 Create_Itype 844 (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); 845 846 if All_Present (N) 847 and then Ada_Version >= Ada_2005 848 then 849 Error_Msg_N ("ALL not permitted for anonymous access types", N); 850 end if; 851 852 -- Ada 2005 (AI-254): In case of anonymous access to subprograms call 853 -- the corresponding semantic routine 854 855 if Present (Access_To_Subprogram_Definition (N)) then 856 Access_Subprogram_Declaration 857 (T_Name => Anon_Type, 858 T_Def => Access_To_Subprogram_Definition (N)); 859 860 if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then 861 Mutate_Ekind 862 (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type); 863 else 864 Mutate_Ekind (Anon_Type, E_Anonymous_Access_Subprogram_Type); 865 end if; 866 867 Set_Can_Use_Internal_Rep 868 (Anon_Type, not Always_Compatible_Rep_On_Target); 869 870 -- If the anonymous access is associated with a protected operation, 871 -- create a reference to it after the enclosing protected definition 872 -- because the itype will be used in the subsequent bodies. 873 874 -- If the anonymous access itself is protected, a full type 875 -- declaratiton will be created for it, so that the equivalent 876 -- record type can be constructed. For further details, see 877 -- Replace_Anonymous_Access_To_Protected-Subprogram. 878 879 if Ekind (Current_Scope) = E_Protected_Type 880 and then not Protected_Present (Access_To_Subprogram_Definition (N)) 881 then 882 Build_Itype_Reference (Anon_Type, Parent (Current_Scope)); 883 end if; 884 885 return Anon_Type; 886 end if; 887 888 Find_Type (Subtype_Mark (N)); 889 Desig_Type := Entity (Subtype_Mark (N)); 890 891 Set_Directly_Designated_Type (Anon_Type, Desig_Type); 892 Set_Etype (Anon_Type, Anon_Type); 893 894 -- Make sure the anonymous access type has size and alignment fields 895 -- set, as required by gigi. This is necessary in the case of the 896 -- Task_Body_Procedure. 897 898 if not Has_Private_Component (Desig_Type) then 899 Layout_Type (Anon_Type); 900 end if; 901 902 -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs 903 -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if 904 -- the null value is allowed. In Ada 95 the null value is never allowed. 905 906 if Ada_Version >= Ada_2005 then 907 Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N)); 908 else 909 Set_Can_Never_Be_Null (Anon_Type, True); 910 end if; 911 912 -- The anonymous access type is as public as the discriminated type or 913 -- subprogram that defines it. It is imported (for back-end purposes) 914 -- if the designated type is. 915 916 Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type))); 917 918 -- Ada 2005 (AI-231): Propagate the access-constant attribute 919 920 Set_Is_Access_Constant (Anon_Type, Constant_Present (N)); 921 922 -- The context is either a subprogram declaration, object declaration, 923 -- or an access discriminant, in a private or a full type declaration. 924 -- In the case of a subprogram, if the designated type is incomplete, 925 -- the operation will be a primitive operation of the full type, to be 926 -- updated subsequently. If the type is imported through a limited_with 927 -- clause, the subprogram is not a primitive operation of the type 928 -- (which is declared elsewhere in some other scope). 929 930 if Ekind (Desig_Type) = E_Incomplete_Type 931 and then not From_Limited_With (Desig_Type) 932 and then Is_Overloadable (Current_Scope) 933 then 934 Append_Elmt (Current_Scope, Private_Dependents (Desig_Type)); 935 Set_Has_Delayed_Freeze (Current_Scope); 936 end if; 937 938 -- If the designated type is limited and class-wide, the object might 939 -- contain tasks, so we create a Master entity for the declaration. This 940 -- must be done before expansion of the full declaration, because the 941 -- declaration may include an expression that is an allocator, whose 942 -- expansion needs the proper Master for the created tasks. 943 944 if Expander_Active 945 and then Nkind (Related_Nod) = N_Object_Declaration 946 then 947 if Is_Limited_Record (Desig_Type) 948 and then Is_Class_Wide_Type (Desig_Type) 949 then 950 Build_Class_Wide_Master (Anon_Type); 951 952 -- Similarly, if the type is an anonymous access that designates 953 -- tasks, create a master entity for it in the current context. 954 955 elsif Has_Task (Desig_Type) 956 and then Comes_From_Source (Related_Nod) 957 then 958 Build_Master_Entity (Defining_Identifier (Related_Nod)); 959 Build_Master_Renaming (Anon_Type); 960 end if; 961 end if; 962 963 -- For a private component of a protected type, it is imperative that 964 -- the back-end elaborate the type immediately after the protected 965 -- declaration, because this type will be used in the declarations 966 -- created for the component within each protected body, so we must 967 -- create an itype reference for it now. 968 969 if Nkind (Parent (Related_Nod)) = N_Protected_Definition then 970 Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod))); 971 972 -- Similarly, if the access definition is the return result of a 973 -- function, create an itype reference for it because it will be used 974 -- within the function body. For a regular function that is not a 975 -- compilation unit, insert reference after the declaration. For a 976 -- protected operation, insert it after the enclosing protected type 977 -- declaration. In either case, do not create a reference for a type 978 -- obtained through a limited_with clause, because this would introduce 979 -- semantic dependencies. 980 981 -- Similarly, do not create a reference if the designated type is a 982 -- generic formal, because no use of it will reach the backend. 983 984 elsif Nkind (Related_Nod) = N_Function_Specification 985 and then not From_Limited_With (Desig_Type) 986 and then not Is_Generic_Type (Desig_Type) 987 then 988 if Present (Enclosing_Prot_Type) then 989 Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type)); 990 991 elsif Is_List_Member (Parent (Related_Nod)) 992 and then Nkind (Parent (N)) /= N_Parameter_Specification 993 then 994 Build_Itype_Reference (Anon_Type, Parent (Related_Nod)); 995 end if; 996 997 -- Finally, create an itype reference for an object declaration of an 998 -- anonymous access type. This is strictly necessary only for deferred 999 -- constants, but in any case will avoid out-of-scope problems in the 1000 -- back-end. 1001 1002 elsif Nkind (Related_Nod) = N_Object_Declaration then 1003 Build_Itype_Reference (Anon_Type, Related_Nod); 1004 end if; 1005 1006 return Anon_Type; 1007 end Access_Definition; 1008 1009 ----------------------------------- 1010 -- Access_Subprogram_Declaration -- 1011 ----------------------------------- 1012 1013 procedure Access_Subprogram_Declaration 1014 (T_Name : Entity_Id; 1015 T_Def : Node_Id) 1016 is 1017 procedure Check_For_Premature_Usage (Def : Node_Id); 1018 -- Check that type T_Name is not used, directly or recursively, as a 1019 -- parameter or a return type in Def. Def is either a subtype, an 1020 -- access_definition, or an access_to_subprogram_definition. 1021 1022 ------------------------------- 1023 -- Check_For_Premature_Usage -- 1024 ------------------------------- 1025 1026 procedure Check_For_Premature_Usage (Def : Node_Id) is 1027 Param : Node_Id; 1028 1029 begin 1030 -- Check for a subtype mark 1031 1032 if Nkind (Def) in N_Has_Etype then 1033 if Etype (Def) = T_Name then 1034 Error_Msg_N 1035 ("type& cannot be used before the end of its declaration", 1036 Def); 1037 end if; 1038 1039 -- If this is not a subtype, then this is an access_definition 1040 1041 elsif Nkind (Def) = N_Access_Definition then 1042 if Present (Access_To_Subprogram_Definition (Def)) then 1043 Check_For_Premature_Usage 1044 (Access_To_Subprogram_Definition (Def)); 1045 else 1046 Check_For_Premature_Usage (Subtype_Mark (Def)); 1047 end if; 1048 1049 -- The only cases left are N_Access_Function_Definition and 1050 -- N_Access_Procedure_Definition. 1051 1052 else 1053 if Present (Parameter_Specifications (Def)) then 1054 Param := First (Parameter_Specifications (Def)); 1055 while Present (Param) loop 1056 Check_For_Premature_Usage (Parameter_Type (Param)); 1057 Next (Param); 1058 end loop; 1059 end if; 1060 1061 if Nkind (Def) = N_Access_Function_Definition then 1062 Check_For_Premature_Usage (Result_Definition (Def)); 1063 end if; 1064 end if; 1065 end Check_For_Premature_Usage; 1066 1067 -- Local variables 1068 1069 Formals : constant List_Id := Parameter_Specifications (T_Def); 1070 Formal : Entity_Id; 1071 D_Ityp : Node_Id; 1072 Desig_Type : constant Entity_Id := 1073 Create_Itype (E_Subprogram_Type, Parent (T_Def)); 1074 1075 -- Start of processing for Access_Subprogram_Declaration 1076 1077 begin 1078 -- Associate the Itype node with the inner full-type declaration or 1079 -- subprogram spec or entry body. This is required to handle nested 1080 -- anonymous declarations. For example: 1081 1082 -- procedure P 1083 -- (X : access procedure 1084 -- (Y : access procedure 1085 -- (Z : access T))) 1086 1087 D_Ityp := Associated_Node_For_Itype (Desig_Type); 1088 while Nkind (D_Ityp) not in N_Full_Type_Declaration 1089 | N_Private_Type_Declaration 1090 | N_Private_Extension_Declaration 1091 | N_Procedure_Specification 1092 | N_Function_Specification 1093 | N_Entry_Body 1094 | N_Object_Declaration 1095 | N_Object_Renaming_Declaration 1096 | N_Formal_Object_Declaration 1097 | N_Formal_Type_Declaration 1098 | N_Task_Type_Declaration 1099 | N_Protected_Type_Declaration 1100 loop 1101 D_Ityp := Parent (D_Ityp); 1102 pragma Assert (D_Ityp /= Empty); 1103 end loop; 1104 1105 Set_Associated_Node_For_Itype (Desig_Type, D_Ityp); 1106 1107 if Nkind (D_Ityp) in N_Procedure_Specification | N_Function_Specification 1108 then 1109 Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp))); 1110 1111 elsif Nkind (D_Ityp) in N_Full_Type_Declaration 1112 | N_Object_Declaration 1113 | N_Object_Renaming_Declaration 1114 | N_Formal_Type_Declaration 1115 then 1116 Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp))); 1117 end if; 1118 1119 if Nkind (T_Def) = N_Access_Function_Definition then 1120 if Nkind (Result_Definition (T_Def)) = N_Access_Definition then 1121 declare 1122 Acc : constant Node_Id := Result_Definition (T_Def); 1123 1124 begin 1125 if Present (Access_To_Subprogram_Definition (Acc)) 1126 and then 1127 Protected_Present (Access_To_Subprogram_Definition (Acc)) 1128 then 1129 Set_Etype 1130 (Desig_Type, 1131 Replace_Anonymous_Access_To_Protected_Subprogram 1132 (T_Def)); 1133 1134 else 1135 Set_Etype 1136 (Desig_Type, 1137 Access_Definition (T_Def, Result_Definition (T_Def))); 1138 end if; 1139 end; 1140 1141 else 1142 Analyze (Result_Definition (T_Def)); 1143 1144 declare 1145 Typ : constant Entity_Id := Entity (Result_Definition (T_Def)); 1146 1147 begin 1148 -- If a null exclusion is imposed on the result type, then 1149 -- create a null-excluding itype (an access subtype) and use 1150 -- it as the function's Etype. 1151 1152 if Is_Access_Type (Typ) 1153 and then Null_Exclusion_In_Return_Present (T_Def) 1154 then 1155 Set_Etype (Desig_Type, 1156 Create_Null_Excluding_Itype 1157 (T => Typ, 1158 Related_Nod => T_Def, 1159 Scope_Id => Current_Scope)); 1160 1161 else 1162 if From_Limited_With (Typ) then 1163 1164 -- AI05-151: Incomplete types are allowed in all basic 1165 -- declarations, including access to subprograms. 1166 1167 if Ada_Version >= Ada_2012 then 1168 null; 1169 1170 else 1171 Error_Msg_NE 1172 ("illegal use of incomplete type&", 1173 Result_Definition (T_Def), Typ); 1174 end if; 1175 1176 elsif Ekind (Current_Scope) = E_Package 1177 and then In_Private_Part (Current_Scope) 1178 then 1179 if Ekind (Typ) = E_Incomplete_Type then 1180 Append_Elmt (Desig_Type, Private_Dependents (Typ)); 1181 1182 elsif Is_Class_Wide_Type (Typ) 1183 and then Ekind (Etype (Typ)) = E_Incomplete_Type 1184 then 1185 Append_Elmt 1186 (Desig_Type, Private_Dependents (Etype (Typ))); 1187 end if; 1188 end if; 1189 1190 Set_Etype (Desig_Type, Typ); 1191 end if; 1192 end; 1193 end if; 1194 1195 if not Is_Type (Etype (Desig_Type)) then 1196 Error_Msg_N 1197 ("expect type in function specification", 1198 Result_Definition (T_Def)); 1199 end if; 1200 1201 else 1202 Set_Etype (Desig_Type, Standard_Void_Type); 1203 end if; 1204 1205 if Present (Formals) then 1206 Push_Scope (Desig_Type); 1207 1208 -- Some special tests here. These special tests can be removed 1209 -- if and when Itypes always have proper parent pointers to their 1210 -- declarations??? 1211 1212 -- Special test 1) Link defining_identifier of formals. Required by 1213 -- First_Formal to provide its functionality. 1214 1215 declare 1216 F : Node_Id; 1217 1218 begin 1219 F := First (Formals); 1220 1221 while Present (F) loop 1222 if No (Parent (Defining_Identifier (F))) then 1223 Set_Parent (Defining_Identifier (F), F); 1224 end if; 1225 1226 Next (F); 1227 end loop; 1228 end; 1229 1230 Process_Formals (Formals, Parent (T_Def)); 1231 1232 -- Special test 2) End_Scope requires that the parent pointer be set 1233 -- to something reasonable, but Itypes don't have parent pointers. So 1234 -- we set it and then unset it ??? 1235 1236 Set_Parent (Desig_Type, T_Name); 1237 End_Scope; 1238 Set_Parent (Desig_Type, Empty); 1239 end if; 1240 1241 -- Check for premature usage of the type being defined 1242 1243 Check_For_Premature_Usage (T_Def); 1244 1245 -- The return type and/or any parameter type may be incomplete. Mark the 1246 -- subprogram_type as depending on the incomplete type, so that it can 1247 -- be updated when the full type declaration is seen. This only applies 1248 -- to incomplete types declared in some enclosing scope, not to limited 1249 -- views from other packages. 1250 1251 -- Prior to Ada 2012, access to functions can only have in_parameters. 1252 1253 if Present (Formals) then 1254 Formal := First_Formal (Desig_Type); 1255 while Present (Formal) loop 1256 if Ekind (Formal) /= E_In_Parameter 1257 and then Nkind (T_Def) = N_Access_Function_Definition 1258 and then Ada_Version < Ada_2012 1259 then 1260 Error_Msg_N ("functions can only have IN parameters", Formal); 1261 end if; 1262 1263 if Ekind (Etype (Formal)) = E_Incomplete_Type 1264 and then In_Open_Scopes (Scope (Etype (Formal))) 1265 then 1266 Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal))); 1267 Set_Has_Delayed_Freeze (Desig_Type); 1268 end if; 1269 1270 Next_Formal (Formal); 1271 end loop; 1272 end if; 1273 1274 -- Check whether an indirect call without actuals may be possible. This 1275 -- is used when resolving calls whose result is then indexed. 1276 1277 May_Need_Actuals (Desig_Type); 1278 1279 -- If the return type is incomplete, this is legal as long as the type 1280 -- is declared in the current scope and will be completed in it (rather 1281 -- than being part of limited view). 1282 1283 if Ekind (Etype (Desig_Type)) = E_Incomplete_Type 1284 and then not Has_Delayed_Freeze (Desig_Type) 1285 and then In_Open_Scopes (Scope (Etype (Desig_Type))) 1286 then 1287 Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type))); 1288 Set_Has_Delayed_Freeze (Desig_Type); 1289 end if; 1290 1291 Check_Delayed_Subprogram (Desig_Type); 1292 1293 if Protected_Present (T_Def) then 1294 Mutate_Ekind (T_Name, E_Access_Protected_Subprogram_Type); 1295 Set_Convention (Desig_Type, Convention_Protected); 1296 else 1297 Mutate_Ekind (T_Name, E_Access_Subprogram_Type); 1298 end if; 1299 1300 Set_Can_Use_Internal_Rep (T_Name, 1301 not Always_Compatible_Rep_On_Target); 1302 Set_Etype (T_Name, T_Name); 1303 Reinit_Size_Align (T_Name); 1304 Set_Directly_Designated_Type (T_Name, Desig_Type); 1305 1306 -- If the access_to_subprogram is not declared at the library level, 1307 -- it can only point to subprograms that are at the same or deeper 1308 -- accessibility level. The corresponding subprogram type might 1309 -- require an activation record when compiling for C. 1310 1311 Set_Needs_Activation_Record (Desig_Type, 1312 not Is_Library_Level_Entity (T_Name)); 1313 1314 Generate_Reference_To_Formals (T_Name); 1315 1316 -- Ada 2005 (AI-231): Propagate the null-excluding attribute 1317 1318 Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def)); 1319 1320 Check_Restriction (No_Access_Subprograms, T_Def); 1321 1322 Create_Extra_Formals (Desig_Type); 1323 end Access_Subprogram_Declaration; 1324 1325 ---------------------------- 1326 -- Access_Type_Declaration -- 1327 ---------------------------- 1328 1329 procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is 1330 1331 procedure Setup_Access_Type (Desig_Typ : Entity_Id); 1332 -- After type declaration is analysed with T being an incomplete type, 1333 -- this routine will mutate the kind of T to the appropriate access type 1334 -- and set its directly designated type to Desig_Typ. 1335 1336 ----------------------- 1337 -- Setup_Access_Type -- 1338 ----------------------- 1339 1340 procedure Setup_Access_Type (Desig_Typ : Entity_Id) is 1341 begin 1342 if All_Present (Def) or else Constant_Present (Def) then 1343 Mutate_Ekind (T, E_General_Access_Type); 1344 else 1345 Mutate_Ekind (T, E_Access_Type); 1346 end if; 1347 1348 Set_Directly_Designated_Type (T, Desig_Typ); 1349 end Setup_Access_Type; 1350 1351 -- Local variables 1352 1353 P : constant Node_Id := Parent (Def); 1354 S : constant Node_Id := Subtype_Indication (Def); 1355 1356 Full_Desig : Entity_Id; 1357 1358 -- Start of processing for Access_Type_Declaration 1359 1360 begin 1361 -- Check for permissible use of incomplete type 1362 1363 if Nkind (S) /= N_Subtype_Indication then 1364 1365 Analyze (S); 1366 1367 if Nkind (S) in N_Has_Entity 1368 and then Present (Entity (S)) 1369 and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type 1370 then 1371 Setup_Access_Type (Desig_Typ => Entity (S)); 1372 1373 -- If the designated type is a limited view, we cannot tell if 1374 -- the full view contains tasks, and there is no way to handle 1375 -- that full view in a client. We create a master entity for the 1376 -- scope, which will be used when a client determines that one 1377 -- is needed. 1378 1379 if From_Limited_With (Entity (S)) 1380 and then not Is_Class_Wide_Type (Entity (S)) 1381 then 1382 Build_Master_Entity (T); 1383 Build_Master_Renaming (T); 1384 end if; 1385 1386 else 1387 Setup_Access_Type (Desig_Typ => Process_Subtype (S, P, T, 'P')); 1388 end if; 1389 1390 -- If the access definition is of the form: ACCESS NOT NULL .. 1391 -- the subtype indication must be of an access type. Create 1392 -- a null-excluding subtype of it. 1393 1394 if Null_Excluding_Subtype (Def) then 1395 if not Is_Access_Type (Entity (S)) then 1396 Error_Msg_N ("null exclusion must apply to access type", Def); 1397 1398 else 1399 declare 1400 Loc : constant Source_Ptr := Sloc (S); 1401 Decl : Node_Id; 1402 Nam : constant Entity_Id := Make_Temporary (Loc, 'S'); 1403 1404 begin 1405 Decl := 1406 Make_Subtype_Declaration (Loc, 1407 Defining_Identifier => Nam, 1408 Subtype_Indication => 1409 New_Occurrence_Of (Entity (S), Loc)); 1410 Set_Null_Exclusion_Present (Decl); 1411 Insert_Before (Parent (Def), Decl); 1412 Analyze (Decl); 1413 Set_Entity (S, Nam); 1414 end; 1415 end if; 1416 end if; 1417 1418 else 1419 Setup_Access_Type (Desig_Typ => Process_Subtype (S, P, T, 'P')); 1420 end if; 1421 1422 if not Error_Posted (T) then 1423 Full_Desig := Designated_Type (T); 1424 1425 if Base_Type (Full_Desig) = T then 1426 Error_Msg_N ("access type cannot designate itself", S); 1427 1428 -- In Ada 2005, the type may have a limited view through some unit in 1429 -- its own context, allowing the following circularity that cannot be 1430 -- detected earlier. 1431 1432 elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T 1433 then 1434 Error_Msg_N 1435 ("access type cannot designate its own class-wide type", S); 1436 1437 -- Clean up indication of tagged status to prevent cascaded errors 1438 1439 Set_Is_Tagged_Type (T, False); 1440 end if; 1441 1442 Set_Etype (T, T); 1443 1444 -- For SPARK, check that the designated type is compatible with 1445 -- respect to volatility with the access type. 1446 1447 if SPARK_Mode /= Off 1448 and then Comes_From_Source (T) 1449 then 1450 -- ??? UNIMPLEMENTED 1451 -- In the case where the designated type is incomplete at this 1452 -- point, performing this check here is harmless but the check 1453 -- will need to be repeated when the designated type is complete. 1454 1455 -- The preceding call to Comes_From_Source is needed because the 1456 -- FE sometimes introduces implicitly declared access types. See, 1457 -- for example, the expansion of nested_po.ads in OA28-015. 1458 1459 Check_Volatility_Compatibility 1460 (Full_Desig, T, "designated type", "access type", 1461 Srcpos_Bearer => T); 1462 end if; 1463 end if; 1464 1465 -- If the type has appeared already in a with_type clause, it is frozen 1466 -- and the pointer size is already set. Else, initialize. 1467 1468 if not From_Limited_With (T) then 1469 Reinit_Size_Align (T); 1470 end if; 1471 1472 -- Note that Has_Task is always false, since the access type itself 1473 -- is not a task type. See Einfo for more description on this point. 1474 -- Exactly the same consideration applies to Has_Controlled_Component 1475 -- and to Has_Protected. 1476 1477 Set_Has_Task (T, False); 1478 Set_Has_Protected (T, False); 1479 Set_Has_Timing_Event (T, False); 1480 Set_Has_Controlled_Component (T, False); 1481 1482 -- Initialize field Finalization_Master explicitly to Empty, to avoid 1483 -- problems where an incomplete view of this entity has been previously 1484 -- established by a limited with and an overlaid version of this field 1485 -- (Stored_Constraint) was initialized for the incomplete view. 1486 1487 -- This reset is performed in most cases except where the access type 1488 -- has been created for the purposes of allocating or deallocating a 1489 -- build-in-place object. Such access types have explicitly set pools 1490 -- and finalization masters. 1491 1492 if No (Associated_Storage_Pool (T)) then 1493 Set_Finalization_Master (T, Empty); 1494 end if; 1495 1496 -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant 1497 -- attributes 1498 1499 Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def)); 1500 Set_Is_Access_Constant (T, Constant_Present (Def)); 1501 end Access_Type_Declaration; 1502 1503 ---------------------------------- 1504 -- Add_Interface_Tag_Components -- 1505 ---------------------------------- 1506 1507 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is 1508 Loc : constant Source_Ptr := Sloc (N); 1509 L : List_Id; 1510 Last_Tag : Node_Id; 1511 1512 procedure Add_Tag (Iface : Entity_Id); 1513 -- Add tag for one of the progenitor interfaces 1514 1515 ------------- 1516 -- Add_Tag -- 1517 ------------- 1518 1519 procedure Add_Tag (Iface : Entity_Id) is 1520 Decl : Node_Id; 1521 Def : Node_Id; 1522 Tag : Entity_Id; 1523 Offset : Entity_Id; 1524 1525 begin 1526 pragma Assert (Is_Tagged_Type (Iface) and then Is_Interface (Iface)); 1527 1528 -- This is a reasonable place to propagate predicates 1529 1530 if Has_Predicates (Iface) then 1531 Set_Has_Predicates (Typ); 1532 end if; 1533 1534 Def := 1535 Make_Component_Definition (Loc, 1536 Aliased_Present => True, 1537 Subtype_Indication => 1538 New_Occurrence_Of (RTE (RE_Interface_Tag), Loc)); 1539 1540 Tag := Make_Temporary (Loc, 'V'); 1541 1542 Decl := 1543 Make_Component_Declaration (Loc, 1544 Defining_Identifier => Tag, 1545 Component_Definition => Def); 1546 1547 Analyze_Component_Declaration (Decl); 1548 1549 Set_Analyzed (Decl); 1550 Mutate_Ekind (Tag, E_Component); 1551 Set_Is_Tag (Tag); 1552 Set_Is_Aliased (Tag); 1553 Set_Is_Independent (Tag); 1554 Set_Related_Type (Tag, Iface); 1555 Reinit_Component_Location (Tag); 1556 1557 pragma Assert (Is_Frozen (Iface)); 1558 1559 Set_DT_Entry_Count (Tag, 1560 DT_Entry_Count (First_Entity (Iface))); 1561 1562 if No (Last_Tag) then 1563 Prepend (Decl, L); 1564 else 1565 Insert_After (Last_Tag, Decl); 1566 end if; 1567 1568 Last_Tag := Decl; 1569 1570 -- If the ancestor has discriminants we need to give special support 1571 -- to store the offset_to_top value of the secondary dispatch tables. 1572 -- For this purpose we add a supplementary component just after the 1573 -- field that contains the tag associated with each secondary DT. 1574 1575 if Typ /= Etype (Typ) and then Has_Discriminants (Etype (Typ)) then 1576 Def := 1577 Make_Component_Definition (Loc, 1578 Subtype_Indication => 1579 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); 1580 1581 Offset := Make_Temporary (Loc, 'V'); 1582 1583 Decl := 1584 Make_Component_Declaration (Loc, 1585 Defining_Identifier => Offset, 1586 Component_Definition => Def); 1587 1588 Analyze_Component_Declaration (Decl); 1589 1590 Set_Analyzed (Decl); 1591 Mutate_Ekind (Offset, E_Component); 1592 Set_Is_Aliased (Offset); 1593 Set_Is_Independent (Offset); 1594 Set_Related_Type (Offset, Iface); 1595 Reinit_Component_Location (Offset); 1596 Insert_After (Last_Tag, Decl); 1597 Last_Tag := Decl; 1598 end if; 1599 end Add_Tag; 1600 1601 -- Local variables 1602 1603 Elmt : Elmt_Id; 1604 Ext : Node_Id; 1605 Comp : Node_Id; 1606 1607 -- Start of processing for Add_Interface_Tag_Components 1608 1609 begin 1610 if not RTE_Available (RE_Interface_Tag) then 1611 Error_Msg_N 1612 ("(Ada 2005) interface types not supported by this run-time!", N); 1613 return; 1614 end if; 1615 1616 if Ekind (Typ) /= E_Record_Type 1617 or else (Is_Concurrent_Record_Type (Typ) 1618 and then Is_Empty_List (Abstract_Interface_List (Typ))) 1619 or else (not Is_Concurrent_Record_Type (Typ) 1620 and then No (Interfaces (Typ)) 1621 and then Is_Empty_Elmt_List (Interfaces (Typ))) 1622 then 1623 return; 1624 end if; 1625 1626 -- Find the current last tag 1627 1628 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 1629 Ext := Record_Extension_Part (Type_Definition (N)); 1630 else 1631 pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition); 1632 Ext := Type_Definition (N); 1633 end if; 1634 1635 Last_Tag := Empty; 1636 1637 if not (Present (Component_List (Ext))) then 1638 Set_Null_Present (Ext, False); 1639 L := New_List; 1640 Set_Component_List (Ext, 1641 Make_Component_List (Loc, 1642 Component_Items => L, 1643 Null_Present => False)); 1644 else 1645 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 1646 L := Component_Items 1647 (Component_List 1648 (Record_Extension_Part 1649 (Type_Definition (N)))); 1650 else 1651 L := Component_Items 1652 (Component_List 1653 (Type_Definition (N))); 1654 end if; 1655 1656 -- Find the last tag component 1657 1658 Comp := First (L); 1659 while Present (Comp) loop 1660 if Nkind (Comp) = N_Component_Declaration 1661 and then Is_Tag (Defining_Identifier (Comp)) 1662 then 1663 Last_Tag := Comp; 1664 end if; 1665 1666 Next (Comp); 1667 end loop; 1668 end if; 1669 1670 -- At this point L references the list of components and Last_Tag 1671 -- references the current last tag (if any). Now we add the tag 1672 -- corresponding with all the interfaces that are not implemented 1673 -- by the parent. 1674 1675 if Present (Interfaces (Typ)) then 1676 Elmt := First_Elmt (Interfaces (Typ)); 1677 while Present (Elmt) loop 1678 Add_Tag (Node (Elmt)); 1679 Next_Elmt (Elmt); 1680 end loop; 1681 end if; 1682 end Add_Interface_Tag_Components; 1683 1684 ------------------------------------- 1685 -- Add_Internal_Interface_Entities -- 1686 ------------------------------------- 1687 1688 procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is 1689 Elmt : Elmt_Id; 1690 Iface : Entity_Id; 1691 Iface_Elmt : Elmt_Id; 1692 Iface_Prim : Entity_Id; 1693 Ifaces_List : Elist_Id; 1694 New_Subp : Entity_Id := Empty; 1695 Prim : Entity_Id; 1696 Restore_Scope : Boolean := False; 1697 1698 begin 1699 pragma Assert (Ada_Version >= Ada_2005 1700 and then Is_Record_Type (Tagged_Type) 1701 and then Is_Tagged_Type (Tagged_Type) 1702 and then Has_Interfaces (Tagged_Type) 1703 and then not Is_Interface (Tagged_Type)); 1704 1705 -- Ensure that the internal entities are added to the scope of the type 1706 1707 if Scope (Tagged_Type) /= Current_Scope then 1708 Push_Scope (Scope (Tagged_Type)); 1709 Restore_Scope := True; 1710 end if; 1711 1712 Collect_Interfaces (Tagged_Type, Ifaces_List); 1713 1714 Iface_Elmt := First_Elmt (Ifaces_List); 1715 while Present (Iface_Elmt) loop 1716 Iface := Node (Iface_Elmt); 1717 1718 -- Originally we excluded here from this processing interfaces that 1719 -- are parents of Tagged_Type because their primitives are located 1720 -- in the primary dispatch table (and hence no auxiliary internal 1721 -- entities are required to handle secondary dispatch tables in such 1722 -- case). However, these auxiliary entities are also required to 1723 -- handle derivations of interfaces in formals of generics (see 1724 -- Derive_Subprograms). 1725 1726 Elmt := First_Elmt (Primitive_Operations (Iface)); 1727 while Present (Elmt) loop 1728 Iface_Prim := Node (Elmt); 1729 1730 if not Is_Predefined_Dispatching_Operation (Iface_Prim) then 1731 Prim := 1732 Find_Primitive_Covering_Interface 1733 (Tagged_Type => Tagged_Type, 1734 Iface_Prim => Iface_Prim); 1735 1736 if No (Prim) and then Serious_Errors_Detected > 0 then 1737 goto Continue; 1738 end if; 1739 1740 pragma Assert (Present (Prim)); 1741 1742 -- Ada 2012 (AI05-0197): If the name of the covering primitive 1743 -- differs from the name of the interface primitive then it is 1744 -- a private primitive inherited from a parent type. In such 1745 -- case, given that Tagged_Type covers the interface, the 1746 -- inherited private primitive becomes visible. For such 1747 -- purpose we add a new entity that renames the inherited 1748 -- private primitive. 1749 1750 if Chars (Prim) /= Chars (Iface_Prim) then 1751 pragma Assert (Has_Suffix (Prim, 'P')); 1752 Derive_Subprogram 1753 (New_Subp => New_Subp, 1754 Parent_Subp => Iface_Prim, 1755 Derived_Type => Tagged_Type, 1756 Parent_Type => Iface); 1757 Set_Alias (New_Subp, Prim); 1758 Set_Is_Abstract_Subprogram 1759 (New_Subp, Is_Abstract_Subprogram (Prim)); 1760 end if; 1761 1762 Derive_Subprogram 1763 (New_Subp => New_Subp, 1764 Parent_Subp => Iface_Prim, 1765 Derived_Type => Tagged_Type, 1766 Parent_Type => Iface); 1767 1768 declare 1769 Anc : Entity_Id; 1770 begin 1771 if Is_Inherited_Operation (Prim) 1772 and then Present (Alias (Prim)) 1773 then 1774 Anc := Alias (Prim); 1775 else 1776 Anc := Overridden_Operation (Prim); 1777 end if; 1778 1779 -- Apply legality checks in RM 6.1.1 (10-13) concerning 1780 -- nonconforming preconditions in both an ancestor and 1781 -- a progenitor operation. 1782 1783 -- If the operation is a primitive wrapper it is an explicit 1784 -- (overriding) operqtion and all is fine. 1785 1786 if Present (Anc) 1787 and then Has_Non_Trivial_Precondition (Anc) 1788 and then Has_Non_Trivial_Precondition (Iface_Prim) 1789 then 1790 if Is_Abstract_Subprogram (Prim) 1791 or else 1792 (Ekind (Prim) = E_Procedure 1793 and then Nkind (Parent (Prim)) = 1794 N_Procedure_Specification 1795 and then Null_Present (Parent (Prim))) 1796 or else Is_Primitive_Wrapper (Prim) 1797 then 1798 null; 1799 1800 -- The operation is inherited and must be overridden 1801 1802 elsif not Comes_From_Source (Prim) then 1803 Error_Msg_NE 1804 ("&inherits non-conforming preconditions and must " 1805 & "be overridden (RM 6.1.1 (10-16))", 1806 Parent (Tagged_Type), Prim); 1807 end if; 1808 end if; 1809 end; 1810 1811 -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp 1812 -- associated with interface types. These entities are 1813 -- only registered in the list of primitives of its 1814 -- corresponding tagged type because they are only used 1815 -- to fill the contents of the secondary dispatch tables. 1816 -- Therefore they are removed from the homonym chains. 1817 1818 Set_Is_Hidden (New_Subp); 1819 Set_Is_Internal (New_Subp); 1820 Set_Alias (New_Subp, Prim); 1821 Set_Is_Abstract_Subprogram 1822 (New_Subp, Is_Abstract_Subprogram (Prim)); 1823 Set_Interface_Alias (New_Subp, Iface_Prim); 1824 1825 -- If the returned type is an interface then propagate it to 1826 -- the returned type. Needed by the thunk to generate the code 1827 -- which displaces "this" to reference the corresponding 1828 -- secondary dispatch table in the returned object. 1829 1830 if Is_Interface (Etype (Iface_Prim)) then 1831 Set_Etype (New_Subp, Etype (Iface_Prim)); 1832 end if; 1833 1834 -- Internal entities associated with interface types are only 1835 -- registered in the list of primitives of the tagged type. 1836 -- They are only used to fill the contents of the secondary 1837 -- dispatch tables. Therefore they are not needed in the 1838 -- homonym chains. 1839 1840 Remove_Homonym (New_Subp); 1841 1842 -- Hidden entities associated with interfaces must have set 1843 -- the Has_Delay_Freeze attribute to ensure that, in case 1844 -- of locally defined tagged types (or compiling with static 1845 -- dispatch tables generation disabled) the corresponding 1846 -- entry of the secondary dispatch table is filled when such 1847 -- an entity is frozen. 1848 1849 Set_Has_Delayed_Freeze (New_Subp); 1850 end if; 1851 1852 <<Continue>> 1853 Next_Elmt (Elmt); 1854 end loop; 1855 1856 Next_Elmt (Iface_Elmt); 1857 end loop; 1858 1859 if Restore_Scope then 1860 Pop_Scope; 1861 end if; 1862 end Add_Internal_Interface_Entities; 1863 1864 ----------------------------------- 1865 -- Analyze_Component_Declaration -- 1866 ----------------------------------- 1867 1868 procedure Analyze_Component_Declaration (N : Node_Id) is 1869 Loc : constant Source_Ptr := Sloc (Component_Definition (N)); 1870 Id : constant Entity_Id := Defining_Identifier (N); 1871 E : constant Node_Id := Expression (N); 1872 Typ : constant Node_Id := 1873 Subtype_Indication (Component_Definition (N)); 1874 T : Entity_Id; 1875 P : Entity_Id; 1876 1877 function Contains_POC (Constr : Node_Id) return Boolean; 1878 -- Determines whether a constraint uses the discriminant of a record 1879 -- type thus becoming a per-object constraint (POC). 1880 1881 function Is_Known_Limited (Typ : Entity_Id) return Boolean; 1882 -- Typ is the type of the current component, check whether this type is 1883 -- a limited type. Used to validate declaration against that of 1884 -- enclosing record. 1885 1886 ------------------ 1887 -- Contains_POC -- 1888 ------------------ 1889 1890 function Contains_POC (Constr : Node_Id) return Boolean is 1891 begin 1892 -- Prevent cascaded errors 1893 1894 if Error_Posted (Constr) then 1895 return False; 1896 end if; 1897 1898 case Nkind (Constr) is 1899 when N_Attribute_Reference => 1900 return Attribute_Name (Constr) = Name_Access 1901 and then Prefix (Constr) = Scope (Entity (Prefix (Constr))); 1902 1903 when N_Discriminant_Association => 1904 return Denotes_Discriminant (Expression (Constr)); 1905 1906 when N_Identifier => 1907 return Denotes_Discriminant (Constr); 1908 1909 when N_Index_Or_Discriminant_Constraint => 1910 declare 1911 IDC : Node_Id; 1912 1913 begin 1914 IDC := First (Constraints (Constr)); 1915 while Present (IDC) loop 1916 1917 -- One per-object constraint is sufficient 1918 1919 if Contains_POC (IDC) then 1920 return True; 1921 end if; 1922 1923 Next (IDC); 1924 end loop; 1925 1926 return False; 1927 end; 1928 1929 when N_Range => 1930 return Denotes_Discriminant (Low_Bound (Constr)) 1931 or else 1932 Denotes_Discriminant (High_Bound (Constr)); 1933 1934 when N_Range_Constraint => 1935 return Denotes_Discriminant (Range_Expression (Constr)); 1936 1937 when others => 1938 return False; 1939 end case; 1940 end Contains_POC; 1941 1942 ---------------------- 1943 -- Is_Known_Limited -- 1944 ---------------------- 1945 1946 function Is_Known_Limited (Typ : Entity_Id) return Boolean is 1947 P : constant Entity_Id := Etype (Typ); 1948 R : constant Entity_Id := Root_Type (Typ); 1949 1950 begin 1951 if Is_Limited_Record (Typ) then 1952 return True; 1953 1954 -- If the root type is limited (and not a limited interface) so is 1955 -- the current type. 1956 1957 elsif Is_Limited_Record (R) 1958 and then (not Is_Interface (R) or else not Is_Limited_Interface (R)) 1959 then 1960 return True; 1961 1962 -- Else the type may have a limited interface progenitor, but a 1963 -- limited record parent that is not an interface. 1964 1965 elsif R /= P 1966 and then Is_Limited_Record (P) 1967 and then not Is_Interface (P) 1968 then 1969 return True; 1970 1971 else 1972 return False; 1973 end if; 1974 end Is_Known_Limited; 1975 1976 -- Start of processing for Analyze_Component_Declaration 1977 1978 begin 1979 Generate_Definition (Id); 1980 Enter_Name (Id); 1981 1982 if Present (Typ) then 1983 T := Find_Type_Of_Object 1984 (Subtype_Indication (Component_Definition (N)), N); 1985 1986 -- Ada 2005 (AI-230): Access Definition case 1987 1988 else 1989 pragma Assert (Present 1990 (Access_Definition (Component_Definition (N)))); 1991 1992 T := Access_Definition 1993 (Related_Nod => N, 1994 N => Access_Definition (Component_Definition (N))); 1995 Set_Is_Local_Anonymous_Access (T); 1996 1997 -- Ada 2005 (AI-254) 1998 1999 if Present (Access_To_Subprogram_Definition 2000 (Access_Definition (Component_Definition (N)))) 2001 and then Protected_Present (Access_To_Subprogram_Definition 2002 (Access_Definition 2003 (Component_Definition (N)))) 2004 then 2005 T := Replace_Anonymous_Access_To_Protected_Subprogram (N); 2006 end if; 2007 end if; 2008 2009 -- If the subtype is a constrained subtype of the enclosing record, 2010 -- (which must have a partial view) the back-end does not properly 2011 -- handle the recursion. Rewrite the component declaration with an 2012 -- explicit subtype indication, which is acceptable to Gigi. We can copy 2013 -- the tree directly because side effects have already been removed from 2014 -- discriminant constraints. 2015 2016 if Ekind (T) = E_Access_Subtype 2017 and then Is_Entity_Name (Subtype_Indication (Component_Definition (N))) 2018 and then Comes_From_Source (T) 2019 and then Nkind (Parent (T)) = N_Subtype_Declaration 2020 and then Etype (Directly_Designated_Type (T)) = Current_Scope 2021 then 2022 Rewrite 2023 (Subtype_Indication (Component_Definition (N)), 2024 New_Copy_Tree (Subtype_Indication (Parent (T)))); 2025 T := Find_Type_Of_Object 2026 (Subtype_Indication (Component_Definition (N)), N); 2027 end if; 2028 2029 -- If the component declaration includes a default expression, then we 2030 -- check that the component is not of a limited type (RM 3.7(5)), 2031 -- and do the special preanalysis of the expression (see section on 2032 -- "Handling of Default and Per-Object Expressions" in the spec of 2033 -- package Sem). 2034 2035 if Present (E) then 2036 Preanalyze_Default_Expression (E, T); 2037 Check_Initialization (T, E); 2038 2039 if Ada_Version >= Ada_2005 2040 and then Ekind (T) = E_Anonymous_Access_Type 2041 and then Etype (E) /= Any_Type 2042 then 2043 -- Check RM 3.9.2(9): "if the expected type for an expression is 2044 -- an anonymous access-to-specific tagged type, then the object 2045 -- designated by the expression shall not be dynamically tagged 2046 -- unless it is a controlling operand in a call on a dispatching 2047 -- operation" 2048 2049 if Is_Tagged_Type (Directly_Designated_Type (T)) 2050 and then 2051 Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type 2052 and then 2053 Ekind (Directly_Designated_Type (Etype (E))) = 2054 E_Class_Wide_Type 2055 then 2056 Error_Msg_N 2057 ("access to specific tagged type required (RM 3.9.2(9))", E); 2058 end if; 2059 2060 -- (Ada 2005: AI-230): Accessibility check for anonymous 2061 -- components 2062 2063 if Type_Access_Level (Etype (E)) > 2064 Deepest_Type_Access_Level (T) 2065 then 2066 Error_Msg_N 2067 ("expression has deeper access level than component " & 2068 "(RM 3.10.2 (12.2))", E); 2069 end if; 2070 2071 -- The initialization expression is a reference to an access 2072 -- discriminant. The type of the discriminant is always deeper 2073 -- than any access type. 2074 2075 if Ekind (Etype (E)) = E_Anonymous_Access_Type 2076 and then Is_Entity_Name (E) 2077 and then Ekind (Entity (E)) = E_In_Parameter 2078 and then Present (Discriminal_Link (Entity (E))) 2079 then 2080 Error_Msg_N 2081 ("discriminant has deeper accessibility level than target", 2082 E); 2083 end if; 2084 end if; 2085 end if; 2086 2087 -- The parent type may be a private view with unknown discriminants, 2088 -- and thus unconstrained. Regular components must be constrained. 2089 2090 if not Is_Definite_Subtype (T) 2091 and then Chars (Id) /= Name_uParent 2092 then 2093 if Is_Class_Wide_Type (T) then 2094 Error_Msg_N 2095 ("class-wide subtype with unknown discriminants" & 2096 " in component declaration", 2097 Subtype_Indication (Component_Definition (N))); 2098 else 2099 Error_Msg_N 2100 ("unconstrained subtype in component declaration", 2101 Subtype_Indication (Component_Definition (N))); 2102 end if; 2103 2104 -- Components cannot be abstract, except for the special case of 2105 -- the _Parent field (case of extending an abstract tagged type) 2106 2107 elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then 2108 Error_Msg_N ("type of a component cannot be abstract", N); 2109 end if; 2110 2111 Set_Etype (Id, T); 2112 2113 if Aliased_Present (Component_Definition (N)) then 2114 Set_Is_Aliased (Id); 2115 2116 -- AI12-001: All aliased objects are considered to be specified as 2117 -- independently addressable (RM C.6(8.1/4)). 2118 2119 Set_Is_Independent (Id); 2120 end if; 2121 2122 -- The component declaration may have a per-object constraint, set 2123 -- the appropriate flag in the defining identifier of the subtype. 2124 2125 if Present (Subtype_Indication (Component_Definition (N))) then 2126 declare 2127 Sindic : constant Node_Id := 2128 Subtype_Indication (Component_Definition (N)); 2129 begin 2130 if Nkind (Sindic) = N_Subtype_Indication 2131 and then Present (Constraint (Sindic)) 2132 and then Contains_POC (Constraint (Sindic)) 2133 then 2134 Set_Has_Per_Object_Constraint (Id); 2135 end if; 2136 end; 2137 end if; 2138 2139 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry 2140 -- out some static checks. 2141 2142 if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then 2143 Null_Exclusion_Static_Checks (N); 2144 end if; 2145 2146 -- If this component is private (or depends on a private type), flag the 2147 -- record type to indicate that some operations are not available. 2148 2149 P := Private_Component (T); 2150 2151 if Present (P) then 2152 2153 -- Check for circular definitions 2154 2155 if P = Any_Type then 2156 Set_Etype (Id, Any_Type); 2157 2158 -- There is a gap in the visibility of operations only if the 2159 -- component type is not defined in the scope of the record type. 2160 2161 elsif Scope (P) = Scope (Current_Scope) then 2162 null; 2163 2164 elsif Is_Limited_Type (P) then 2165 Set_Is_Limited_Composite (Current_Scope); 2166 2167 else 2168 Set_Is_Private_Composite (Current_Scope); 2169 end if; 2170 end if; 2171 2172 if P /= Any_Type 2173 and then Is_Limited_Type (T) 2174 and then Chars (Id) /= Name_uParent 2175 and then Is_Tagged_Type (Current_Scope) 2176 then 2177 if Is_Derived_Type (Current_Scope) 2178 and then not Is_Known_Limited (Current_Scope) 2179 then 2180 Error_Msg_N 2181 ("extension of nonlimited type cannot have limited components", 2182 N); 2183 2184 if Is_Interface (Root_Type (Current_Scope)) then 2185 Error_Msg_N 2186 ("\limitedness is not inherited from limited interface", N); 2187 Error_Msg_N ("\add LIMITED to type indication", N); 2188 end if; 2189 2190 Explain_Limited_Type (T, N); 2191 Set_Etype (Id, Any_Type); 2192 Set_Is_Limited_Composite (Current_Scope, False); 2193 2194 elsif not Is_Derived_Type (Current_Scope) 2195 and then not Is_Limited_Record (Current_Scope) 2196 and then not Is_Concurrent_Type (Current_Scope) 2197 then 2198 Error_Msg_N 2199 ("nonlimited tagged type cannot have limited components", N); 2200 Explain_Limited_Type (T, N); 2201 Set_Etype (Id, Any_Type); 2202 Set_Is_Limited_Composite (Current_Scope, False); 2203 end if; 2204 end if; 2205 2206 -- If the component is an unconstrained task or protected type with 2207 -- discriminants, the component and the enclosing record are limited 2208 -- and the component is constrained by its default values. Compute 2209 -- its actual subtype, else it may be allocated the maximum size by 2210 -- the backend, and possibly overflow. 2211 2212 if Is_Concurrent_Type (T) 2213 and then not Is_Constrained (T) 2214 and then Has_Discriminants (T) 2215 and then not Has_Discriminants (Current_Scope) 2216 then 2217 declare 2218 Act_T : constant Entity_Id := Build_Default_Subtype (T, N); 2219 2220 begin 2221 Set_Etype (Id, Act_T); 2222 2223 -- Rewrite component definition to use the constrained subtype 2224 2225 Rewrite (Component_Definition (N), 2226 Make_Component_Definition (Loc, 2227 Subtype_Indication => New_Occurrence_Of (Act_T, Loc))); 2228 end; 2229 end if; 2230 2231 Set_Original_Record_Component (Id, Id); 2232 2233 if Has_Aspects (N) then 2234 Analyze_Aspect_Specifications (N, Id); 2235 end if; 2236 2237 Analyze_Dimension (N); 2238 end Analyze_Component_Declaration; 2239 2240 -------------------------- 2241 -- Analyze_Declarations -- 2242 -------------------------- 2243 2244 procedure Analyze_Declarations (L : List_Id) is 2245 Decl : Node_Id; 2246 2247 procedure Adjust_Decl; 2248 -- Adjust Decl not to include implicit label declarations, since these 2249 -- have strange Sloc values that result in elaboration check problems. 2250 -- (They have the sloc of the label as found in the source, and that 2251 -- is ahead of the current declarative part). 2252 2253 procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id); 2254 -- Create the subprogram bodies which verify the run-time semantics of 2255 -- the pragmas listed below for each elibigle type found in declarative 2256 -- list Decls. The pragmas are: 2257 -- 2258 -- Default_Initial_Condition 2259 -- Invariant 2260 -- Type_Invariant 2261 -- 2262 -- Context denotes the owner of the declarative list. 2263 2264 procedure Check_Entry_Contracts; 2265 -- Perform a preanalysis of the pre- and postconditions of an entry 2266 -- declaration. This must be done before full resolution and creation 2267 -- of the parameter block, etc. to catch illegal uses within the 2268 -- contract expression. Full analysis of the expression is done when 2269 -- the contract is processed. 2270 2271 function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean; 2272 -- Check if a nested package has entities within it that rely on library 2273 -- level private types where the full view has not been completed for 2274 -- the purposes of checking if it is acceptable to freeze an expression 2275 -- function at the point of declaration. 2276 2277 procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id); 2278 -- Determine whether Body_Decl denotes the body of a late controlled 2279 -- primitive (either Initialize, Adjust or Finalize). If this is the 2280 -- case, add a proper spec if the body lacks one. The spec is inserted 2281 -- before Body_Decl and immediately analyzed. 2282 2283 procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id); 2284 -- Spec_Id is the entity of a package that may define abstract states, 2285 -- and in the case of a child unit, whose ancestors may define abstract 2286 -- states. If the states have partial visible refinement, remove the 2287 -- partial visibility of each constituent at the end of the package 2288 -- spec and body declarations. 2289 2290 procedure Remove_Visible_Refinements (Spec_Id : Entity_Id); 2291 -- Spec_Id is the entity of a package that may define abstract states. 2292 -- If the states have visible refinement, remove the visibility of each 2293 -- constituent at the end of the package body declaration. 2294 2295 procedure Resolve_Aspects; 2296 -- Utility to resolve the expressions of aspects at the end of a list of 2297 -- declarations, or before a declaration that freezes previous entities, 2298 -- such as in a subprogram body. 2299 2300 ----------------- 2301 -- Adjust_Decl -- 2302 ----------------- 2303 2304 procedure Adjust_Decl is 2305 begin 2306 while Present (Prev (Decl)) 2307 and then Nkind (Decl) = N_Implicit_Label_Declaration 2308 loop 2309 Prev (Decl); 2310 end loop; 2311 end Adjust_Decl; 2312 2313 ---------------------------- 2314 -- Build_Assertion_Bodies -- 2315 ---------------------------- 2316 2317 procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id) is 2318 procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id); 2319 -- Create the subprogram bodies which verify the run-time semantics 2320 -- of the pragmas listed below for type Typ. The pragmas are: 2321 -- 2322 -- Default_Initial_Condition 2323 -- Invariant 2324 -- Type_Invariant 2325 2326 ------------------------------------- 2327 -- Build_Assertion_Bodies_For_Type -- 2328 ------------------------------------- 2329 2330 procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id) is 2331 begin 2332 if Nkind (Context) = N_Package_Specification then 2333 2334 -- Preanalyze and resolve the class-wide invariants of an 2335 -- interface at the end of whichever declarative part has the 2336 -- interface type. Note that an interface may be declared in 2337 -- any non-package declarative part, but reaching the end of 2338 -- such a declarative part will always freeze the type and 2339 -- generate the invariant procedure (see Freeze_Type). 2340 2341 if Is_Interface (Typ) then 2342 2343 -- Interfaces are treated as the partial view of a private 2344 -- type, in order to achieve uniformity with the general 2345 -- case. As a result, an interface receives only a "partial" 2346 -- invariant procedure, which is never called. 2347 2348 if Has_Own_Invariants (Typ) then 2349 Build_Invariant_Procedure_Body 2350 (Typ => Typ, 2351 Partial_Invariant => True); 2352 end if; 2353 2354 elsif Decls = Visible_Declarations (Context) then 2355 -- Preanalyze and resolve the invariants of a private type 2356 -- at the end of the visible declarations to catch potential 2357 -- errors. Inherited class-wide invariants are not included 2358 -- because they have already been resolved. 2359 2360 if Ekind (Typ) in E_Limited_Private_Type 2361 | E_Private_Type 2362 | E_Record_Type_With_Private 2363 and then Has_Own_Invariants (Typ) 2364 then 2365 Build_Invariant_Procedure_Body 2366 (Typ => Typ, 2367 Partial_Invariant => True); 2368 end if; 2369 2370 -- Preanalyze and resolve the Default_Initial_Condition 2371 -- assertion expression at the end of the declarations to 2372 -- catch any errors. 2373 2374 if Ekind (Typ) in E_Limited_Private_Type 2375 | E_Private_Type 2376 | E_Record_Type_With_Private 2377 and then Has_Own_DIC (Typ) 2378 then 2379 Build_DIC_Procedure_Body 2380 (Typ => Typ, 2381 Partial_DIC => True); 2382 end if; 2383 2384 elsif Decls = Private_Declarations (Context) then 2385 2386 -- Preanalyze and resolve the invariants of a private type's 2387 -- full view at the end of the private declarations to catch 2388 -- potential errors. 2389 2390 if (not Is_Private_Type (Typ) 2391 or else Present (Underlying_Full_View (Typ))) 2392 and then Has_Private_Declaration (Typ) 2393 and then Has_Invariants (Typ) 2394 then 2395 Build_Invariant_Procedure_Body (Typ); 2396 end if; 2397 2398 if (not Is_Private_Type (Typ) 2399 or else Present (Underlying_Full_View (Typ))) 2400 and then Has_Private_Declaration (Typ) 2401 and then Has_DIC (Typ) 2402 then 2403 Build_DIC_Procedure_Body (Typ); 2404 end if; 2405 end if; 2406 end if; 2407 end Build_Assertion_Bodies_For_Type; 2408 2409 -- Local variables 2410 2411 Decl : Node_Id; 2412 Decl_Id : Entity_Id; 2413 2414 -- Start of processing for Build_Assertion_Bodies 2415 2416 begin 2417 Decl := First (Decls); 2418 while Present (Decl) loop 2419 if Is_Declaration (Decl) then 2420 Decl_Id := Defining_Entity (Decl); 2421 2422 if Is_Type (Decl_Id) then 2423 Build_Assertion_Bodies_For_Type (Decl_Id); 2424 end if; 2425 end if; 2426 2427 Next (Decl); 2428 end loop; 2429 end Build_Assertion_Bodies; 2430 2431 --------------------------- 2432 -- Check_Entry_Contracts -- 2433 --------------------------- 2434 2435 procedure Check_Entry_Contracts is 2436 ASN : Node_Id; 2437 Ent : Entity_Id; 2438 Exp : Node_Id; 2439 2440 begin 2441 Ent := First_Entity (Current_Scope); 2442 while Present (Ent) loop 2443 2444 -- This only concerns entries with pre/postconditions 2445 2446 if Ekind (Ent) = E_Entry 2447 and then Present (Contract (Ent)) 2448 and then Present (Pre_Post_Conditions (Contract (Ent))) 2449 then 2450 ASN := Pre_Post_Conditions (Contract (Ent)); 2451 Push_Scope (Ent); 2452 Install_Formals (Ent); 2453 2454 -- Pre/postconditions are rewritten as Check pragmas. Analysis 2455 -- is performed on a copy of the pragma expression, to prevent 2456 -- modifying the original expression. 2457 2458 while Present (ASN) loop 2459 if Nkind (ASN) = N_Pragma then 2460 Exp := 2461 New_Copy_Tree 2462 (Expression 2463 (First (Pragma_Argument_Associations (ASN)))); 2464 Set_Parent (Exp, ASN); 2465 2466 Preanalyze_Assert_Expression (Exp, Standard_Boolean); 2467 end if; 2468 2469 ASN := Next_Pragma (ASN); 2470 end loop; 2471 2472 End_Scope; 2473 end if; 2474 2475 Next_Entity (Ent); 2476 end loop; 2477 end Check_Entry_Contracts; 2478 2479 ---------------------------------- 2480 -- Contains_Lib_Incomplete_Type -- 2481 ---------------------------------- 2482 2483 function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean is 2484 Curr : Entity_Id; 2485 2486 begin 2487 -- Avoid looking through scopes that do not meet the precondition of 2488 -- Pkg not being within a library unit spec. 2489 2490 if not Is_Compilation_Unit (Pkg) 2491 and then not Is_Generic_Instance (Pkg) 2492 and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg)) 2493 then 2494 -- Loop through all entities in the current scope to identify 2495 -- an entity that depends on a private type. 2496 2497 Curr := First_Entity (Pkg); 2498 loop 2499 if Nkind (Curr) in N_Entity 2500 and then Depends_On_Private (Curr) 2501 then 2502 return True; 2503 end if; 2504 2505 exit when Last_Entity (Current_Scope) = Curr; 2506 Next_Entity (Curr); 2507 end loop; 2508 end if; 2509 2510 return False; 2511 end Contains_Lib_Incomplete_Type; 2512 2513 -------------------------------------- 2514 -- Handle_Late_Controlled_Primitive -- 2515 -------------------------------------- 2516 2517 procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id) is 2518 Body_Spec : constant Node_Id := Specification (Body_Decl); 2519 Body_Id : constant Entity_Id := Defining_Entity (Body_Spec); 2520 Loc : constant Source_Ptr := Sloc (Body_Id); 2521 Params : constant List_Id := 2522 Parameter_Specifications (Body_Spec); 2523 Spec : Node_Id; 2524 Spec_Id : Entity_Id; 2525 Typ : Node_Id; 2526 2527 begin 2528 -- Consider only procedure bodies whose name matches one of the three 2529 -- controlled primitives. 2530 2531 if Nkind (Body_Spec) /= N_Procedure_Specification 2532 or else Chars (Body_Id) not in Name_Adjust 2533 | Name_Finalize 2534 | Name_Initialize 2535 then 2536 return; 2537 2538 -- A controlled primitive must have exactly one formal which is not 2539 -- an anonymous access type. 2540 2541 elsif List_Length (Params) /= 1 then 2542 return; 2543 end if; 2544 2545 Typ := Parameter_Type (First (Params)); 2546 2547 if Nkind (Typ) = N_Access_Definition then 2548 return; 2549 end if; 2550 2551 Find_Type (Typ); 2552 2553 -- The type of the formal must be derived from [Limited_]Controlled 2554 2555 if not Is_Controlled (Entity (Typ)) then 2556 return; 2557 end if; 2558 2559 -- Check whether a specification exists for this body. We do not 2560 -- analyze the spec of the body in full, because it will be analyzed 2561 -- again when the body is properly analyzed, and we cannot create 2562 -- duplicate entries in the formals chain. We look for an explicit 2563 -- specification because the body may be an overriding operation and 2564 -- an inherited spec may be present. 2565 2566 Spec_Id := Current_Entity (Body_Id); 2567 2568 while Present (Spec_Id) loop 2569 if Ekind (Spec_Id) in E_Procedure | E_Generic_Procedure 2570 and then Scope (Spec_Id) = Current_Scope 2571 and then Present (First_Formal (Spec_Id)) 2572 and then No (Next_Formal (First_Formal (Spec_Id))) 2573 and then Etype (First_Formal (Spec_Id)) = Entity (Typ) 2574 and then Comes_From_Source (Spec_Id) 2575 then 2576 return; 2577 end if; 2578 2579 Spec_Id := Homonym (Spec_Id); 2580 end loop; 2581 2582 -- At this point the body is known to be a late controlled primitive. 2583 -- Generate a matching spec and insert it before the body. Note the 2584 -- use of Copy_Separate_Tree - we want an entirely separate semantic 2585 -- tree in this case. 2586 2587 Spec := Copy_Separate_Tree (Body_Spec); 2588 2589 -- Ensure that the subprogram declaration does not inherit the null 2590 -- indicator from the body as we now have a proper spec/body pair. 2591 2592 Set_Null_Present (Spec, False); 2593 2594 -- Ensure that the freeze node is inserted after the declaration of 2595 -- the primitive since its expansion will freeze the primitive. 2596 2597 Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); 2598 2599 Insert_Before_And_Analyze (Body_Decl, Decl); 2600 end Handle_Late_Controlled_Primitive; 2601 2602 ---------------------------------------- 2603 -- Remove_Partial_Visible_Refinements -- 2604 ---------------------------------------- 2605 2606 procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id) is 2607 State_Elmt : Elmt_Id; 2608 begin 2609 if Present (Abstract_States (Spec_Id)) then 2610 State_Elmt := First_Elmt (Abstract_States (Spec_Id)); 2611 while Present (State_Elmt) loop 2612 Set_Has_Partial_Visible_Refinement (Node (State_Elmt), False); 2613 Next_Elmt (State_Elmt); 2614 end loop; 2615 end if; 2616 2617 -- For a child unit, also hide the partial state refinement from 2618 -- ancestor packages. 2619 2620 if Is_Child_Unit (Spec_Id) then 2621 Remove_Partial_Visible_Refinements (Scope (Spec_Id)); 2622 end if; 2623 end Remove_Partial_Visible_Refinements; 2624 2625 -------------------------------- 2626 -- Remove_Visible_Refinements -- 2627 -------------------------------- 2628 2629 procedure Remove_Visible_Refinements (Spec_Id : Entity_Id) is 2630 State_Elmt : Elmt_Id; 2631 begin 2632 if Present (Abstract_States (Spec_Id)) then 2633 State_Elmt := First_Elmt (Abstract_States (Spec_Id)); 2634 while Present (State_Elmt) loop 2635 Set_Has_Visible_Refinement (Node (State_Elmt), False); 2636 Next_Elmt (State_Elmt); 2637 end loop; 2638 end if; 2639 end Remove_Visible_Refinements; 2640 2641 --------------------- 2642 -- Resolve_Aspects -- 2643 --------------------- 2644 2645 procedure Resolve_Aspects is 2646 E : Entity_Id; 2647 2648 begin 2649 E := First_Entity (Current_Scope); 2650 while Present (E) loop 2651 Resolve_Aspect_Expressions (E); 2652 2653 -- Now that the aspect expressions have been resolved, if this is 2654 -- at the end of the visible declarations, we can set the flag 2655 -- Known_To_Have_Preelab_Init properly on types declared in the 2656 -- visible part, which is needed for checking whether full types 2657 -- in the private part satisfy the Preelaborable_Initialization 2658 -- aspect of the partial view. We can't wait for the creation of 2659 -- the pragma by Analyze_Aspects_At_Freeze_Point, because the 2660 -- freeze point may occur after the end of the package declaration 2661 -- (in the case of nested packages). 2662 2663 if Is_Type (E) 2664 and then L = Visible_Declarations (Parent (L)) 2665 and then Has_Aspect (E, Aspect_Preelaborable_Initialization) 2666 then 2667 declare 2668 ASN : constant Node_Id := 2669 Find_Aspect (E, Aspect_Preelaborable_Initialization); 2670 Expr : constant Node_Id := Expression (ASN); 2671 begin 2672 -- Set Known_To_Have_Preelab_Init to True if aspect has no 2673 -- expression, or if the expression is True (or was folded 2674 -- to True), or if the expression is a conjunction of one or 2675 -- more Preelaborable_Initialization attributes applied to 2676 -- formal types and wasn't folded to False. (Note that 2677 -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes goes to 2678 -- Original_Node if needed, hence test for Standard_False.) 2679 2680 if not Present (Expr) 2681 or else (Is_Entity_Name (Expr) 2682 and then Entity (Expr) = Standard_True) 2683 or else 2684 (Is_Conjunction_Of_Formal_Preelab_Init_Attributes (Expr) 2685 and then 2686 not (Is_Entity_Name (Expr) 2687 and then Entity (Expr) = Standard_False)) 2688 then 2689 Set_Known_To_Have_Preelab_Init (E); 2690 end if; 2691 end; 2692 end if; 2693 2694 Next_Entity (E); 2695 end loop; 2696 end Resolve_Aspects; 2697 2698 -- Local variables 2699 2700 Context : Node_Id := Empty; 2701 Ctrl_Typ : Entity_Id := Empty; 2702 Freeze_From : Entity_Id := Empty; 2703 Next_Decl : Node_Id; 2704 2705 -- Start of processing for Analyze_Declarations 2706 2707 begin 2708 Decl := First (L); 2709 while Present (Decl) loop 2710 2711 -- Complete analysis of declaration 2712 2713 Analyze (Decl); 2714 Next_Decl := Next (Decl); 2715 2716 if No (Freeze_From) then 2717 Freeze_From := First_Entity (Current_Scope); 2718 end if; 2719 2720 -- Remember if the declaration we just processed is the full type 2721 -- declaration of a controlled type (to handle late overriding of 2722 -- initialize, adjust or finalize). 2723 2724 if Nkind (Decl) = N_Full_Type_Declaration 2725 and then Is_Controlled (Defining_Identifier (Decl)) 2726 then 2727 Ctrl_Typ := Defining_Identifier (Decl); 2728 end if; 2729 2730 -- At the end of a declarative part, freeze remaining entities 2731 -- declared in it. The end of the visible declarations of package 2732 -- specification is not the end of a declarative part if private 2733 -- declarations are present. The end of a package declaration is a 2734 -- freezing point only if it a library package. A task definition or 2735 -- protected type definition is not a freeze point either. Finally, 2736 -- we do not freeze entities in generic scopes, because there is no 2737 -- code generated for them and freeze nodes will be generated for 2738 -- the instance. 2739 2740 -- The end of a package instantiation is not a freeze point, but 2741 -- for now we make it one, because the generic body is inserted 2742 -- (currently) immediately after. Generic instantiations will not 2743 -- be a freeze point once delayed freezing of bodies is implemented. 2744 -- (This is needed in any case for early instantiations ???). 2745 2746 if No (Next_Decl) then 2747 if Nkind (Parent (L)) = N_Component_List then 2748 null; 2749 2750 elsif Nkind (Parent (L)) in 2751 N_Protected_Definition | N_Task_Definition 2752 then 2753 Check_Entry_Contracts; 2754 2755 elsif Nkind (Parent (L)) /= N_Package_Specification then 2756 if Nkind (Parent (L)) = N_Package_Body then 2757 Freeze_From := First_Entity (Current_Scope); 2758 end if; 2759 2760 -- There may have been several freezing points previously, 2761 -- for example object declarations or subprogram bodies, but 2762 -- at the end of a declarative part we check freezing from 2763 -- the beginning, even though entities may already be frozen, 2764 -- in order to perform visibility checks on delayed aspects. 2765 2766 Adjust_Decl; 2767 2768 -- If the current scope is a generic subprogram body. Skip the 2769 -- generic formal parameters that are not frozen here. 2770 2771 if Is_Subprogram (Current_Scope) 2772 and then Nkind (Unit_Declaration_Node (Current_Scope)) = 2773 N_Generic_Subprogram_Declaration 2774 and then Present (First_Entity (Current_Scope)) 2775 then 2776 while Is_Generic_Formal (Freeze_From) loop 2777 Next_Entity (Freeze_From); 2778 end loop; 2779 2780 Freeze_All (Freeze_From, Decl); 2781 Freeze_From := Last_Entity (Current_Scope); 2782 2783 else 2784 -- For declarations in a subprogram body there is no issue 2785 -- with name resolution in aspect specifications. 2786 2787 Freeze_All (First_Entity (Current_Scope), Decl); 2788 Freeze_From := Last_Entity (Current_Scope); 2789 end if; 2790 2791 -- Current scope is a package specification 2792 2793 elsif Scope (Current_Scope) /= Standard_Standard 2794 and then not Is_Child_Unit (Current_Scope) 2795 and then No (Generic_Parent (Parent (L))) 2796 then 2797 -- ARM rule 13.1.1(11/3): usage names in aspect definitions are 2798 -- resolved at the end of the immediately enclosing declaration 2799 -- list (AI05-0183-1). 2800 2801 Resolve_Aspects; 2802 2803 elsif L /= Visible_Declarations (Parent (L)) 2804 or else Is_Empty_List (Private_Declarations (Parent (L))) 2805 then 2806 Adjust_Decl; 2807 2808 -- End of a package declaration 2809 2810 -- This is a freeze point because it is the end of a 2811 -- compilation unit. 2812 2813 Freeze_All (First_Entity (Current_Scope), Decl); 2814 Freeze_From := Last_Entity (Current_Scope); 2815 2816 -- At the end of the visible declarations the expressions in 2817 -- aspects of all entities declared so far must be resolved. 2818 -- The entities themselves might be frozen later, and the 2819 -- generated pragmas and attribute definition clauses analyzed 2820 -- in full at that point, but name resolution must take place 2821 -- now. 2822 -- In addition to being the proper semantics, this is mandatory 2823 -- within generic units, because global name capture requires 2824 -- those expressions to be analyzed, given that the generated 2825 -- pragmas do not appear in the original generic tree. 2826 2827 elsif Serious_Errors_Detected = 0 then 2828 Resolve_Aspects; 2829 end if; 2830 2831 -- If next node is a body then freeze all types before the body. 2832 -- An exception occurs for some expander-generated bodies. If these 2833 -- are generated at places where in general language rules would not 2834 -- allow a freeze point, then we assume that the expander has 2835 -- explicitly checked that all required types are properly frozen, 2836 -- and we do not cause general freezing here. This special circuit 2837 -- is used when the encountered body is marked as having already 2838 -- been analyzed. 2839 2840 -- In all other cases (bodies that come from source, and expander 2841 -- generated bodies that have not been analyzed yet), freeze all 2842 -- types now. Note that in the latter case, the expander must take 2843 -- care to attach the bodies at a proper place in the tree so as to 2844 -- not cause unwanted freezing at that point. 2845 2846 -- It is also necessary to check for a case where both an expression 2847 -- function is used and the current scope depends on an incomplete 2848 -- private type from a library unit, otherwise premature freezing of 2849 -- the private type will occur. 2850 2851 elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) 2852 and then ((Nkind (Next_Decl) /= N_Subprogram_Body 2853 or else not Was_Expression_Function (Next_Decl)) 2854 or else (not Is_Ignored_Ghost_Entity (Current_Scope) 2855 and then not Contains_Lib_Incomplete_Type 2856 (Current_Scope))) 2857 then 2858 -- When a controlled type is frozen, the expander generates stream 2859 -- and controlled-type support routines. If the freeze is caused 2860 -- by the stand-alone body of Initialize, Adjust, or Finalize, the 2861 -- expander will end up using the wrong version of these routines, 2862 -- as the body has not been processed yet. To remedy this, detect 2863 -- a late controlled primitive and create a proper spec for it. 2864 -- This ensures that the primitive will override its inherited 2865 -- counterpart before the freeze takes place. 2866 2867 -- If the declaration we just processed is a body, do not attempt 2868 -- to examine Next_Decl as the late primitive idiom can only apply 2869 -- to the first encountered body. 2870 2871 -- ??? A cleaner approach may be possible and/or this solution 2872 -- could be extended to general-purpose late primitives. 2873 2874 if Present (Ctrl_Typ) then 2875 2876 -- No need to continue searching for late body overriding if 2877 -- the controlled type is already frozen. 2878 2879 if Is_Frozen (Ctrl_Typ) then 2880 Ctrl_Typ := Empty; 2881 2882 elsif Nkind (Next_Decl) = N_Subprogram_Body then 2883 Handle_Late_Controlled_Primitive (Next_Decl); 2884 end if; 2885 end if; 2886 2887 Adjust_Decl; 2888 2889 -- The generated body of an expression function does not freeze, 2890 -- unless it is a completion, in which case only the expression 2891 -- itself freezes. This is handled when the body itself is 2892 -- analyzed (see Freeze_Expr_Types, sem_ch6.adb). 2893 2894 Freeze_All (Freeze_From, Decl); 2895 Freeze_From := Last_Entity (Current_Scope); 2896 end if; 2897 2898 Decl := Next_Decl; 2899 end loop; 2900 2901 -- Post-freezing actions 2902 2903 if Present (L) then 2904 Context := Parent (L); 2905 2906 -- Certain contract annotations have forward visibility semantics and 2907 -- must be analyzed after all declarative items have been processed. 2908 -- This timing ensures that entities referenced by such contracts are 2909 -- visible. 2910 2911 -- Analyze the contract of an immediately enclosing package spec or 2912 -- body first because other contracts may depend on its information. 2913 2914 if Nkind (Context) = N_Package_Body then 2915 Analyze_Package_Body_Contract (Defining_Entity (Context)); 2916 2917 elsif Nkind (Context) = N_Package_Specification then 2918 Analyze_Package_Contract (Defining_Entity (Context)); 2919 end if; 2920 2921 -- Analyze the contracts of various constructs in the declarative 2922 -- list. 2923 2924 Analyze_Contracts (L); 2925 2926 if Nkind (Context) = N_Package_Body then 2927 2928 -- Ensure that all abstract states and objects declared in the 2929 -- state space of a package body are utilized as constituents. 2930 2931 Check_Unused_Body_States (Defining_Entity (Context)); 2932 2933 -- State refinements are visible up to the end of the package body 2934 -- declarations. Hide the state refinements from visibility to 2935 -- restore the original state conditions. 2936 2937 Remove_Visible_Refinements (Corresponding_Spec (Context)); 2938 Remove_Partial_Visible_Refinements (Corresponding_Spec (Context)); 2939 2940 elsif Nkind (Context) = N_Package_Specification then 2941 2942 -- Partial state refinements are visible up to the end of the 2943 -- package spec declarations. Hide the partial state refinements 2944 -- from visibility to restore the original state conditions. 2945 2946 Remove_Partial_Visible_Refinements (Defining_Entity (Context)); 2947 end if; 2948 2949 -- Verify that all abstract states found in any package declared in 2950 -- the input declarative list have proper refinements. The check is 2951 -- performed only when the context denotes a block, entry, package, 2952 -- protected, subprogram, or task body (SPARK RM 7.2.2(3)). 2953 2954 Check_State_Refinements (Context); 2955 2956 -- Create the subprogram bodies which verify the run-time semantics 2957 -- of pragmas Default_Initial_Condition and [Type_]Invariant for all 2958 -- types within the current declarative list. This ensures that all 2959 -- assertion expressions are preanalyzed and resolved at the end of 2960 -- the declarative part. Note that the resolution happens even when 2961 -- freezing does not take place. 2962 2963 Build_Assertion_Bodies (L, Context); 2964 end if; 2965 end Analyze_Declarations; 2966 2967 ----------------------------------- 2968 -- Analyze_Full_Type_Declaration -- 2969 ----------------------------------- 2970 2971 procedure Analyze_Full_Type_Declaration (N : Node_Id) is 2972 Def : constant Node_Id := Type_Definition (N); 2973 Def_Id : constant Entity_Id := Defining_Identifier (N); 2974 T : Entity_Id; 2975 Prev : Entity_Id; 2976 2977 Is_Remote : constant Boolean := 2978 (Is_Remote_Types (Current_Scope) 2979 or else Is_Remote_Call_Interface (Current_Scope)) 2980 and then not (In_Private_Part (Current_Scope) 2981 or else In_Package_Body (Current_Scope)); 2982 2983 procedure Check_Nonoverridable_Aspects; 2984 -- Apply the rule in RM 13.1.1(18.4/4) on iterator aspects that cannot 2985 -- be overridden, and can only be confirmed on derivation. 2986 2987 procedure Check_Ops_From_Incomplete_Type; 2988 -- If there is a tagged incomplete partial view of the type, traverse 2989 -- the primitives of the incomplete view and change the type of any 2990 -- controlling formals and result to indicate the full view. The 2991 -- primitives will be added to the full type's primitive operations 2992 -- list later in Sem_Disp.Check_Operation_From_Incomplete_Type (which 2993 -- is called from Process_Incomplete_Dependents). 2994 2995 ---------------------------------- 2996 -- Check_Nonoverridable_Aspects -- 2997 ---------------------------------- 2998 2999 procedure Check_Nonoverridable_Aspects is 3000 function Get_Aspect_Spec 3001 (Specs : List_Id; 3002 Aspect_Name : Name_Id) return Node_Id; 3003 -- Check whether a list of aspect specifications includes an entry 3004 -- for a specific aspect. The list is either that of a partial or 3005 -- a full view. 3006 3007 --------------------- 3008 -- Get_Aspect_Spec -- 3009 --------------------- 3010 3011 function Get_Aspect_Spec 3012 (Specs : List_Id; 3013 Aspect_Name : Name_Id) return Node_Id 3014 is 3015 Spec : Node_Id; 3016 3017 begin 3018 Spec := First (Specs); 3019 while Present (Spec) loop 3020 if Chars (Identifier (Spec)) = Aspect_Name then 3021 return Spec; 3022 end if; 3023 Next (Spec); 3024 end loop; 3025 3026 return Empty; 3027 end Get_Aspect_Spec; 3028 3029 -- Local variables 3030 3031 Prev_Aspects : constant List_Id := 3032 Aspect_Specifications (Parent (Def_Id)); 3033 Par_Type : Entity_Id; 3034 Prev_Aspect : Node_Id; 3035 3036 -- Start of processing for Check_Nonoverridable_Aspects 3037 3038 begin 3039 -- Get parent type of derived type. Note that Prev is the entity in 3040 -- the partial declaration, but its contents are now those of full 3041 -- view, while Def_Id reflects the partial view. 3042 3043 if Is_Private_Type (Def_Id) then 3044 Par_Type := Etype (Full_View (Def_Id)); 3045 else 3046 Par_Type := Etype (Def_Id); 3047 end if; 3048 3049 -- If there is an inherited Implicit_Dereference, verify that it is 3050 -- made explicit in the partial view. 3051 3052 if Has_Discriminants (Base_Type (Par_Type)) 3053 and then Nkind (Parent (Prev)) = N_Full_Type_Declaration 3054 and then Present (Discriminant_Specifications (Parent (Prev))) 3055 and then Present (Get_Reference_Discriminant (Par_Type)) 3056 then 3057 Prev_Aspect := 3058 Get_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference); 3059 3060 if No (Prev_Aspect) 3061 and then Present 3062 (Discriminant_Specifications 3063 (Original_Node (Parent (Prev)))) 3064 then 3065 Error_Msg_N 3066 ("type does not inherit implicit dereference", Prev); 3067 3068 else 3069 -- If one of the views has the aspect specified, verify that it 3070 -- is consistent with that of the parent. 3071 3072 declare 3073 Cur_Discr : constant Entity_Id := 3074 Get_Reference_Discriminant (Prev); 3075 Par_Discr : constant Entity_Id := 3076 Get_Reference_Discriminant (Par_Type); 3077 3078 begin 3079 if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then 3080 Error_Msg_N 3081 ("aspect inconsistent with that of parent", N); 3082 end if; 3083 3084 -- Check that specification in partial view matches the 3085 -- inherited aspect. Compare names directly because aspect 3086 -- expression may not be analyzed. 3087 3088 if Present (Prev_Aspect) 3089 and then Nkind (Expression (Prev_Aspect)) = N_Identifier 3090 and then Chars (Expression (Prev_Aspect)) /= 3091 Chars (Cur_Discr) 3092 then 3093 Error_Msg_N 3094 ("aspect inconsistent with that of parent", N); 3095 end if; 3096 end; 3097 end if; 3098 end if; 3099 3100 -- What about other nonoverridable aspects??? 3101 end Check_Nonoverridable_Aspects; 3102 3103 ------------------------------------ 3104 -- Check_Ops_From_Incomplete_Type -- 3105 ------------------------------------ 3106 3107 procedure Check_Ops_From_Incomplete_Type is 3108 Elmt : Elmt_Id; 3109 Formal : Entity_Id; 3110 Op : Entity_Id; 3111 3112 begin 3113 if Prev /= T 3114 and then Ekind (Prev) = E_Incomplete_Type 3115 and then Is_Tagged_Type (Prev) 3116 and then Is_Tagged_Type (T) 3117 and then Present (Primitive_Operations (Prev)) 3118 then 3119 Elmt := First_Elmt (Primitive_Operations (Prev)); 3120 while Present (Elmt) loop 3121 Op := Node (Elmt); 3122 3123 Formal := First_Formal (Op); 3124 while Present (Formal) loop 3125 if Etype (Formal) = Prev then 3126 Set_Etype (Formal, T); 3127 end if; 3128 3129 Next_Formal (Formal); 3130 end loop; 3131 3132 if Etype (Op) = Prev then 3133 Set_Etype (Op, T); 3134 end if; 3135 3136 Next_Elmt (Elmt); 3137 end loop; 3138 end if; 3139 end Check_Ops_From_Incomplete_Type; 3140 3141 -- Start of processing for Analyze_Full_Type_Declaration 3142 3143 begin 3144 Prev := Find_Type_Name (N); 3145 3146 -- The full view, if present, now points to the current type. If there 3147 -- is an incomplete partial view, set a link to it, to simplify the 3148 -- retrieval of primitive operations of the type. 3149 3150 -- Ada 2005 (AI-50217): If the type was previously decorated when 3151 -- imported through a LIMITED WITH clause, it appears as incomplete 3152 -- but has no full view. 3153 3154 if Ekind (Prev) = E_Incomplete_Type 3155 and then Present (Full_View (Prev)) 3156 then 3157 T := Full_View (Prev); 3158 Set_Incomplete_View (N, Parent (Prev)); 3159 else 3160 T := Prev; 3161 end if; 3162 3163 Set_Is_Pure (T, Is_Pure (Current_Scope)); 3164 3165 -- We set the flag Is_First_Subtype here. It is needed to set the 3166 -- corresponding flag for the Implicit class-wide-type created 3167 -- during tagged types processing. 3168 3169 Set_Is_First_Subtype (T, True); 3170 3171 -- Only composite types other than array types are allowed to have 3172 -- discriminants. 3173 3174 case Nkind (Def) is 3175 3176 -- For derived types, the rule will be checked once we've figured 3177 -- out the parent type. 3178 3179 when N_Derived_Type_Definition => 3180 null; 3181 3182 -- For record types, discriminants are allowed. 3183 3184 when N_Record_Definition => 3185 null; 3186 3187 when others => 3188 if Present (Discriminant_Specifications (N)) then 3189 Error_Msg_N 3190 ("elementary or array type cannot have discriminants", 3191 Defining_Identifier 3192 (First (Discriminant_Specifications (N)))); 3193 end if; 3194 end case; 3195 3196 -- Elaborate the type definition according to kind, and generate 3197 -- subsidiary (implicit) subtypes where needed. We skip this if it was 3198 -- already done (this happens during the reanalysis that follows a call 3199 -- to the high level optimizer). 3200 3201 if not Analyzed (T) then 3202 Set_Analyzed (T); 3203 3204 -- Set the SPARK mode from the current context 3205 3206 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 3207 Set_SPARK_Pragma_Inherited (T); 3208 3209 case Nkind (Def) is 3210 when N_Access_To_Subprogram_Definition => 3211 Access_Subprogram_Declaration (T, Def); 3212 3213 -- If this is a remote access to subprogram, we must create the 3214 -- equivalent fat pointer type, and related subprograms. 3215 3216 if Is_Remote then 3217 Process_Remote_AST_Declaration (N); 3218 end if; 3219 3220 -- Validate categorization rule against access type declaration 3221 -- usually a violation in Pure unit, Shared_Passive unit. 3222 3223 Validate_Access_Type_Declaration (T, N); 3224 3225 -- If the type has contracts, we create the corresponding 3226 -- wrapper at once, before analyzing the aspect specifications, 3227 -- so that pre/postconditions can be handled directly on the 3228 -- generated wrapper. 3229 3230 if Ada_Version >= Ada_2022 3231 and then Present (Aspect_Specifications (N)) 3232 then 3233 Build_Access_Subprogram_Wrapper (N); 3234 end if; 3235 3236 when N_Access_To_Object_Definition => 3237 Access_Type_Declaration (T, Def); 3238 3239 -- Validate categorization rule against access type declaration 3240 -- usually a violation in Pure unit, Shared_Passive unit. 3241 3242 Validate_Access_Type_Declaration (T, N); 3243 3244 -- If we are in a Remote_Call_Interface package and define a 3245 -- RACW, then calling stubs and specific stream attributes 3246 -- must be added. 3247 3248 if Is_Remote 3249 and then Is_Remote_Access_To_Class_Wide_Type (Def_Id) 3250 then 3251 Add_RACW_Features (Def_Id); 3252 end if; 3253 3254 when N_Array_Type_Definition => 3255 Array_Type_Declaration (T, Def); 3256 3257 when N_Derived_Type_Definition => 3258 Derived_Type_Declaration (T, N, T /= Def_Id); 3259 3260 -- Inherit predicates from parent, and protect against illegal 3261 -- derivations. 3262 3263 if Is_Type (T) and then Has_Predicates (T) then 3264 Set_Has_Predicates (Def_Id); 3265 end if; 3266 3267 -- Save the scenario for examination by the ABE Processing 3268 -- phase. 3269 3270 Record_Elaboration_Scenario (N); 3271 3272 when N_Enumeration_Type_Definition => 3273 Enumeration_Type_Declaration (T, Def); 3274 3275 when N_Floating_Point_Definition => 3276 Floating_Point_Type_Declaration (T, Def); 3277 3278 when N_Decimal_Fixed_Point_Definition => 3279 Decimal_Fixed_Point_Type_Declaration (T, Def); 3280 3281 when N_Ordinary_Fixed_Point_Definition => 3282 Ordinary_Fixed_Point_Type_Declaration (T, Def); 3283 3284 when N_Signed_Integer_Type_Definition => 3285 Signed_Integer_Type_Declaration (T, Def); 3286 3287 when N_Modular_Type_Definition => 3288 Modular_Type_Declaration (T, Def); 3289 3290 when N_Record_Definition => 3291 Record_Type_Declaration (T, N, Prev); 3292 3293 -- If declaration has a parse error, nothing to elaborate. 3294 3295 when N_Error => 3296 null; 3297 3298 when others => 3299 raise Program_Error; 3300 end case; 3301 end if; 3302 3303 if Etype (T) = Any_Type then 3304 return; 3305 end if; 3306 3307 -- Set the primitives list of the full type and its base type when 3308 -- needed. T may be E_Void in cases of earlier errors, and in that 3309 -- case we bypass this. 3310 3311 if Ekind (T) /= E_Void then 3312 if not Present (Direct_Primitive_Operations (T)) then 3313 if Etype (T) = T then 3314 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3315 3316 -- If Etype of T is the base type (as opposed to a parent type) 3317 -- and already has an associated list of primitive operations, 3318 -- then set T's primitive list to the base type's list. Otherwise, 3319 -- create a new empty primitives list and share the list between 3320 -- T and its base type. The lists need to be shared in common. 3321 3322 elsif Etype (T) = Base_Type (T) then 3323 3324 if not Present (Direct_Primitive_Operations (Base_Type (T))) 3325 then 3326 Set_Direct_Primitive_Operations 3327 (Base_Type (T), New_Elmt_List); 3328 end if; 3329 3330 Set_Direct_Primitive_Operations 3331 (T, Direct_Primitive_Operations (Base_Type (T))); 3332 3333 -- Case where the Etype is a parent type, so we need a new 3334 -- primitives list for T. 3335 3336 else 3337 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3338 end if; 3339 3340 -- If T already has a Direct_Primitive_Operations list but its 3341 -- base type doesn't then set the base type's list to T's list. 3342 3343 elsif not Present (Direct_Primitive_Operations (Base_Type (T))) then 3344 Set_Direct_Primitive_Operations 3345 (Base_Type (T), Direct_Primitive_Operations (T)); 3346 end if; 3347 end if; 3348 3349 -- Some common processing for all types 3350 3351 Set_Depends_On_Private (T, Has_Private_Component (T)); 3352 Check_Ops_From_Incomplete_Type; 3353 3354 -- Both the declared entity, and its anonymous base type if one was 3355 -- created, need freeze nodes allocated. 3356 3357 declare 3358 B : constant Entity_Id := Base_Type (T); 3359 3360 begin 3361 -- In the case where the base type differs from the first subtype, we 3362 -- pre-allocate a freeze node, and set the proper link to the first 3363 -- subtype. Freeze_Entity will use this preallocated freeze node when 3364 -- it freezes the entity. 3365 3366 -- This does not apply if the base type is a generic type, whose 3367 -- declaration is independent of the current derived definition. 3368 3369 if B /= T and then not Is_Generic_Type (B) then 3370 Ensure_Freeze_Node (B); 3371 Set_First_Subtype_Link (Freeze_Node (B), T); 3372 end if; 3373 3374 -- A type that is imported through a limited_with clause cannot 3375 -- generate any code, and thus need not be frozen. However, an access 3376 -- type with an imported designated type needs a finalization list, 3377 -- which may be referenced in some other package that has non-limited 3378 -- visibility on the designated type. Thus we must create the 3379 -- finalization list at the point the access type is frozen, to 3380 -- prevent unsatisfied references at link time. 3381 3382 if not From_Limited_With (T) or else Is_Access_Type (T) then 3383 Set_Has_Delayed_Freeze (T); 3384 end if; 3385 end; 3386 3387 -- Case where T is the full declaration of some private type which has 3388 -- been swapped in Defining_Identifier (N). 3389 3390 if T /= Def_Id and then Is_Private_Type (Def_Id) then 3391 Process_Full_View (N, T, Def_Id); 3392 3393 -- Record the reference. The form of this is a little strange, since 3394 -- the full declaration has been swapped in. So the first parameter 3395 -- here represents the entity to which a reference is made which is 3396 -- the "real" entity, i.e. the one swapped in, and the second 3397 -- parameter provides the reference location. 3398 3399 -- Also, we want to kill Has_Pragma_Unreferenced temporarily here 3400 -- since we don't want a complaint about the full type being an 3401 -- unwanted reference to the private type 3402 3403 declare 3404 B : constant Boolean := Has_Pragma_Unreferenced (T); 3405 begin 3406 Set_Has_Pragma_Unreferenced (T, False); 3407 Generate_Reference (T, T, 'c'); 3408 Set_Has_Pragma_Unreferenced (T, B); 3409 end; 3410 3411 Set_Completion_Referenced (Def_Id); 3412 3413 -- For completion of incomplete type, process incomplete dependents 3414 -- and always mark the full type as referenced (it is the incomplete 3415 -- type that we get for any real reference). 3416 3417 elsif Ekind (Prev) = E_Incomplete_Type then 3418 Process_Incomplete_Dependents (N, T, Prev); 3419 Generate_Reference (Prev, Def_Id, 'c'); 3420 Set_Completion_Referenced (Def_Id); 3421 3422 -- If not private type or incomplete type completion, this is a real 3423 -- definition of a new entity, so record it. 3424 3425 else 3426 Generate_Definition (Def_Id); 3427 end if; 3428 3429 -- Propagate any pending access types whose finalization masters need to 3430 -- be fully initialized from the partial to the full view. Guard against 3431 -- an illegal full view that remains unanalyzed. 3432 3433 if Is_Type (Def_Id) and then Is_Incomplete_Or_Private_Type (Prev) then 3434 Set_Pending_Access_Types (Def_Id, Pending_Access_Types (Prev)); 3435 end if; 3436 3437 if Chars (Scope (Def_Id)) = Name_System 3438 and then Chars (Def_Id) = Name_Address 3439 and then In_Predefined_Unit (N) 3440 then 3441 Set_Is_Descendant_Of_Address (Def_Id); 3442 Set_Is_Descendant_Of_Address (Base_Type (Def_Id)); 3443 Set_Is_Descendant_Of_Address (Prev); 3444 end if; 3445 3446 Set_Optimize_Alignment_Flags (Def_Id); 3447 Check_Eliminated (Def_Id); 3448 3449 -- If the declaration is a completion and aspects are present, apply 3450 -- them to the entity for the type which is currently the partial 3451 -- view, but which is the one that will be frozen. 3452 3453 if Has_Aspects (N) then 3454 3455 -- In most cases the partial view is a private type, and both views 3456 -- appear in different declarative parts. In the unusual case where 3457 -- the partial view is incomplete, perform the analysis on the 3458 -- full view, to prevent freezing anomalies with the corresponding 3459 -- class-wide type, which otherwise might be frozen before the 3460 -- dispatch table is built. 3461 3462 if Prev /= Def_Id 3463 and then Ekind (Prev) /= E_Incomplete_Type 3464 then 3465 Analyze_Aspect_Specifications (N, Prev); 3466 3467 -- Normal case 3468 3469 else 3470 Analyze_Aspect_Specifications (N, Def_Id); 3471 end if; 3472 end if; 3473 3474 if Is_Derived_Type (Prev) 3475 and then Def_Id /= Prev 3476 then 3477 Check_Nonoverridable_Aspects; 3478 end if; 3479 end Analyze_Full_Type_Declaration; 3480 3481 ---------------------------------- 3482 -- Analyze_Incomplete_Type_Decl -- 3483 ---------------------------------- 3484 3485 procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is 3486 F : constant Boolean := Is_Pure (Current_Scope); 3487 T : Entity_Id; 3488 3489 begin 3490 Generate_Definition (Defining_Identifier (N)); 3491 3492 -- Process an incomplete declaration. The identifier must not have been 3493 -- declared already in the scope. However, an incomplete declaration may 3494 -- appear in the private part of a package, for a private type that has 3495 -- already been declared. 3496 3497 -- In this case, the discriminants (if any) must match 3498 3499 T := Find_Type_Name (N); 3500 3501 Mutate_Ekind (T, E_Incomplete_Type); 3502 Set_Etype (T, T); 3503 Set_Is_First_Subtype (T); 3504 Reinit_Size_Align (T); 3505 3506 -- Set the SPARK mode from the current context 3507 3508 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 3509 Set_SPARK_Pragma_Inherited (T); 3510 3511 -- Ada 2005 (AI-326): Minimum decoration to give support to tagged 3512 -- incomplete types. 3513 3514 if Tagged_Present (N) then 3515 Set_Is_Tagged_Type (T, True); 3516 Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); 3517 Make_Class_Wide_Type (T); 3518 end if; 3519 3520 -- Initialize the list of primitive operations to an empty list, 3521 -- to cover tagged types as well as untagged types. For untagged 3522 -- types this is used either to analyze the call as legal when 3523 -- Extensions_Allowed is True, or to issue a better error message 3524 -- otherwise. 3525 3526 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3527 3528 Set_Stored_Constraint (T, No_Elist); 3529 3530 if Present (Discriminant_Specifications (N)) then 3531 Push_Scope (T); 3532 Process_Discriminants (N); 3533 End_Scope; 3534 end if; 3535 3536 -- If the type has discriminants, nontrivial subtypes may be declared 3537 -- before the full view of the type. The full views of those subtypes 3538 -- will be built after the full view of the type. 3539 3540 Set_Private_Dependents (T, New_Elmt_List); 3541 Set_Is_Pure (T, F); 3542 end Analyze_Incomplete_Type_Decl; 3543 3544 ----------------------------------- 3545 -- Analyze_Interface_Declaration -- 3546 ----------------------------------- 3547 3548 procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is 3549 CW : constant Entity_Id := Class_Wide_Type (T); 3550 3551 begin 3552 Set_Is_Tagged_Type (T); 3553 Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); 3554 3555 Set_Is_Limited_Record (T, Limited_Present (Def) 3556 or else Task_Present (Def) 3557 or else Protected_Present (Def) 3558 or else Synchronized_Present (Def)); 3559 3560 -- Type is abstract if full declaration carries keyword, or if previous 3561 -- partial view did. 3562 3563 Set_Is_Abstract_Type (T); 3564 Set_Is_Interface (T); 3565 3566 -- Type is a limited interface if it includes the keyword limited, task, 3567 -- protected, or synchronized. 3568 3569 Set_Is_Limited_Interface 3570 (T, Limited_Present (Def) 3571 or else Protected_Present (Def) 3572 or else Synchronized_Present (Def) 3573 or else Task_Present (Def)); 3574 3575 Set_Interfaces (T, New_Elmt_List); 3576 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3577 3578 -- Complete the decoration of the class-wide entity if it was already 3579 -- built (i.e. during the creation of the limited view) 3580 3581 if Present (CW) then 3582 Set_Is_Interface (CW); 3583 Set_Is_Limited_Interface (CW, Is_Limited_Interface (T)); 3584 end if; 3585 3586 -- Check runtime support for synchronized interfaces 3587 3588 if Is_Concurrent_Interface (T) 3589 and then not RTE_Available (RE_Select_Specific_Data) 3590 then 3591 Error_Msg_CRT ("synchronized interfaces", T); 3592 end if; 3593 end Analyze_Interface_Declaration; 3594 3595 ----------------------------- 3596 -- Analyze_Itype_Reference -- 3597 ----------------------------- 3598 3599 -- Nothing to do. This node is placed in the tree only for the benefit of 3600 -- back end processing, and has no effect on the semantic processing. 3601 3602 procedure Analyze_Itype_Reference (N : Node_Id) is 3603 begin 3604 pragma Assert (Is_Itype (Itype (N))); 3605 null; 3606 end Analyze_Itype_Reference; 3607 3608 -------------------------------- 3609 -- Analyze_Number_Declaration -- 3610 -------------------------------- 3611 3612 procedure Analyze_Number_Declaration (N : Node_Id) is 3613 E : constant Node_Id := Expression (N); 3614 Id : constant Entity_Id := Defining_Identifier (N); 3615 Index : Interp_Index; 3616 It : Interp; 3617 T : Entity_Id; 3618 3619 begin 3620 Generate_Definition (Id); 3621 Enter_Name (Id); 3622 3623 -- This is an optimization of a common case of an integer literal 3624 3625 if Nkind (E) = N_Integer_Literal then 3626 Set_Is_Static_Expression (E, True); 3627 Set_Etype (E, Universal_Integer); 3628 3629 Set_Etype (Id, Universal_Integer); 3630 Mutate_Ekind (Id, E_Named_Integer); 3631 Set_Is_Frozen (Id, True); 3632 3633 Set_Debug_Info_Needed (Id); 3634 return; 3635 end if; 3636 3637 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3638 3639 -- Process expression, replacing error by integer zero, to avoid 3640 -- cascaded errors or aborts further along in the processing 3641 3642 -- Replace Error by integer zero, which seems least likely to cause 3643 -- cascaded errors. 3644 3645 if E = Error then 3646 Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0)); 3647 Set_Error_Posted (E); 3648 end if; 3649 3650 Analyze (E); 3651 3652 -- Verify that the expression is static and numeric. If 3653 -- the expression is overloaded, we apply the preference 3654 -- rule that favors root numeric types. 3655 3656 if not Is_Overloaded (E) then 3657 T := Etype (E); 3658 if Has_Dynamic_Predicate_Aspect (T) then 3659 Error_Msg_N 3660 ("subtype has dynamic predicate, " 3661 & "not allowed in number declaration", N); 3662 end if; 3663 3664 else 3665 T := Any_Type; 3666 3667 Get_First_Interp (E, Index, It); 3668 while Present (It.Typ) loop 3669 if (Is_Integer_Type (It.Typ) or else Is_Real_Type (It.Typ)) 3670 and then (Scope (Base_Type (It.Typ))) = Standard_Standard 3671 then 3672 if T = Any_Type then 3673 T := It.Typ; 3674 3675 elsif Is_Universal_Numeric_Type (It.Typ) then 3676 -- Choose universal interpretation over any other 3677 3678 T := It.Typ; 3679 exit; 3680 end if; 3681 end if; 3682 3683 Get_Next_Interp (Index, It); 3684 end loop; 3685 end if; 3686 3687 if Is_Integer_Type (T) then 3688 Resolve (E, T); 3689 Set_Etype (Id, Universal_Integer); 3690 Mutate_Ekind (Id, E_Named_Integer); 3691 3692 elsif Is_Real_Type (T) then 3693 3694 -- Because the real value is converted to universal_real, this is a 3695 -- legal context for a universal fixed expression. 3696 3697 if T = Universal_Fixed then 3698 declare 3699 Loc : constant Source_Ptr := Sloc (N); 3700 Conv : constant Node_Id := Make_Type_Conversion (Loc, 3701 Subtype_Mark => 3702 New_Occurrence_Of (Universal_Real, Loc), 3703 Expression => Relocate_Node (E)); 3704 3705 begin 3706 Rewrite (E, Conv); 3707 Analyze (E); 3708 end; 3709 3710 elsif T = Any_Fixed then 3711 Error_Msg_N ("illegal context for mixed mode operation", E); 3712 3713 -- Expression is of the form : universal_fixed * integer. Try to 3714 -- resolve as universal_real. 3715 3716 T := Universal_Real; 3717 Set_Etype (E, T); 3718 end if; 3719 3720 Resolve (E, T); 3721 Set_Etype (Id, Universal_Real); 3722 Mutate_Ekind (Id, E_Named_Real); 3723 3724 else 3725 Wrong_Type (E, Any_Numeric); 3726 Resolve (E, T); 3727 3728 Set_Etype (Id, T); 3729 Mutate_Ekind (Id, E_Constant); 3730 Set_Never_Set_In_Source (Id, True); 3731 Set_Is_True_Constant (Id, True); 3732 return; 3733 end if; 3734 3735 if Nkind (E) in N_Integer_Literal | N_Real_Literal then 3736 Set_Etype (E, Etype (Id)); 3737 end if; 3738 3739 if not Is_OK_Static_Expression (E) then 3740 Flag_Non_Static_Expr 3741 ("non-static expression used in number declaration!", E); 3742 Rewrite (E, Make_Integer_Literal (Sloc (N), 1)); 3743 Set_Etype (E, Any_Type); 3744 end if; 3745 3746 Analyze_Dimension (N); 3747 end Analyze_Number_Declaration; 3748 3749 -------------------------------- 3750 -- Analyze_Object_Declaration -- 3751 -------------------------------- 3752 3753 -- WARNING: This routine manages Ghost regions. Return statements must be 3754 -- replaced by gotos which jump to the end of the routine and restore the 3755 -- Ghost mode. 3756 3757 procedure Analyze_Object_Declaration (N : Node_Id) is 3758 Loc : constant Source_Ptr := Sloc (N); 3759 Id : constant Entity_Id := Defining_Identifier (N); 3760 Next_Decl : constant Node_Id := Next (N); 3761 3762 Act_T : Entity_Id; 3763 T : Entity_Id; 3764 3765 E : Node_Id := Expression (N); 3766 -- E is set to Expression (N) throughout this routine. When Expression 3767 -- (N) is modified, E is changed accordingly. 3768 3769 procedure Check_Dynamic_Object (Typ : Entity_Id); 3770 -- A library-level object with nonstatic discriminant constraints may 3771 -- require dynamic allocation. The declaration is illegal if the 3772 -- profile includes the restriction No_Implicit_Heap_Allocations. 3773 3774 procedure Check_For_Null_Excluding_Components 3775 (Obj_Typ : Entity_Id; 3776 Obj_Decl : Node_Id); 3777 -- Verify that each null-excluding component of object declaration 3778 -- Obj_Decl carrying type Obj_Typ has explicit initialization. Emit 3779 -- a compile-time warning if this is not the case. 3780 3781 function Count_Tasks (T : Entity_Id) return Uint; 3782 -- This function is called when a non-generic library level object of a 3783 -- task type is declared. Its function is to count the static number of 3784 -- tasks declared within the type (it is only called if Has_Task is set 3785 -- for T). As a side effect, if an array of tasks with nonstatic bounds 3786 -- or a variant record type is encountered, Check_Restriction is called 3787 -- indicating the count is unknown. 3788 3789 function Delayed_Aspect_Present return Boolean; 3790 -- If the declaration has an expression that is an aggregate, and it 3791 -- has aspects that require delayed analysis, the resolution of the 3792 -- aggregate must be deferred to the freeze point of the object. This 3793 -- special processing was created for address clauses, but it must 3794 -- also apply to address aspects. This must be done before the aspect 3795 -- specifications are analyzed because we must handle the aggregate 3796 -- before the analysis of the object declaration is complete. 3797 3798 -- Any other relevant delayed aspects on object declarations ??? 3799 3800 -------------------------- 3801 -- Check_Dynamic_Object -- 3802 -------------------------- 3803 3804 procedure Check_Dynamic_Object (Typ : Entity_Id) is 3805 Comp : Entity_Id; 3806 Obj_Type : Entity_Id; 3807 3808 begin 3809 Obj_Type := Typ; 3810 3811 if Is_Private_Type (Obj_Type) 3812 and then Present (Full_View (Obj_Type)) 3813 then 3814 Obj_Type := Full_View (Obj_Type); 3815 end if; 3816 3817 if Known_Static_Esize (Obj_Type) then 3818 return; 3819 end if; 3820 3821 if Restriction_Active (No_Implicit_Heap_Allocations) 3822 and then Expander_Active 3823 and then Has_Discriminants (Obj_Type) 3824 then 3825 Comp := First_Component (Obj_Type); 3826 while Present (Comp) loop 3827 if Known_Static_Esize (Etype (Comp)) 3828 or else Size_Known_At_Compile_Time (Etype (Comp)) 3829 then 3830 null; 3831 3832 elsif not Discriminated_Size (Comp) 3833 and then Comes_From_Source (Comp) 3834 then 3835 Error_Msg_NE 3836 ("component& of non-static size will violate restriction " 3837 & "No_Implicit_Heap_Allocation?", N, Comp); 3838 3839 elsif Is_Record_Type (Etype (Comp)) then 3840 Check_Dynamic_Object (Etype (Comp)); 3841 end if; 3842 3843 Next_Component (Comp); 3844 end loop; 3845 end if; 3846 end Check_Dynamic_Object; 3847 3848 ----------------------------------------- 3849 -- Check_For_Null_Excluding_Components -- 3850 ----------------------------------------- 3851 3852 procedure Check_For_Null_Excluding_Components 3853 (Obj_Typ : Entity_Id; 3854 Obj_Decl : Node_Id) 3855 is 3856 procedure Check_Component 3857 (Comp_Typ : Entity_Id; 3858 Comp_Decl : Node_Id := Empty; 3859 Array_Comp : Boolean := False); 3860 -- Apply a compile-time null-exclusion check on a component denoted 3861 -- by its declaration Comp_Decl and type Comp_Typ, and all of its 3862 -- subcomponents (if any). 3863 3864 --------------------- 3865 -- Check_Component -- 3866 --------------------- 3867 3868 procedure Check_Component 3869 (Comp_Typ : Entity_Id; 3870 Comp_Decl : Node_Id := Empty; 3871 Array_Comp : Boolean := False) 3872 is 3873 Comp : Entity_Id; 3874 T : Entity_Id; 3875 3876 begin 3877 -- Do not consider internally-generated components or those that 3878 -- are already initialized. 3879 3880 if Present (Comp_Decl) 3881 and then (not Comes_From_Source (Comp_Decl) 3882 or else Present (Expression (Comp_Decl))) 3883 then 3884 return; 3885 end if; 3886 3887 if Is_Incomplete_Or_Private_Type (Comp_Typ) 3888 and then Present (Full_View (Comp_Typ)) 3889 then 3890 T := Full_View (Comp_Typ); 3891 else 3892 T := Comp_Typ; 3893 end if; 3894 3895 -- Verify a component of a null-excluding access type 3896 3897 if Is_Access_Type (T) 3898 and then Can_Never_Be_Null (T) 3899 then 3900 if Comp_Decl = Obj_Decl then 3901 Null_Exclusion_Static_Checks 3902 (N => Obj_Decl, 3903 Comp => Empty, 3904 Array_Comp => Array_Comp); 3905 3906 else 3907 Null_Exclusion_Static_Checks 3908 (N => Obj_Decl, 3909 Comp => Comp_Decl, 3910 Array_Comp => Array_Comp); 3911 end if; 3912 3913 -- Check array components 3914 3915 elsif Is_Array_Type (T) then 3916 3917 -- There is no suitable component when the object is of an 3918 -- array type. However, a namable component may appear at some 3919 -- point during the recursive inspection, but not at the top 3920 -- level. At the top level just indicate array component case. 3921 3922 if Comp_Decl = Obj_Decl then 3923 Check_Component (Component_Type (T), Array_Comp => True); 3924 else 3925 Check_Component (Component_Type (T), Comp_Decl); 3926 end if; 3927 3928 -- Verify all components of type T 3929 3930 -- Note: No checks are performed on types with discriminants due 3931 -- to complexities involving variants. ??? 3932 3933 elsif (Is_Concurrent_Type (T) 3934 or else Is_Incomplete_Or_Private_Type (T) 3935 or else Is_Record_Type (T)) 3936 and then not Has_Discriminants (T) 3937 then 3938 Comp := First_Component (T); 3939 while Present (Comp) loop 3940 Check_Component (Etype (Comp), Parent (Comp)); 3941 3942 Next_Component (Comp); 3943 end loop; 3944 end if; 3945 end Check_Component; 3946 3947 -- Start processing for Check_For_Null_Excluding_Components 3948 3949 begin 3950 Check_Component (Obj_Typ, Obj_Decl); 3951 end Check_For_Null_Excluding_Components; 3952 3953 ----------------- 3954 -- Count_Tasks -- 3955 ----------------- 3956 3957 function Count_Tasks (T : Entity_Id) return Uint is 3958 C : Entity_Id; 3959 X : Node_Id; 3960 V : Uint; 3961 3962 begin 3963 if Is_Task_Type (T) then 3964 return Uint_1; 3965 3966 elsif Is_Record_Type (T) then 3967 if Has_Discriminants (T) then 3968 Check_Restriction (Max_Tasks, N); 3969 return Uint_0; 3970 3971 else 3972 V := Uint_0; 3973 C := First_Component (T); 3974 while Present (C) loop 3975 V := V + Count_Tasks (Etype (C)); 3976 Next_Component (C); 3977 end loop; 3978 3979 return V; 3980 end if; 3981 3982 elsif Is_Array_Type (T) then 3983 X := First_Index (T); 3984 V := Count_Tasks (Component_Type (T)); 3985 while Present (X) loop 3986 C := Etype (X); 3987 3988 if not Is_OK_Static_Subtype (C) then 3989 Check_Restriction (Max_Tasks, N); 3990 return Uint_0; 3991 else 3992 V := V * (UI_Max (Uint_0, 3993 Expr_Value (Type_High_Bound (C)) - 3994 Expr_Value (Type_Low_Bound (C)) + Uint_1)); 3995 end if; 3996 3997 Next_Index (X); 3998 end loop; 3999 4000 return V; 4001 4002 else 4003 return Uint_0; 4004 end if; 4005 end Count_Tasks; 4006 4007 ---------------------------- 4008 -- Delayed_Aspect_Present -- 4009 ---------------------------- 4010 4011 function Delayed_Aspect_Present return Boolean is 4012 A : Node_Id; 4013 A_Id : Aspect_Id; 4014 4015 begin 4016 if Present (Aspect_Specifications (N)) then 4017 A := First (Aspect_Specifications (N)); 4018 4019 while Present (A) loop 4020 A_Id := Get_Aspect_Id (Chars (Identifier (A))); 4021 4022 if A_Id = Aspect_Address then 4023 4024 -- Set flag on object entity, for later processing at 4025 -- the freeze point. 4026 4027 Set_Has_Delayed_Aspects (Id); 4028 return True; 4029 end if; 4030 4031 Next (A); 4032 end loop; 4033 end if; 4034 4035 return False; 4036 end Delayed_Aspect_Present; 4037 4038 -- Local variables 4039 4040 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 4041 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 4042 -- Save the Ghost-related attributes to restore on exit 4043 4044 Prev_Entity : Entity_Id := Empty; 4045 Related_Id : Entity_Id; 4046 Full_View_Present : Boolean := False; 4047 4048 -- Start of processing for Analyze_Object_Declaration 4049 4050 begin 4051 -- There are three kinds of implicit types generated by an 4052 -- object declaration: 4053 4054 -- 1. Those generated by the original Object Definition 4055 4056 -- 2. Those generated by the Expression 4057 4058 -- 3. Those used to constrain the Object Definition with the 4059 -- expression constraints when the definition is unconstrained. 4060 4061 -- They must be generated in this order to avoid order of elaboration 4062 -- issues. Thus the first step (after entering the name) is to analyze 4063 -- the object definition. 4064 4065 if Constant_Present (N) then 4066 Prev_Entity := Current_Entity_In_Scope (Id); 4067 4068 if Present (Prev_Entity) 4069 and then 4070 -- If the homograph is an implicit subprogram, it is overridden 4071 -- by the current declaration. 4072 4073 ((Is_Overloadable (Prev_Entity) 4074 and then Is_Inherited_Operation (Prev_Entity)) 4075 4076 -- The current object is a discriminal generated for an entry 4077 -- family index. Even though the index is a constant, in this 4078 -- particular context there is no true constant redeclaration. 4079 -- Enter_Name will handle the visibility. 4080 4081 or else 4082 (Is_Discriminal (Id) 4083 and then Ekind (Discriminal_Link (Id)) = 4084 E_Entry_Index_Parameter) 4085 4086 -- The current object is the renaming for a generic declared 4087 -- within the instance. 4088 4089 or else 4090 (Ekind (Prev_Entity) = E_Package 4091 and then Nkind (Parent (Prev_Entity)) = 4092 N_Package_Renaming_Declaration 4093 and then not Comes_From_Source (Prev_Entity) 4094 and then 4095 Is_Generic_Instance (Renamed_Entity (Prev_Entity))) 4096 4097 -- The entity may be a homonym of a private component of the 4098 -- enclosing protected object, for which we create a local 4099 -- renaming declaration. The declaration is legal, even if 4100 -- useless when it just captures that component. 4101 4102 or else 4103 (Ekind (Scope (Current_Scope)) = E_Protected_Type 4104 and then Nkind (Parent (Prev_Entity)) = 4105 N_Object_Renaming_Declaration)) 4106 then 4107 Prev_Entity := Empty; 4108 end if; 4109 end if; 4110 4111 if Present (Prev_Entity) then 4112 4113 -- The object declaration is Ghost when it completes a deferred Ghost 4114 -- constant. 4115 4116 Mark_And_Set_Ghost_Completion (N, Prev_Entity); 4117 4118 Constant_Redeclaration (Id, N, T); 4119 4120 Generate_Reference (Prev_Entity, Id, 'c'); 4121 Set_Completion_Referenced (Id); 4122 4123 if Error_Posted (N) then 4124 4125 -- Type mismatch or illegal redeclaration; do not analyze 4126 -- expression to avoid cascaded errors. 4127 4128 T := Find_Type_Of_Object (Object_Definition (N), N); 4129 Set_Etype (Id, T); 4130 Mutate_Ekind (Id, E_Variable); 4131 goto Leave; 4132 end if; 4133 4134 -- In the normal case, enter identifier at the start to catch premature 4135 -- usage in the initialization expression. 4136 4137 else 4138 Generate_Definition (Id); 4139 Enter_Name (Id); 4140 4141 Mark_Coextensions (N, Object_Definition (N)); 4142 4143 T := Find_Type_Of_Object (Object_Definition (N), N); 4144 4145 if Nkind (Object_Definition (N)) = N_Access_Definition 4146 and then Present 4147 (Access_To_Subprogram_Definition (Object_Definition (N))) 4148 and then Protected_Present 4149 (Access_To_Subprogram_Definition (Object_Definition (N))) 4150 then 4151 T := Replace_Anonymous_Access_To_Protected_Subprogram (N); 4152 end if; 4153 4154 if Error_Posted (Id) then 4155 Set_Etype (Id, T); 4156 Mutate_Ekind (Id, E_Variable); 4157 goto Leave; 4158 end if; 4159 end if; 4160 4161 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry 4162 -- out some static checks. 4163 4164 if Ada_Version >= Ada_2005 then 4165 4166 -- In case of aggregates we must also take care of the correct 4167 -- initialization of nested aggregates bug this is done at the 4168 -- point of the analysis of the aggregate (see sem_aggr.adb) ??? 4169 4170 if Can_Never_Be_Null (T) then 4171 if Present (Expression (N)) 4172 and then Nkind (Expression (N)) = N_Aggregate 4173 then 4174 null; 4175 4176 elsif Comes_From_Source (Id) then 4177 declare 4178 Save_Typ : constant Entity_Id := Etype (Id); 4179 begin 4180 Set_Etype (Id, T); -- Temp. decoration for static checks 4181 Null_Exclusion_Static_Checks (N); 4182 Set_Etype (Id, Save_Typ); 4183 end; 4184 end if; 4185 4186 -- We might be dealing with an object of a composite type containing 4187 -- null-excluding components without an aggregate, so we must verify 4188 -- that such components have default initialization. 4189 4190 else 4191 Check_For_Null_Excluding_Components (T, N); 4192 end if; 4193 end if; 4194 4195 -- Object is marked pure if it is in a pure scope 4196 4197 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 4198 4199 -- If deferred constant, make sure context is appropriate. We detect 4200 -- a deferred constant as a constant declaration with no expression. 4201 -- A deferred constant can appear in a package body if its completion 4202 -- is by means of an interface pragma. 4203 4204 if Constant_Present (N) and then No (E) then 4205 4206 -- A deferred constant may appear in the declarative part of the 4207 -- following constructs: 4208 4209 -- blocks 4210 -- entry bodies 4211 -- extended return statements 4212 -- package specs 4213 -- package bodies 4214 -- subprogram bodies 4215 -- task bodies 4216 4217 -- When declared inside a package spec, a deferred constant must be 4218 -- completed by a full constant declaration or pragma Import. In all 4219 -- other cases, the only proper completion is pragma Import. Extended 4220 -- return statements are flagged as invalid contexts because they do 4221 -- not have a declarative part and so cannot accommodate the pragma. 4222 4223 if Ekind (Current_Scope) = E_Return_Statement then 4224 Error_Msg_N 4225 ("invalid context for deferred constant declaration (RM 7.4)", 4226 N); 4227 Error_Msg_N 4228 ("\declaration requires an initialization expression", 4229 N); 4230 Set_Constant_Present (N, False); 4231 4232 -- In Ada 83, deferred constant must be of private type 4233 4234 elsif not Is_Private_Type (T) then 4235 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 4236 Error_Msg_N 4237 ("(Ada 83) deferred constant must be private type", N); 4238 end if; 4239 end if; 4240 4241 -- If not a deferred constant, then the object declaration freezes 4242 -- its type, unless the object is of an anonymous type and has delayed 4243 -- aspects. In that case the type is frozen when the object itself is. 4244 4245 else 4246 Check_Fully_Declared (T, N); 4247 4248 if Has_Delayed_Aspects (Id) 4249 and then Is_Array_Type (T) 4250 and then Is_Itype (T) 4251 then 4252 Set_Has_Delayed_Freeze (T); 4253 else 4254 Freeze_Before (N, T); 4255 end if; 4256 end if; 4257 4258 -- If the object was created by a constrained array definition, then 4259 -- set the link in both the anonymous base type and anonymous subtype 4260 -- that are built to represent the array type to point to the object. 4261 4262 if Nkind (Object_Definition (Declaration_Node (Id))) = 4263 N_Constrained_Array_Definition 4264 then 4265 Set_Related_Array_Object (T, Id); 4266 Set_Related_Array_Object (Base_Type (T), Id); 4267 end if; 4268 4269 -- Check for protected objects not at library level 4270 4271 if Has_Protected (T) and then not Is_Library_Level_Entity (Id) then 4272 Check_Restriction (No_Local_Protected_Objects, Id); 4273 end if; 4274 4275 -- Check for violation of No_Local_Timing_Events 4276 4277 if Has_Timing_Event (T) and then not Is_Library_Level_Entity (Id) then 4278 Check_Restriction (No_Local_Timing_Events, Id); 4279 end if; 4280 4281 -- The actual subtype of the object is the nominal subtype, unless 4282 -- the nominal one is unconstrained and obtained from the expression. 4283 4284 Act_T := T; 4285 4286 if Is_Library_Level_Entity (Id) then 4287 Check_Dynamic_Object (T); 4288 end if; 4289 4290 -- Process initialization expression if present and not in error 4291 4292 if Present (E) and then E /= Error then 4293 4294 -- Generate an error in case of CPP class-wide object initialization. 4295 -- Required because otherwise the expansion of the class-wide 4296 -- assignment would try to use 'size to initialize the object 4297 -- (primitive that is not available in CPP tagged types). 4298 4299 if Is_Class_Wide_Type (Act_T) 4300 and then 4301 (Is_CPP_Class (Root_Type (Etype (Act_T))) 4302 or else 4303 (Present (Full_View (Root_Type (Etype (Act_T)))) 4304 and then 4305 Is_CPP_Class (Full_View (Root_Type (Etype (Act_T)))))) 4306 then 4307 Error_Msg_N 4308 ("predefined assignment not available for 'C'P'P tagged types", 4309 E); 4310 end if; 4311 4312 Mark_Coextensions (N, E); 4313 Analyze (E); 4314 4315 -- In case of errors detected in the analysis of the expression, 4316 -- decorate it with the expected type to avoid cascaded errors. 4317 4318 if No (Etype (E)) then 4319 Set_Etype (E, T); 4320 end if; 4321 4322 -- If an initialization expression is present, then we set the 4323 -- Is_True_Constant flag. It will be reset if this is a variable 4324 -- and it is indeed modified. 4325 4326 Set_Is_True_Constant (Id, True); 4327 4328 -- If we are analyzing a constant declaration, set its completion 4329 -- flag after analyzing and resolving the expression. 4330 4331 if Constant_Present (N) then 4332 Set_Has_Completion (Id); 4333 end if; 4334 4335 -- Set type and resolve (type may be overridden later on). Note: 4336 -- Ekind (Id) must still be E_Void at this point so that incorrect 4337 -- early usage within E is properly diagnosed. 4338 4339 Set_Etype (Id, T); 4340 4341 -- If the expression is an aggregate we must look ahead to detect 4342 -- the possible presence of an address clause, and defer resolution 4343 -- and expansion of the aggregate to the freeze point of the entity. 4344 4345 -- This is not always legal because the aggregate may contain other 4346 -- references that need freezing, e.g. references to other entities 4347 -- with address clauses. In any case, when compiling with -gnatI the 4348 -- presence of the address clause must be ignored. 4349 4350 if Comes_From_Source (N) 4351 and then Expander_Active 4352 and then Nkind (E) = N_Aggregate 4353 and then 4354 ((Present (Following_Address_Clause (N)) 4355 and then not Ignore_Rep_Clauses) 4356 or else Delayed_Aspect_Present) 4357 then 4358 Set_Etype (E, T); 4359 4360 -- If the aggregate is limited it will be built in place, and its 4361 -- expansion is deferred until the object declaration is expanded. 4362 4363 -- This is also required when generating C code to ensure that an 4364 -- object with an alignment or address clause can be initialized 4365 -- by means of component by component assignments. 4366 4367 if Is_Limited_Type (T) or else Modify_Tree_For_C then 4368 Set_Expansion_Delayed (E); 4369 end if; 4370 4371 else 4372 -- If the expression is a formal that is a "subprogram pointer" 4373 -- this is illegal in accessibility terms (see RM 3.10.2 (13.1/2) 4374 -- and AARM 3.10.2 (13.b/2)). Add an explicit conversion to force 4375 -- the corresponding check, as is done for assignments. 4376 4377 if Is_Entity_Name (E) 4378 and then Present (Entity (E)) 4379 and then Is_Formal (Entity (E)) 4380 and then 4381 Ekind (Etype (Entity (E))) = E_Anonymous_Access_Subprogram_Type 4382 and then Ekind (T) /= E_Anonymous_Access_Subprogram_Type 4383 then 4384 Rewrite (E, Convert_To (T, Relocate_Node (E))); 4385 end if; 4386 4387 Resolve (E, T); 4388 end if; 4389 4390 -- No further action needed if E is a call to an inlined function 4391 -- which returns an unconstrained type and it has been expanded into 4392 -- a procedure call. In that case N has been replaced by an object 4393 -- declaration without initializing expression and it has been 4394 -- analyzed (see Expand_Inlined_Call). 4395 4396 if Back_End_Inlining 4397 and then Expander_Active 4398 and then Nkind (E) = N_Function_Call 4399 and then Nkind (Name (E)) in N_Has_Entity 4400 and then Is_Inlined (Entity (Name (E))) 4401 and then not Is_Constrained (Etype (E)) 4402 and then Analyzed (N) 4403 and then No (Expression (N)) 4404 then 4405 goto Leave; 4406 end if; 4407 4408 -- If E is null and has been replaced by an N_Raise_Constraint_Error 4409 -- node (which was marked already-analyzed), we need to set the type 4410 -- to something other than Any_Access in order to keep gigi happy. 4411 4412 if Etype (E) = Any_Access then 4413 Set_Etype (E, T); 4414 end if; 4415 4416 -- If the object is an access to variable, the initialization 4417 -- expression cannot be an access to constant. 4418 4419 if Is_Access_Type (T) 4420 and then not Is_Access_Constant (T) 4421 and then Is_Access_Type (Etype (E)) 4422 and then Is_Access_Constant (Etype (E)) 4423 then 4424 Error_Msg_N 4425 ("access to variable cannot be initialized with an " 4426 & "access-to-constant expression", E); 4427 end if; 4428 4429 if not Assignment_OK (N) then 4430 Check_Initialization (T, E); 4431 end if; 4432 4433 Check_Unset_Reference (E); 4434 4435 -- If this is a variable, then set current value. If this is a 4436 -- declared constant of a scalar type with a static expression, 4437 -- indicate that it is always valid. 4438 4439 if not Constant_Present (N) then 4440 if Compile_Time_Known_Value (E) then 4441 Set_Current_Value (Id, E); 4442 end if; 4443 4444 elsif Is_Scalar_Type (T) and then Is_OK_Static_Expression (E) then 4445 Set_Is_Known_Valid (Id); 4446 4447 -- If it is a constant initialized with a valid nonstatic entity, 4448 -- the constant is known valid as well, and can inherit the subtype 4449 -- of the entity if it is a subtype of the given type. This info 4450 -- is preserved on the actual subtype of the constant. 4451 4452 elsif Is_Scalar_Type (T) 4453 and then Is_Entity_Name (E) 4454 and then Is_Known_Valid (Entity (E)) 4455 and then In_Subrange_Of (Etype (Entity (E)), T) 4456 then 4457 Set_Is_Known_Valid (Id); 4458 Mutate_Ekind (Id, E_Constant); 4459 Set_Actual_Subtype (Id, Etype (Entity (E))); 4460 end if; 4461 4462 -- Deal with setting of null flags 4463 4464 if Is_Access_Type (T) then 4465 if Known_Non_Null (E) then 4466 Set_Is_Known_Non_Null (Id, True); 4467 elsif Known_Null (E) and then not Can_Never_Be_Null (Id) then 4468 Set_Is_Known_Null (Id, True); 4469 end if; 4470 end if; 4471 4472 -- Check incorrect use of dynamically tagged expressions 4473 4474 if Is_Tagged_Type (T) then 4475 Check_Dynamically_Tagged_Expression 4476 (Expr => E, 4477 Typ => T, 4478 Related_Nod => N); 4479 end if; 4480 4481 Apply_Scalar_Range_Check (E, T); 4482 Apply_Static_Length_Check (E, T); 4483 4484 -- A formal parameter of a specific tagged type whose related 4485 -- subprogram is subject to pragma Extensions_Visible with value 4486 -- "False" cannot be implicitly converted to a class-wide type by 4487 -- means of an initialization expression (SPARK RM 6.1.7(3)). Do 4488 -- not consider internally generated expressions. 4489 4490 if Is_Class_Wide_Type (T) 4491 and then Comes_From_Source (E) 4492 and then Is_EVF_Expression (E) 4493 then 4494 Error_Msg_N 4495 ("formal parameter cannot be implicitly converted to " 4496 & "class-wide type when Extensions_Visible is False", E); 4497 end if; 4498 end if; 4499 4500 -- If the No_Streams restriction is set, check that the type of the 4501 -- object is not, and does not contain, any subtype derived from 4502 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to 4503 -- Has_Stream just for efficiency reasons. There is no point in 4504 -- spending time on a Has_Stream check if the restriction is not set. 4505 4506 if Restriction_Check_Required (No_Streams) then 4507 if Has_Stream (T) then 4508 Check_Restriction (No_Streams, N); 4509 end if; 4510 end if; 4511 4512 -- Deal with predicate check before we start to do major rewriting. It 4513 -- is OK to initialize and then check the initialized value, since the 4514 -- object goes out of scope if we get a predicate failure. Note that we 4515 -- do this in the analyzer and not the expander because the analyzer 4516 -- does some substantial rewriting in some cases. 4517 4518 -- We need a predicate check if the type has predicates that are not 4519 -- ignored, and if either there is an initializing expression, or for 4520 -- default initialization when we have at least one case of an explicit 4521 -- default initial value (including via a Default_Value or 4522 -- Default_Component_Value aspect, see AI12-0301) and then this is not 4523 -- an internal declaration whose initialization comes later (as for an 4524 -- aggregate expansion) or a deferred constant. 4525 -- If expression is an aggregate it may be expanded into assignments 4526 -- and the declaration itself is marked with No_Initialization, but 4527 -- the predicate still applies. 4528 4529 if not Suppress_Assignment_Checks (N) 4530 and then (Predicate_Enabled (T) or else Has_Static_Predicate (T)) 4531 and then 4532 (not No_Initialization (N) 4533 or else (Present (E) and then Nkind (E) = N_Aggregate)) 4534 and then 4535 (Present (E) 4536 or else 4537 Is_Partially_Initialized_Type (T, Include_Implicit => False)) 4538 and then not (Constant_Present (N) and then No (E)) 4539 then 4540 -- If the type has a static predicate and the expression is known at 4541 -- compile time, see if the expression satisfies the predicate. 4542 -- In the case of a static expression, this must be done even if 4543 -- the predicate is not enabled (as per static expression rules). 4544 4545 if Present (E) then 4546 Check_Expression_Against_Static_Predicate (E, T); 4547 end if; 4548 4549 -- Do not perform further predicate-related checks unless 4550 -- predicates are enabled for the subtype. 4551 4552 if not Predicate_Enabled (T) then 4553 null; 4554 4555 -- If the type is a null record and there is no explicit initial 4556 -- expression, no predicate check applies. 4557 4558 elsif No (E) and then Is_Null_Record_Type (T) then 4559 null; 4560 4561 -- Do not generate a predicate check if the initialization expression 4562 -- is a type conversion because the conversion has been subjected to 4563 -- the same check. This is a small optimization which avoid redundant 4564 -- checks. 4565 4566 elsif Present (E) and then Nkind (E) = N_Type_Conversion then 4567 null; 4568 4569 else 4570 -- The check must be inserted after the expanded aggregate 4571 -- expansion code, if any. 4572 4573 declare 4574 Check : constant Node_Id := 4575 Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)); 4576 4577 begin 4578 if No (Next_Decl) then 4579 Append_To (List_Containing (N), Check); 4580 else 4581 Insert_Before (Next_Decl, Check); 4582 end if; 4583 end; 4584 end if; 4585 end if; 4586 4587 -- Case of unconstrained type 4588 4589 if not Is_Definite_Subtype (T) then 4590 4591 -- Nothing to do in deferred constant case 4592 4593 if Constant_Present (N) and then No (E) then 4594 null; 4595 4596 -- Case of no initialization present 4597 4598 elsif No (E) then 4599 if No_Initialization (N) then 4600 null; 4601 4602 elsif Is_Class_Wide_Type (T) then 4603 Error_Msg_N 4604 ("initialization required in class-wide declaration", N); 4605 4606 else 4607 Error_Msg_N 4608 ("unconstrained subtype not allowed (need initialization)", 4609 Object_Definition (N)); 4610 4611 if Is_Record_Type (T) and then Has_Discriminants (T) then 4612 Error_Msg_N 4613 ("\provide initial value or explicit discriminant values", 4614 Object_Definition (N)); 4615 4616 Error_Msg_NE 4617 ("\or give default discriminant values for type&", 4618 Object_Definition (N), T); 4619 4620 elsif Is_Array_Type (T) then 4621 Error_Msg_N 4622 ("\provide initial value or explicit array bounds", 4623 Object_Definition (N)); 4624 end if; 4625 end if; 4626 4627 -- Case of initialization present but in error. Set initial 4628 -- expression as absent (but do not make above complaints). 4629 4630 elsif E = Error then 4631 Set_Expression (N, Empty); 4632 E := Empty; 4633 4634 -- Case of initialization present 4635 4636 else 4637 -- Unconstrained variables not allowed in Ada 83 4638 4639 if Ada_Version = Ada_83 4640 and then not Constant_Present (N) 4641 and then Comes_From_Source (Object_Definition (N)) 4642 then 4643 Error_Msg_N 4644 ("(Ada 83) unconstrained variable not allowed", 4645 Object_Definition (N)); 4646 end if; 4647 4648 -- Now we constrain the variable from the initializing expression 4649 4650 -- If the expression is an aggregate, it has been expanded into 4651 -- individual assignments. Retrieve the actual type from the 4652 -- expanded construct. 4653 4654 if Is_Array_Type (T) 4655 and then No_Initialization (N) 4656 and then Nkind (Original_Node (E)) = N_Aggregate 4657 then 4658 Act_T := Etype (E); 4659 4660 -- In case of class-wide interface object declarations we delay 4661 -- the generation of the equivalent record type declarations until 4662 -- its expansion because there are cases in they are not required. 4663 4664 elsif Is_Interface (T) then 4665 null; 4666 4667 -- If the type is an unchecked union, no subtype can be built from 4668 -- the expression. Rewrite declaration as a renaming, which the 4669 -- back-end can handle properly. This is a rather unusual case, 4670 -- because most unchecked_union declarations have default values 4671 -- for discriminants and are thus not indefinite. 4672 4673 elsif Is_Unchecked_Union (T) then 4674 if Constant_Present (N) or else Nkind (E) = N_Function_Call then 4675 Mutate_Ekind (Id, E_Constant); 4676 else 4677 Mutate_Ekind (Id, E_Variable); 4678 end if; 4679 4680 -- If the expression is an aggregate it contains the required 4681 -- discriminant values but it has not been resolved yet, so do 4682 -- it now, and treat it as the initial expression of an object 4683 -- declaration, rather than a renaming. 4684 4685 if Nkind (E) = N_Aggregate then 4686 Analyze_And_Resolve (E, T); 4687 4688 else 4689 Rewrite (N, 4690 Make_Object_Renaming_Declaration (Loc, 4691 Defining_Identifier => Id, 4692 Subtype_Mark => New_Occurrence_Of (T, Loc), 4693 Name => E)); 4694 4695 Set_Renamed_Object (Id, E); 4696 Freeze_Before (N, T); 4697 Set_Is_Frozen (Id); 4698 goto Leave; 4699 end if; 4700 4701 else 4702 -- Ensure that the generated subtype has a unique external name 4703 -- when the related object is public. This guarantees that the 4704 -- subtype and its bounds will not be affected by switches or 4705 -- pragmas that may offset the internal counter due to extra 4706 -- generated code. 4707 4708 if Is_Public (Id) then 4709 Related_Id := Id; 4710 else 4711 Related_Id := Empty; 4712 end if; 4713 4714 -- If the object has an unconstrained array subtype with fixed 4715 -- lower bound, then sliding to that bound may be needed. 4716 4717 if Is_Fixed_Lower_Bound_Array_Subtype (T) then 4718 Expand_Sliding_Conversion (E, T); 4719 end if; 4720 4721 Expand_Subtype_From_Expr 4722 (N => N, 4723 Unc_Type => T, 4724 Subtype_Indic => Object_Definition (N), 4725 Exp => E, 4726 Related_Id => Related_Id); 4727 4728 Act_T := Find_Type_Of_Object (Object_Definition (N), N); 4729 end if; 4730 4731 -- Propagate attributes to full view when needed 4732 4733 Set_Is_Constr_Subt_For_U_Nominal (Act_T); 4734 4735 if Is_Private_Type (Act_T) and then Present (Full_View (Act_T)) 4736 then 4737 Full_View_Present := True; 4738 end if; 4739 4740 if Full_View_Present then 4741 Set_Is_Constr_Subt_For_U_Nominal (Full_View (Act_T)); 4742 end if; 4743 4744 if Aliased_Present (N) then 4745 Set_Is_Constr_Subt_For_UN_Aliased (Act_T); 4746 4747 if Full_View_Present then 4748 Set_Is_Constr_Subt_For_UN_Aliased (Full_View (Act_T)); 4749 end if; 4750 end if; 4751 4752 Freeze_Before (N, Act_T); 4753 Freeze_Before (N, T); 4754 end if; 4755 4756 elsif Is_Array_Type (T) 4757 and then No_Initialization (N) 4758 and then (Nkind (Original_Node (E)) = N_Aggregate 4759 or else (Nkind (Original_Node (E)) = N_Qualified_Expression 4760 and then Nkind (Original_Node (Expression 4761 (Original_Node (E)))) = N_Aggregate)) 4762 then 4763 if not Is_Entity_Name (Object_Definition (N)) then 4764 Act_T := Etype (E); 4765 Check_Compile_Time_Size (Act_T); 4766 4767 if Aliased_Present (N) then 4768 Set_Is_Constr_Subt_For_UN_Aliased (Act_T); 4769 end if; 4770 end if; 4771 4772 -- When the given object definition and the aggregate are specified 4773 -- independently, and their lengths might differ do a length check. 4774 -- This cannot happen if the aggregate is of the form (others =>...) 4775 4776 if not Is_Constrained (T) then 4777 null; 4778 4779 elsif Nkind (E) = N_Raise_Constraint_Error then 4780 4781 -- Aggregate is statically illegal. Place back in declaration 4782 4783 Set_Expression (N, E); 4784 Set_No_Initialization (N, False); 4785 4786 elsif T = Etype (E) then 4787 null; 4788 4789 elsif Nkind (E) = N_Aggregate 4790 and then Present (Component_Associations (E)) 4791 and then Present (Choice_List (First (Component_Associations (E)))) 4792 and then 4793 Nkind (First (Choice_List (First (Component_Associations (E))))) = 4794 N_Others_Choice 4795 then 4796 null; 4797 4798 else 4799 Apply_Length_Check (E, T); 4800 end if; 4801 4802 -- If the type is limited unconstrained with defaulted discriminants and 4803 -- there is no expression, then the object is constrained by the 4804 -- defaults, so it is worthwhile building the corresponding subtype. 4805 4806 elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T)) 4807 and then not Is_Constrained (T) 4808 and then Has_Discriminants (T) 4809 then 4810 if No (E) then 4811 Act_T := Build_Default_Subtype (T, N); 4812 else 4813 -- Ada 2005: A limited object may be initialized by means of an 4814 -- aggregate. If the type has default discriminants it has an 4815 -- unconstrained nominal type, Its actual subtype will be obtained 4816 -- from the aggregate, and not from the default discriminants. 4817 4818 Act_T := Etype (E); 4819 end if; 4820 4821 Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc)); 4822 4823 elsif Nkind (E) = N_Function_Call 4824 and then Constant_Present (N) 4825 and then Has_Unconstrained_Elements (Etype (E)) 4826 then 4827 -- The back-end has problems with constants of a discriminated type 4828 -- with defaults, if the initial value is a function call. We 4829 -- generate an intermediate temporary that will receive a reference 4830 -- to the result of the call. The initialization expression then 4831 -- becomes a dereference of that temporary. 4832 4833 Remove_Side_Effects (E); 4834 4835 -- If this is a constant declaration of an unconstrained type and 4836 -- the initialization is an aggregate, we can use the subtype of the 4837 -- aggregate for the declared entity because it is immutable. 4838 4839 elsif not Is_Constrained (T) 4840 and then Has_Discriminants (T) 4841 and then Constant_Present (N) 4842 and then not Has_Unchecked_Union (T) 4843 and then Nkind (E) = N_Aggregate 4844 then 4845 Act_T := Etype (E); 4846 end if; 4847 4848 -- Check No_Wide_Characters restriction 4849 4850 Check_Wide_Character_Restriction (T, Object_Definition (N)); 4851 4852 -- Indicate this is not set in source. Certainly true for constants, and 4853 -- true for variables so far (will be reset for a variable if and when 4854 -- we encounter a modification in the source). 4855 4856 Set_Never_Set_In_Source (Id); 4857 4858 -- Now establish the proper kind and type of the object 4859 4860 if Ekind (Id) = E_Void then 4861 Reinit_Field_To_Zero (Id, F_Next_Inlined_Subprogram); 4862 end if; 4863 4864 if Constant_Present (N) then 4865 Mutate_Ekind (Id, E_Constant); 4866 Set_Is_True_Constant (Id); 4867 4868 else 4869 Mutate_Ekind (Id, E_Variable); 4870 4871 -- A variable is set as shared passive if it appears in a shared 4872 -- passive package, and is at the outer level. This is not done for 4873 -- entities generated during expansion, because those are always 4874 -- manipulated locally. 4875 4876 if Is_Shared_Passive (Current_Scope) 4877 and then Is_Library_Level_Entity (Id) 4878 and then Comes_From_Source (Id) 4879 then 4880 Set_Is_Shared_Passive (Id); 4881 Check_Shared_Var (Id, T, N); 4882 end if; 4883 4884 -- Set Has_Initial_Value if initializing expression present. Note 4885 -- that if there is no initializing expression, we leave the state 4886 -- of this flag unchanged (usually it will be False, but notably in 4887 -- the case of exception choice variables, it will already be true). 4888 4889 if Present (E) then 4890 Set_Has_Initial_Value (Id); 4891 end if; 4892 end if; 4893 4894 -- Set the SPARK mode from the current context (may be overwritten later 4895 -- with explicit pragma). 4896 4897 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); 4898 Set_SPARK_Pragma_Inherited (Id); 4899 4900 -- Preserve relevant elaboration-related attributes of the context which 4901 -- are no longer available or very expensive to recompute once analysis, 4902 -- resolution, and expansion are over. 4903 4904 Mark_Elaboration_Attributes 4905 (N_Id => Id, 4906 Checks => True, 4907 Warnings => True); 4908 4909 -- Initialize alignment and size and capture alignment setting 4910 4911 Reinit_Alignment (Id); 4912 Reinit_Esize (Id); 4913 Set_Optimize_Alignment_Flags (Id); 4914 4915 -- Deal with aliased case 4916 4917 if Aliased_Present (N) then 4918 Set_Is_Aliased (Id); 4919 4920 -- AI12-001: All aliased objects are considered to be specified as 4921 -- independently addressable (RM C.6(8.1/4)). 4922 4923 Set_Is_Independent (Id); 4924 4925 -- If the object is aliased and the type is unconstrained with 4926 -- defaulted discriminants and there is no expression, then the 4927 -- object is constrained by the defaults, so it is worthwhile 4928 -- building the corresponding subtype. 4929 4930 -- Ada 2005 (AI-363): If the aliased object is discriminated and 4931 -- unconstrained, then only establish an actual subtype if the 4932 -- nominal subtype is indefinite. In definite cases the object is 4933 -- unconstrained in Ada 2005. 4934 4935 if No (E) 4936 and then Is_Record_Type (T) 4937 and then not Is_Constrained (T) 4938 and then Has_Discriminants (T) 4939 and then (Ada_Version < Ada_2005 4940 or else not Is_Definite_Subtype (T)) 4941 then 4942 Set_Actual_Subtype (Id, Build_Default_Subtype (T, N)); 4943 end if; 4944 end if; 4945 4946 -- Now we can set the type of the object 4947 4948 Set_Etype (Id, Act_T); 4949 4950 -- Non-constant object is marked to be treated as volatile if type is 4951 -- volatile and we clear the Current_Value setting that may have been 4952 -- set above. Doing so for constants isn't required and might interfere 4953 -- with possible uses of the object as a static expression in contexts 4954 -- incompatible with volatility (e.g. as a case-statement alternative). 4955 4956 if Ekind (Id) /= E_Constant and then Treat_As_Volatile (Etype (Id)) then 4957 Set_Treat_As_Volatile (Id); 4958 Set_Current_Value (Id, Empty); 4959 end if; 4960 4961 -- Deal with controlled types 4962 4963 if Has_Controlled_Component (Etype (Id)) 4964 or else Is_Controlled (Etype (Id)) 4965 then 4966 if not Is_Library_Level_Entity (Id) then 4967 Check_Restriction (No_Nested_Finalization, N); 4968 else 4969 Validate_Controlled_Object (Id); 4970 end if; 4971 end if; 4972 4973 if Has_Task (Etype (Id)) then 4974 Check_Restriction (No_Tasking, N); 4975 4976 -- Deal with counting max tasks 4977 4978 -- Nothing to do if inside a generic 4979 4980 if Inside_A_Generic then 4981 null; 4982 4983 -- If library level entity, then count tasks 4984 4985 elsif Is_Library_Level_Entity (Id) then 4986 Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id))); 4987 4988 -- If not library level entity, then indicate we don't know max 4989 -- tasks and also check task hierarchy restriction and blocking 4990 -- operation (since starting a task is definitely blocking). 4991 4992 else 4993 Check_Restriction (Max_Tasks, N); 4994 Check_Restriction (No_Task_Hierarchy, N); 4995 Check_Potentially_Blocking_Operation (N); 4996 end if; 4997 4998 -- A rather specialized test. If we see two tasks being declared 4999 -- of the same type in the same object declaration, and the task 5000 -- has an entry with an address clause, we know that program error 5001 -- will be raised at run time since we can't have two tasks with 5002 -- entries at the same address. 5003 5004 if Is_Task_Type (Etype (Id)) and then More_Ids (N) then 5005 declare 5006 E : Entity_Id; 5007 5008 begin 5009 E := First_Entity (Etype (Id)); 5010 while Present (E) loop 5011 if Ekind (E) = E_Entry 5012 and then Present (Get_Attribute_Definition_Clause 5013 (E, Attribute_Address)) 5014 then 5015 Error_Msg_Warn := SPARK_Mode /= On; 5016 Error_Msg_N 5017 ("more than one task with same entry address<<", N); 5018 Error_Msg_N ("\Program_Error [<<", N); 5019 Insert_Action (N, 5020 Make_Raise_Program_Error (Loc, 5021 Reason => PE_Duplicated_Entry_Address)); 5022 exit; 5023 end if; 5024 5025 Next_Entity (E); 5026 end loop; 5027 end; 5028 end if; 5029 end if; 5030 5031 -- Some simple constant-propagation: if the expression is a constant 5032 -- string initialized with a literal, share the literal. This avoids 5033 -- a run-time copy. 5034 5035 if Present (E) 5036 and then Is_Entity_Name (E) 5037 and then Ekind (Entity (E)) = E_Constant 5038 and then Base_Type (Etype (E)) = Standard_String 5039 then 5040 declare 5041 Val : constant Node_Id := Constant_Value (Entity (E)); 5042 begin 5043 if Present (Val) and then Nkind (Val) = N_String_Literal then 5044 Rewrite (E, New_Copy (Val)); 5045 end if; 5046 end; 5047 end if; 5048 5049 -- Another optimization: if the nominal subtype is unconstrained and 5050 -- the expression is a function call that returns an unconstrained 5051 -- type, rewrite the declaration as a renaming of the result of the 5052 -- call. The exceptions below are cases where the copy is expected, 5053 -- either by the back end (Aliased case) or by the semantics, as for 5054 -- initializing controlled types or copying tags for class-wide types. 5055 5056 if Present (E) 5057 and then Nkind (E) = N_Explicit_Dereference 5058 and then Nkind (Original_Node (E)) = N_Function_Call 5059 and then not Is_Library_Level_Entity (Id) 5060 and then not Is_Constrained (Underlying_Type (T)) 5061 and then not Is_Aliased (Id) 5062 and then not Is_Class_Wide_Type (T) 5063 and then not Is_Controlled (T) 5064 and then not Has_Controlled_Component (Base_Type (T)) 5065 and then Expander_Active 5066 then 5067 Rewrite (N, 5068 Make_Object_Renaming_Declaration (Loc, 5069 Defining_Identifier => Id, 5070 Access_Definition => Empty, 5071 Subtype_Mark => New_Occurrence_Of 5072 (Base_Type (Etype (Id)), Loc), 5073 Name => E)); 5074 5075 Set_Renamed_Object (Id, E); 5076 5077 -- Force generation of debugging information for the constant and for 5078 -- the renamed function call. 5079 5080 Set_Debug_Info_Needed (Id); 5081 Set_Debug_Info_Needed (Entity (Prefix (E))); 5082 end if; 5083 5084 if Present (Prev_Entity) 5085 and then Is_Frozen (Prev_Entity) 5086 and then not Error_Posted (Id) 5087 then 5088 Error_Msg_N ("full constant declaration appears too late", N); 5089 end if; 5090 5091 Check_Eliminated (Id); 5092 5093 -- Deal with setting In_Private_Part flag if in private part 5094 5095 if Ekind (Scope (Id)) = E_Package 5096 and then In_Private_Part (Scope (Id)) 5097 then 5098 Set_In_Private_Part (Id); 5099 end if; 5100 5101 <<Leave>> 5102 -- Initialize the refined state of a variable here because this is a 5103 -- common destination for legal and illegal object declarations. 5104 5105 if Ekind (Id) = E_Variable then 5106 Set_Encapsulating_State (Id, Empty); 5107 end if; 5108 5109 if Has_Aspects (N) then 5110 Analyze_Aspect_Specifications (N, Id); 5111 end if; 5112 5113 Analyze_Dimension (N); 5114 5115 -- Verify whether the object declaration introduces an illegal hidden 5116 -- state within a package subject to a null abstract state. 5117 5118 if Ekind (Id) = E_Variable then 5119 Check_No_Hidden_State (Id); 5120 end if; 5121 5122 Restore_Ghost_Region (Saved_GM, Saved_IGR); 5123 end Analyze_Object_Declaration; 5124 5125 --------------------------- 5126 -- Analyze_Others_Choice -- 5127 --------------------------- 5128 5129 -- Nothing to do for the others choice node itself, the semantic analysis 5130 -- of the others choice will occur as part of the processing of the parent 5131 5132 procedure Analyze_Others_Choice (N : Node_Id) is 5133 pragma Warnings (Off, N); 5134 begin 5135 null; 5136 end Analyze_Others_Choice; 5137 5138 ------------------------------------------- 5139 -- Analyze_Private_Extension_Declaration -- 5140 ------------------------------------------- 5141 5142 procedure Analyze_Private_Extension_Declaration (N : Node_Id) is 5143 Indic : constant Node_Id := Subtype_Indication (N); 5144 T : constant Entity_Id := Defining_Identifier (N); 5145 Iface : Entity_Id; 5146 Iface_Elmt : Elmt_Id; 5147 Parent_Base : Entity_Id; 5148 Parent_Type : Entity_Id; 5149 5150 begin 5151 -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces 5152 5153 if Is_Non_Empty_List (Interface_List (N)) then 5154 declare 5155 Intf : Node_Id; 5156 T : Entity_Id; 5157 5158 begin 5159 Intf := First (Interface_List (N)); 5160 while Present (Intf) loop 5161 T := Find_Type_Of_Subtype_Indic (Intf); 5162 5163 Diagnose_Interface (Intf, T); 5164 Next (Intf); 5165 end loop; 5166 end; 5167 end if; 5168 5169 Generate_Definition (T); 5170 5171 -- For other than Ada 2012, just enter the name in the current scope 5172 5173 if Ada_Version < Ada_2012 then 5174 Enter_Name (T); 5175 5176 -- Ada 2012 (AI05-0162): Enter the name in the current scope handling 5177 -- case of private type that completes an incomplete type. 5178 5179 else 5180 declare 5181 Prev : Entity_Id; 5182 5183 begin 5184 Prev := Find_Type_Name (N); 5185 5186 pragma Assert (Prev = T 5187 or else (Ekind (Prev) = E_Incomplete_Type 5188 and then Present (Full_View (Prev)) 5189 and then Full_View (Prev) = T)); 5190 end; 5191 end if; 5192 5193 Parent_Type := Find_Type_Of_Subtype_Indic (Indic); 5194 Parent_Base := Base_Type (Parent_Type); 5195 5196 if Parent_Type = Any_Type or else Etype (Parent_Type) = Any_Type then 5197 Mutate_Ekind (T, Ekind (Parent_Type)); 5198 Set_Etype (T, Any_Type); 5199 goto Leave; 5200 5201 elsif not Is_Tagged_Type (Parent_Type) then 5202 Error_Msg_N 5203 ("parent of type extension must be a tagged type", Indic); 5204 goto Leave; 5205 5206 elsif Ekind (Parent_Type) in E_Void | E_Incomplete_Type then 5207 Error_Msg_N ("premature derivation of incomplete type", Indic); 5208 goto Leave; 5209 5210 elsif Is_Concurrent_Type (Parent_Type) then 5211 Error_Msg_N 5212 ("parent type of a private extension cannot be a synchronized " 5213 & "tagged type (RM 3.9.1 (3/1))", N); 5214 5215 Set_Etype (T, Any_Type); 5216 Mutate_Ekind (T, E_Limited_Private_Type); 5217 Set_Private_Dependents (T, New_Elmt_List); 5218 Set_Error_Posted (T); 5219 goto Leave; 5220 end if; 5221 5222 Check_Wide_Character_Restriction (Parent_Type, Indic); 5223 5224 -- Perhaps the parent type should be changed to the class-wide type's 5225 -- specific type in this case to prevent cascading errors ??? 5226 5227 if Is_Class_Wide_Type (Parent_Type) then 5228 Error_Msg_N 5229 ("parent of type extension must not be a class-wide type", Indic); 5230 goto Leave; 5231 end if; 5232 5233 if (not Is_Package_Or_Generic_Package (Current_Scope) 5234 and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration) 5235 or else In_Private_Part (Current_Scope) 5236 then 5237 Error_Msg_N ("invalid context for private extension", N); 5238 end if; 5239 5240 -- Set common attributes 5241 5242 Set_Is_Pure (T, Is_Pure (Current_Scope)); 5243 Set_Scope (T, Current_Scope); 5244 Mutate_Ekind (T, E_Record_Type_With_Private); 5245 Reinit_Size_Align (T); 5246 Set_Default_SSO (T); 5247 Set_No_Reordering (T, No_Component_Reordering); 5248 5249 Set_Etype (T, Parent_Base); 5250 Propagate_Concurrent_Flags (T, Parent_Base); 5251 5252 Set_Convention (T, Convention (Parent_Type)); 5253 Set_First_Rep_Item (T, First_Rep_Item (Parent_Type)); 5254 Set_Is_First_Subtype (T); 5255 Make_Class_Wide_Type (T); 5256 5257 -- Set the SPARK mode from the current context 5258 5259 Set_SPARK_Pragma (T, SPARK_Mode_Pragma); 5260 Set_SPARK_Pragma_Inherited (T); 5261 5262 if Unknown_Discriminants_Present (N) then 5263 Set_Discriminant_Constraint (T, No_Elist); 5264 end if; 5265 5266 Build_Derived_Record_Type (N, Parent_Type, T); 5267 5268 -- A private extension inherits the Default_Initial_Condition pragma 5269 -- coming from any parent type within the derivation chain. 5270 5271 if Has_DIC (Parent_Type) then 5272 Set_Has_Inherited_DIC (T); 5273 end if; 5274 5275 -- A private extension inherits any class-wide invariants coming from a 5276 -- parent type or an interface. Note that the invariant procedure of the 5277 -- parent type should not be inherited because the private extension may 5278 -- define invariants of its own. 5279 5280 if Has_Inherited_Invariants (Parent_Type) 5281 or else Has_Inheritable_Invariants (Parent_Type) 5282 then 5283 Set_Has_Inherited_Invariants (T); 5284 5285 elsif Present (Interfaces (T)) then 5286 Iface_Elmt := First_Elmt (Interfaces (T)); 5287 while Present (Iface_Elmt) loop 5288 Iface := Node (Iface_Elmt); 5289 5290 if Has_Inheritable_Invariants (Iface) then 5291 Set_Has_Inherited_Invariants (T); 5292 exit; 5293 end if; 5294 5295 Next_Elmt (Iface_Elmt); 5296 end loop; 5297 end if; 5298 5299 -- Ada 2005 (AI-443): Synchronized private extension or a rewritten 5300 -- synchronized formal derived type. 5301 5302 if Ada_Version >= Ada_2005 and then Synchronized_Present (N) then 5303 Set_Is_Limited_Record (T); 5304 5305 -- Formal derived type case 5306 5307 if Is_Generic_Type (T) then 5308 5309 -- The parent must be a tagged limited type or a synchronized 5310 -- interface. 5311 5312 if (not Is_Tagged_Type (Parent_Type) 5313 or else not Is_Limited_Type (Parent_Type)) 5314 and then 5315 (not Is_Interface (Parent_Type) 5316 or else not Is_Synchronized_Interface (Parent_Type)) 5317 then 5318 Error_Msg_NE 5319 ("parent type of & must be tagged limited or synchronized", 5320 N, T); 5321 end if; 5322 5323 -- The progenitors (if any) must be limited or synchronized 5324 -- interfaces. 5325 5326 if Present (Interfaces (T)) then 5327 Iface_Elmt := First_Elmt (Interfaces (T)); 5328 while Present (Iface_Elmt) loop 5329 Iface := Node (Iface_Elmt); 5330 5331 if not Is_Limited_Interface (Iface) 5332 and then not Is_Synchronized_Interface (Iface) 5333 then 5334 Error_Msg_NE 5335 ("progenitor & must be limited or synchronized", 5336 N, Iface); 5337 end if; 5338 5339 Next_Elmt (Iface_Elmt); 5340 end loop; 5341 end if; 5342 5343 -- Regular derived extension, the parent must be a limited or 5344 -- synchronized interface. 5345 5346 else 5347 if not Is_Interface (Parent_Type) 5348 or else (not Is_Limited_Interface (Parent_Type) 5349 and then not Is_Synchronized_Interface (Parent_Type)) 5350 then 5351 Error_Msg_NE 5352 ("parent type of & must be limited interface", N, T); 5353 end if; 5354 end if; 5355 5356 -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private 5357 -- extension with a synchronized parent must be explicitly declared 5358 -- synchronized, because the full view will be a synchronized type. 5359 -- This must be checked before the check for limited types below, 5360 -- to ensure that types declared limited are not allowed to extend 5361 -- synchronized interfaces. 5362 5363 elsif Is_Interface (Parent_Type) 5364 and then Is_Synchronized_Interface (Parent_Type) 5365 and then not Synchronized_Present (N) 5366 then 5367 Error_Msg_NE 5368 ("private extension of& must be explicitly synchronized", 5369 N, Parent_Type); 5370 5371 elsif Limited_Present (N) then 5372 Set_Is_Limited_Record (T); 5373 5374 if not Is_Limited_Type (Parent_Type) 5375 and then 5376 (not Is_Interface (Parent_Type) 5377 or else not Is_Limited_Interface (Parent_Type)) 5378 then 5379 Error_Msg_NE ("parent type& of limited extension must be limited", 5380 N, Parent_Type); 5381 end if; 5382 end if; 5383 5384 -- Remember that its parent type has a private extension. Used to warn 5385 -- on public primitives of the parent type defined after its private 5386 -- extensions (see Check_Dispatching_Operation). 5387 5388 Set_Has_Private_Extension (Parent_Type); 5389 5390 <<Leave>> 5391 if Has_Aspects (N) then 5392 Analyze_Aspect_Specifications (N, T); 5393 end if; 5394 end Analyze_Private_Extension_Declaration; 5395 5396 --------------------------------- 5397 -- Analyze_Subtype_Declaration -- 5398 --------------------------------- 5399 5400 procedure Analyze_Subtype_Declaration 5401 (N : Node_Id; 5402 Skip : Boolean := False) 5403 is 5404 Id : constant Entity_Id := Defining_Identifier (N); 5405 T : Entity_Id; 5406 5407 begin 5408 Generate_Definition (Id); 5409 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 5410 Reinit_Size_Align (Id); 5411 5412 -- The following guard condition on Enter_Name is to handle cases where 5413 -- the defining identifier has already been entered into the scope but 5414 -- the declaration as a whole needs to be analyzed. 5415 5416 -- This case in particular happens for derived enumeration types. The 5417 -- derived enumeration type is processed as an inserted enumeration type 5418 -- declaration followed by a rewritten subtype declaration. The defining 5419 -- identifier, however, is entered into the name scope very early in the 5420 -- processing of the original type declaration and therefore needs to be 5421 -- avoided here, when the created subtype declaration is analyzed. (See 5422 -- Build_Derived_Types) 5423 5424 -- This also happens when the full view of a private type is derived 5425 -- type with constraints. In this case the entity has been introduced 5426 -- in the private declaration. 5427 5428 -- Finally this happens in some complex cases when validity checks are 5429 -- enabled, where the same subtype declaration may be analyzed twice. 5430 -- This can happen if the subtype is created by the preanalysis of 5431 -- an attribute tht gives the range of a loop statement, and the loop 5432 -- itself appears within an if_statement that will be rewritten during 5433 -- expansion. 5434 5435 if Skip 5436 or else (Present (Etype (Id)) 5437 and then (Is_Private_Type (Etype (Id)) 5438 or else Is_Task_Type (Etype (Id)) 5439 or else Is_Rewrite_Substitution (N))) 5440 then 5441 null; 5442 5443 elsif Current_Entity (Id) = Id then 5444 null; 5445 5446 else 5447 Enter_Name (Id); 5448 end if; 5449 5450 T := Process_Subtype (Subtype_Indication (N), N, Id, 'P'); 5451 5452 -- Class-wide equivalent types of records with unknown discriminants 5453 -- involve the generation of an itype which serves as the private view 5454 -- of a constrained record subtype. In such cases the base type of the 5455 -- current subtype we are processing is the private itype. Use the full 5456 -- of the private itype when decorating various attributes. 5457 5458 if Is_Itype (T) 5459 and then Is_Private_Type (T) 5460 and then Present (Full_View (T)) 5461 then 5462 T := Full_View (T); 5463 end if; 5464 5465 -- Inherit common attributes 5466 5467 Set_Is_Volatile (Id, Is_Volatile (T)); 5468 Set_Treat_As_Volatile (Id, Treat_As_Volatile (T)); 5469 Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T))); 5470 Set_Convention (Id, Convention (T)); 5471 5472 -- If ancestor has predicates then so does the subtype, and in addition 5473 -- we must delay the freeze to properly arrange predicate inheritance. 5474 5475 -- The Ancestor_Type test is really unpleasant, there seem to be cases 5476 -- in which T = ID, so the above tests and assignments do nothing??? 5477 5478 if Has_Predicates (T) 5479 or else (Present (Ancestor_Subtype (T)) 5480 and then Has_Predicates (Ancestor_Subtype (T))) 5481 then 5482 Set_Has_Predicates (Id); 5483 Set_Has_Delayed_Freeze (Id); 5484 5485 -- Generated subtypes inherit the predicate function from the parent 5486 -- (no aspects to examine on the generated declaration). 5487 5488 if not Comes_From_Source (N) then 5489 Mutate_Ekind (Id, Ekind (T)); 5490 5491 if Present (Predicate_Function (Id)) then 5492 null; 5493 5494 elsif Present (Predicate_Function (T)) then 5495 Set_Predicate_Function (Id, Predicate_Function (T)); 5496 5497 elsif Present (Ancestor_Subtype (T)) 5498 and then Present (Predicate_Function (Ancestor_Subtype (T))) 5499 then 5500 Set_Predicate_Function (Id, 5501 Predicate_Function (Ancestor_Subtype (T))); 5502 end if; 5503 end if; 5504 end if; 5505 5506 -- In the case where there is no constraint given in the subtype 5507 -- indication, Process_Subtype just returns the Subtype_Mark, so its 5508 -- semantic attributes must be established here. 5509 5510 if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then 5511 Set_Etype (Id, Base_Type (T)); 5512 5513 case Ekind (T) is 5514 when Array_Kind => 5515 Mutate_Ekind (Id, E_Array_Subtype); 5516 Copy_Array_Subtype_Attributes (Id, T); 5517 5518 when Decimal_Fixed_Point_Kind => 5519 Mutate_Ekind (Id, E_Decimal_Fixed_Point_Subtype); 5520 Set_Digits_Value (Id, Digits_Value (T)); 5521 Set_Delta_Value (Id, Delta_Value (T)); 5522 Set_Scale_Value (Id, Scale_Value (T)); 5523 Set_Small_Value (Id, Small_Value (T)); 5524 Set_Scalar_Range (Id, Scalar_Range (T)); 5525 Set_Machine_Radix_10 (Id, Machine_Radix_10 (T)); 5526 Set_Is_Constrained (Id, Is_Constrained (T)); 5527 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5528 Copy_RM_Size (To => Id, From => T); 5529 5530 when Enumeration_Kind => 5531 Mutate_Ekind (Id, E_Enumeration_Subtype); 5532 Set_First_Literal (Id, First_Literal (Base_Type (T))); 5533 Set_Scalar_Range (Id, Scalar_Range (T)); 5534 Set_Is_Character_Type (Id, Is_Character_Type (T)); 5535 Set_Is_Constrained (Id, Is_Constrained (T)); 5536 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5537 Copy_RM_Size (To => Id, From => T); 5538 5539 when Ordinary_Fixed_Point_Kind => 5540 Mutate_Ekind (Id, E_Ordinary_Fixed_Point_Subtype); 5541 Set_Scalar_Range (Id, Scalar_Range (T)); 5542 Set_Small_Value (Id, Small_Value (T)); 5543 Set_Delta_Value (Id, Delta_Value (T)); 5544 Set_Is_Constrained (Id, Is_Constrained (T)); 5545 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5546 Copy_RM_Size (To => Id, From => T); 5547 5548 when Float_Kind => 5549 Mutate_Ekind (Id, E_Floating_Point_Subtype); 5550 Set_Scalar_Range (Id, Scalar_Range (T)); 5551 Set_Digits_Value (Id, Digits_Value (T)); 5552 Set_Is_Constrained (Id, Is_Constrained (T)); 5553 5554 -- If the floating point type has dimensions, these will be 5555 -- inherited subsequently when Analyze_Dimensions is called. 5556 5557 when Signed_Integer_Kind => 5558 Mutate_Ekind (Id, E_Signed_Integer_Subtype); 5559 Set_Scalar_Range (Id, Scalar_Range (T)); 5560 Set_Is_Constrained (Id, Is_Constrained (T)); 5561 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5562 Copy_RM_Size (To => Id, From => T); 5563 5564 when Modular_Integer_Kind => 5565 Mutate_Ekind (Id, E_Modular_Integer_Subtype); 5566 Set_Scalar_Range (Id, Scalar_Range (T)); 5567 Set_Is_Constrained (Id, Is_Constrained (T)); 5568 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 5569 Copy_RM_Size (To => Id, From => T); 5570 5571 when Class_Wide_Kind => 5572 Mutate_Ekind (Id, E_Class_Wide_Subtype); 5573 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 5574 Set_Cloned_Subtype (Id, T); 5575 Set_Is_Tagged_Type (Id, True); 5576 Set_Is_Limited_Record (Id, Is_Limited_Record (T)); 5577 Set_Has_Unknown_Discriminants 5578 (Id, True); 5579 Set_No_Tagged_Streams_Pragma 5580 (Id, No_Tagged_Streams_Pragma (T)); 5581 5582 if Ekind (T) = E_Class_Wide_Subtype then 5583 Set_Equivalent_Type (Id, Equivalent_Type (T)); 5584 end if; 5585 5586 when E_Record_Subtype 5587 | E_Record_Type 5588 => 5589 Mutate_Ekind (Id, E_Record_Subtype); 5590 5591 -- Subtype declarations introduced for formal type parameters 5592 -- in generic instantiations should inherit the Size value of 5593 -- the type they rename. 5594 5595 if Present (Generic_Parent_Type (N)) then 5596 Copy_RM_Size (To => Id, From => T); 5597 end if; 5598 5599 if Ekind (T) = E_Record_Subtype 5600 and then Present (Cloned_Subtype (T)) 5601 then 5602 Set_Cloned_Subtype (Id, Cloned_Subtype (T)); 5603 else 5604 Set_Cloned_Subtype (Id, T); 5605 end if; 5606 5607 Set_First_Entity (Id, First_Entity (T)); 5608 Set_Last_Entity (Id, Last_Entity (T)); 5609 Set_Has_Discriminants (Id, Has_Discriminants (T)); 5610 Set_Is_Constrained (Id, Is_Constrained (T)); 5611 Set_Is_Limited_Record (Id, Is_Limited_Record (T)); 5612 Set_Has_Implicit_Dereference 5613 (Id, Has_Implicit_Dereference (T)); 5614 Set_Has_Unknown_Discriminants 5615 (Id, Has_Unknown_Discriminants (T)); 5616 5617 if Has_Discriminants (T) then 5618 Set_Discriminant_Constraint 5619 (Id, Discriminant_Constraint (T)); 5620 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 5621 5622 elsif Has_Unknown_Discriminants (Id) then 5623 Set_Discriminant_Constraint (Id, No_Elist); 5624 end if; 5625 5626 if Is_Tagged_Type (T) then 5627 Set_Is_Tagged_Type (Id, True); 5628 Set_No_Tagged_Streams_Pragma 5629 (Id, No_Tagged_Streams_Pragma (T)); 5630 Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); 5631 Set_Direct_Primitive_Operations 5632 (Id, Direct_Primitive_Operations (T)); 5633 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 5634 5635 if Is_Interface (T) then 5636 Set_Is_Interface (Id); 5637 Set_Is_Limited_Interface (Id, Is_Limited_Interface (T)); 5638 end if; 5639 end if; 5640 5641 when Private_Kind => 5642 Mutate_Ekind (Id, Subtype_Kind (Ekind (T))); 5643 Set_Has_Discriminants (Id, Has_Discriminants (T)); 5644 Set_Is_Constrained (Id, Is_Constrained (T)); 5645 Set_First_Entity (Id, First_Entity (T)); 5646 Set_Last_Entity (Id, Last_Entity (T)); 5647 Set_Private_Dependents (Id, New_Elmt_List); 5648 Set_Is_Limited_Record (Id, Is_Limited_Record (T)); 5649 Set_Has_Implicit_Dereference 5650 (Id, Has_Implicit_Dereference (T)); 5651 Set_Has_Unknown_Discriminants 5652 (Id, Has_Unknown_Discriminants (T)); 5653 Set_Known_To_Have_Preelab_Init 5654 (Id, Known_To_Have_Preelab_Init (T)); 5655 5656 if Is_Tagged_Type (T) then 5657 Set_Is_Tagged_Type (Id); 5658 Set_No_Tagged_Streams_Pragma (Id, 5659 No_Tagged_Streams_Pragma (T)); 5660 Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); 5661 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 5662 Set_Direct_Primitive_Operations (Id, 5663 Direct_Primitive_Operations (T)); 5664 end if; 5665 5666 -- In general the attributes of the subtype of a private type 5667 -- are the attributes of the partial view of parent. However, 5668 -- the full view may be a discriminated type, and the subtype 5669 -- must share the discriminant constraint to generate correct 5670 -- calls to initialization procedures. 5671 5672 if Has_Discriminants (T) then 5673 Set_Discriminant_Constraint 5674 (Id, Discriminant_Constraint (T)); 5675 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 5676 5677 elsif Present (Full_View (T)) 5678 and then Has_Discriminants (Full_View (T)) 5679 then 5680 Set_Discriminant_Constraint 5681 (Id, Discriminant_Constraint (Full_View (T))); 5682 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 5683 5684 -- This would seem semantically correct, but apparently 5685 -- generates spurious errors about missing components ??? 5686 5687 -- Set_Has_Discriminants (Id); 5688 end if; 5689 5690 Prepare_Private_Subtype_Completion (Id, N); 5691 5692 -- If this is the subtype of a constrained private type with 5693 -- discriminants that has got a full view and we also have 5694 -- built a completion just above, show that the completion 5695 -- is a clone of the full view to the back-end. 5696 5697 if Has_Discriminants (T) 5698 and then not Has_Unknown_Discriminants (T) 5699 and then not Is_Empty_Elmt_List (Discriminant_Constraint (T)) 5700 and then Present (Full_View (T)) 5701 and then Present (Full_View (Id)) 5702 then 5703 Set_Cloned_Subtype (Full_View (Id), Full_View (T)); 5704 end if; 5705 5706 when Access_Kind => 5707 Mutate_Ekind (Id, E_Access_Subtype); 5708 Set_Is_Constrained (Id, Is_Constrained (T)); 5709 Set_Is_Access_Constant 5710 (Id, Is_Access_Constant (T)); 5711 Set_Directly_Designated_Type 5712 (Id, Designated_Type (T)); 5713 Set_Can_Never_Be_Null (Id, Can_Never_Be_Null (T)); 5714 5715 -- A Pure library_item must not contain the declaration of a 5716 -- named access type, except within a subprogram, generic 5717 -- subprogram, task unit, or protected unit, or if it has 5718 -- a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)). 5719 5720 if Comes_From_Source (Id) 5721 and then In_Pure_Unit 5722 and then not In_Subprogram_Task_Protected_Unit 5723 and then not No_Pool_Assigned (Id) 5724 then 5725 Error_Msg_N 5726 ("named access types not allowed in pure unit", N); 5727 end if; 5728 5729 when Concurrent_Kind => 5730 Mutate_Ekind (Id, Subtype_Kind (Ekind (T))); 5731 Set_Corresponding_Record_Type (Id, 5732 Corresponding_Record_Type (T)); 5733 Set_First_Entity (Id, First_Entity (T)); 5734 Set_First_Private_Entity (Id, First_Private_Entity (T)); 5735 Set_Has_Discriminants (Id, Has_Discriminants (T)); 5736 Set_Is_Constrained (Id, Is_Constrained (T)); 5737 Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); 5738 Set_Last_Entity (Id, Last_Entity (T)); 5739 5740 if Is_Tagged_Type (T) then 5741 Set_No_Tagged_Streams_Pragma 5742 (Id, No_Tagged_Streams_Pragma (T)); 5743 end if; 5744 5745 if Has_Discriminants (T) then 5746 Set_Discriminant_Constraint 5747 (Id, Discriminant_Constraint (T)); 5748 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 5749 end if; 5750 5751 when Incomplete_Kind => 5752 if Ada_Version >= Ada_2005 then 5753 5754 -- In Ada 2005 an incomplete type can be explicitly tagged: 5755 -- propagate indication. Note that we also have to include 5756 -- subtypes for Ada 2012 extended use of incomplete types. 5757 5758 Mutate_Ekind (Id, E_Incomplete_Subtype); 5759 Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); 5760 Set_Private_Dependents (Id, New_Elmt_List); 5761 5762 if Is_Tagged_Type (Id) then 5763 Set_No_Tagged_Streams_Pragma 5764 (Id, No_Tagged_Streams_Pragma (T)); 5765 end if; 5766 5767 -- For tagged types, or when prefixed-call syntax is allowed 5768 -- for untagged types, initialize the list of primitive 5769 -- operations to an empty list. 5770 5771 if Is_Tagged_Type (Id) 5772 or else Extensions_Allowed 5773 then 5774 Set_Direct_Primitive_Operations (Id, New_Elmt_List); 5775 end if; 5776 5777 -- Ada 2005 (AI-412): Decorate an incomplete subtype of an 5778 -- incomplete type visible through a limited with clause. 5779 5780 if From_Limited_With (T) 5781 and then Present (Non_Limited_View (T)) 5782 then 5783 Set_From_Limited_With (Id); 5784 Set_Non_Limited_View (Id, Non_Limited_View (T)); 5785 5786 -- Ada 2005 (AI-412): Add the regular incomplete subtype 5787 -- to the private dependents of the original incomplete 5788 -- type for future transformation. 5789 5790 else 5791 Append_Elmt (Id, Private_Dependents (T)); 5792 end if; 5793 5794 -- If the subtype name denotes an incomplete type an error 5795 -- was already reported by Process_Subtype. 5796 5797 else 5798 Set_Etype (Id, Any_Type); 5799 end if; 5800 5801 when others => 5802 raise Program_Error; 5803 end case; 5804 5805 -- If there is no constraint in the subtype indication, the 5806 -- declared entity inherits predicates from the parent. 5807 5808 Inherit_Predicate_Flags (Id, T); 5809 end if; 5810 5811 if Etype (Id) = Any_Type then 5812 goto Leave; 5813 end if; 5814 5815 -- When prefixed calls are enabled for untagged types, the subtype 5816 -- shares the primitive operations of its base type. Do this even 5817 -- when Extensions_Allowed is False to issue better error messages. 5818 5819 Set_Direct_Primitive_Operations 5820 (Id, Direct_Primitive_Operations (Base_Type (T))); 5821 5822 -- Some common processing on all types 5823 5824 Set_Size_Info (Id, T); 5825 Set_First_Rep_Item (Id, First_Rep_Item (T)); 5826 5827 -- If the parent type is a generic actual, so is the subtype. This may 5828 -- happen in a nested instance. Why Comes_From_Source test??? 5829 5830 if not Comes_From_Source (N) then 5831 Set_Is_Generic_Actual_Type (Id, Is_Generic_Actual_Type (T)); 5832 end if; 5833 5834 -- If this is a subtype declaration for an actual in an instance, 5835 -- inherit static and dynamic predicates if any. 5836 5837 -- If declaration has no aspect specifications, inherit predicate 5838 -- info as well. Unclear how to handle the case of both specified 5839 -- and inherited predicates ??? Other inherited aspects, such as 5840 -- invariants, should be OK, but the combination with later pragmas 5841 -- may also require special merging. 5842 5843 if Has_Predicates (T) 5844 and then Present (Predicate_Function (T)) 5845 and then 5846 ((In_Instance and then not Comes_From_Source (N)) 5847 or else No (Aspect_Specifications (N))) 5848 then 5849 -- Inherit Subprograms_For_Type from the full view, if present 5850 5851 if Present (Full_View (T)) 5852 and then Subprograms_For_Type (Full_View (T)) /= No_Elist 5853 then 5854 Set_Subprograms_For_Type 5855 (Id, Subprograms_For_Type (Full_View (T))); 5856 else 5857 Set_Subprograms_For_Type (Id, Subprograms_For_Type (T)); 5858 end if; 5859 5860 -- If the current declaration created both a private and a full view, 5861 -- then propagate Predicate_Function to the latter as well. 5862 5863 if Present (Full_View (Id)) 5864 and then No (Predicate_Function (Full_View (Id))) 5865 then 5866 Set_Subprograms_For_Type 5867 (Full_View (Id), Subprograms_For_Type (Id)); 5868 end if; 5869 5870 if Has_Static_Predicate (T) then 5871 Set_Has_Static_Predicate (Id); 5872 Set_Static_Discrete_Predicate (Id, Static_Discrete_Predicate (T)); 5873 end if; 5874 end if; 5875 5876 -- If the base type is a scalar type, or else if there is no 5877 -- constraint, the atomic flag is inherited by the subtype. 5878 -- Ditto for the Independent aspect. 5879 5880 if Is_Scalar_Type (Id) 5881 or else Is_Entity_Name (Subtype_Indication (N)) 5882 then 5883 Set_Is_Atomic (Id, Is_Atomic (T)); 5884 Set_Is_Independent (Id, Is_Independent (T)); 5885 end if; 5886 5887 -- Remaining processing depends on characteristics of base type 5888 5889 T := Etype (Id); 5890 5891 Set_Is_Immediately_Visible (Id, True); 5892 Set_Depends_On_Private (Id, Has_Private_Component (T)); 5893 Set_Is_Descendant_Of_Address (Id, Is_Descendant_Of_Address (T)); 5894 5895 if Is_Interface (T) then 5896 Set_Is_Interface (Id); 5897 Set_Is_Limited_Interface (Id, Is_Limited_Interface (T)); 5898 end if; 5899 5900 if Present (Generic_Parent_Type (N)) 5901 and then 5902 (Nkind (Parent (Generic_Parent_Type (N))) /= 5903 N_Formal_Type_Declaration 5904 or else Nkind (Formal_Type_Definition 5905 (Parent (Generic_Parent_Type (N)))) /= 5906 N_Formal_Private_Type_Definition) 5907 then 5908 if Is_Tagged_Type (Id) then 5909 5910 -- If this is a generic actual subtype for a synchronized type, 5911 -- the primitive operations are those of the corresponding record 5912 -- for which there is a separate subtype declaration. 5913 5914 if Is_Concurrent_Type (Id) then 5915 null; 5916 elsif Is_Class_Wide_Type (Id) then 5917 Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T)); 5918 else 5919 Derive_Subprograms (Generic_Parent_Type (N), Id, T); 5920 end if; 5921 5922 elsif Scope (Etype (Id)) /= Standard_Standard then 5923 Derive_Subprograms (Generic_Parent_Type (N), Id); 5924 end if; 5925 end if; 5926 5927 if Is_Private_Type (T) and then Present (Full_View (T)) then 5928 Conditional_Delay (Id, Full_View (T)); 5929 5930 -- The subtypes of components or subcomponents of protected types 5931 -- do not need freeze nodes, which would otherwise appear in the 5932 -- wrong scope (before the freeze node for the protected type). The 5933 -- proper subtypes are those of the subcomponents of the corresponding 5934 -- record. 5935 5936 elsif Ekind (Scope (Id)) /= E_Protected_Type 5937 and then Present (Scope (Scope (Id))) -- error defense 5938 and then Ekind (Scope (Scope (Id))) /= E_Protected_Type 5939 then 5940 Conditional_Delay (Id, T); 5941 end if; 5942 5943 -- If we have a subtype of an incomplete type whose full type is a 5944 -- derived numeric type, we need to have a freeze node for the subtype. 5945 -- Otherwise gigi will complain while computing the (static) bounds of 5946 -- the subtype. 5947 5948 if Is_Itype (T) 5949 and then Is_Elementary_Type (Id) 5950 and then Etype (Id) /= Id 5951 then 5952 declare 5953 Partial : constant Entity_Id := 5954 Incomplete_Or_Partial_View (First_Subtype (Id)); 5955 begin 5956 if Present (Partial) 5957 and then Ekind (Partial) = E_Incomplete_Type 5958 then 5959 Set_Has_Delayed_Freeze (Id); 5960 end if; 5961 end; 5962 end if; 5963 5964 -- Check that Constraint_Error is raised for a scalar subtype indication 5965 -- when the lower or upper bound of a non-null range lies outside the 5966 -- range of the type mark. Likewise for an array subtype, but check the 5967 -- compatibility for each index. 5968 5969 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then 5970 declare 5971 Indic_Typ : constant Entity_Id := 5972 Etype (Subtype_Mark (Subtype_Indication (N))); 5973 Subt_Index : Node_Id; 5974 Target_Index : Node_Id; 5975 5976 begin 5977 if Is_Scalar_Type (Etype (Id)) 5978 and then Scalar_Range (Id) /= Scalar_Range (Indic_Typ) 5979 then 5980 Apply_Range_Check (Scalar_Range (Id), Indic_Typ); 5981 5982 elsif Is_Array_Type (Etype (Id)) 5983 and then Present (First_Index (Id)) 5984 then 5985 Subt_Index := First_Index (Id); 5986 Target_Index := First_Index (Indic_Typ); 5987 5988 while Present (Subt_Index) loop 5989 if ((Nkind (Subt_Index) in N_Expanded_Name | N_Identifier 5990 and then Is_Scalar_Type (Entity (Subt_Index))) 5991 or else Nkind (Subt_Index) = N_Subtype_Indication) 5992 and then 5993 Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range 5994 then 5995 Apply_Range_Check 5996 (Scalar_Range (Etype (Subt_Index)), 5997 Etype (Target_Index), 5998 Insert_Node => N); 5999 end if; 6000 6001 Next_Index (Subt_Index); 6002 Next_Index (Target_Index); 6003 end loop; 6004 end if; 6005 end; 6006 end if; 6007 6008 Set_Optimize_Alignment_Flags (Id); 6009 Check_Eliminated (Id); 6010 6011 <<Leave>> 6012 if Has_Aspects (N) then 6013 Analyze_Aspect_Specifications (N, Id); 6014 end if; 6015 6016 Analyze_Dimension (N); 6017 6018 -- Check No_Dynamic_Sized_Objects restriction, which disallows subtype 6019 -- indications on composite types where the constraints are dynamic. 6020 -- Note that object declarations and aggregates generate implicit 6021 -- subtype declarations, which this covers. One special case is that the 6022 -- implicitly generated "=" for discriminated types includes an 6023 -- offending subtype declaration, which is harmless, so we ignore it 6024 -- here. 6025 6026 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then 6027 declare 6028 Cstr : constant Node_Id := Constraint (Subtype_Indication (N)); 6029 begin 6030 if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint 6031 and then not (Is_Internal (Id) 6032 and then Is_TSS (Scope (Id), 6033 TSS_Composite_Equality)) 6034 and then not Within_Init_Proc 6035 and then not All_Composite_Constraints_Static (Cstr) 6036 then 6037 Check_Restriction (No_Dynamic_Sized_Objects, Cstr); 6038 end if; 6039 end; 6040 end if; 6041 end Analyze_Subtype_Declaration; 6042 6043 -------------------------------- 6044 -- Analyze_Subtype_Indication -- 6045 -------------------------------- 6046 6047 procedure Analyze_Subtype_Indication (N : Node_Id) is 6048 T : constant Entity_Id := Subtype_Mark (N); 6049 R : constant Node_Id := Range_Expression (Constraint (N)); 6050 6051 begin 6052 Analyze (T); 6053 6054 if R /= Error then 6055 Analyze (R); 6056 Set_Etype (N, Etype (R)); 6057 Resolve (R, Entity (T)); 6058 else 6059 Set_Error_Posted (R); 6060 Set_Error_Posted (T); 6061 end if; 6062 end Analyze_Subtype_Indication; 6063 6064 -------------------------- 6065 -- Analyze_Variant_Part -- 6066 -------------------------- 6067 6068 procedure Analyze_Variant_Part (N : Node_Id) is 6069 Discr_Name : Node_Id; 6070 Discr_Type : Entity_Id; 6071 6072 procedure Process_Variant (A : Node_Id); 6073 -- Analyze declarations for a single variant 6074 6075 package Analyze_Variant_Choices is 6076 new Generic_Analyze_Choices (Process_Variant); 6077 use Analyze_Variant_Choices; 6078 6079 --------------------- 6080 -- Process_Variant -- 6081 --------------------- 6082 6083 procedure Process_Variant (A : Node_Id) is 6084 CL : constant Node_Id := Component_List (A); 6085 begin 6086 if not Null_Present (CL) then 6087 Analyze_Declarations (Component_Items (CL)); 6088 6089 if Present (Variant_Part (CL)) then 6090 Analyze (Variant_Part (CL)); 6091 end if; 6092 end if; 6093 end Process_Variant; 6094 6095 -- Start of processing for Analyze_Variant_Part 6096 6097 begin 6098 Discr_Name := Name (N); 6099 Analyze (Discr_Name); 6100 6101 -- If Discr_Name bad, get out (prevent cascaded errors) 6102 6103 if Etype (Discr_Name) = Any_Type then 6104 return; 6105 end if; 6106 6107 -- Check invalid discriminant in variant part 6108 6109 if Ekind (Entity (Discr_Name)) /= E_Discriminant then 6110 Error_Msg_N ("invalid discriminant name in variant part", Discr_Name); 6111 end if; 6112 6113 Discr_Type := Etype (Entity (Discr_Name)); 6114 6115 if not Is_Discrete_Type (Discr_Type) then 6116 Error_Msg_N 6117 ("discriminant in a variant part must be of a discrete type", 6118 Name (N)); 6119 return; 6120 end if; 6121 6122 -- Now analyze the choices, which also analyzes the declarations that 6123 -- are associated with each choice. 6124 6125 Analyze_Choices (Variants (N), Discr_Type); 6126 6127 -- Note: we used to instantiate and call Check_Choices here to check 6128 -- that the choices covered the discriminant, but it's too early to do 6129 -- that because of statically predicated subtypes, whose analysis may 6130 -- be deferred to their freeze point which may be as late as the freeze 6131 -- point of the containing record. So this call is now to be found in 6132 -- Freeze_Record_Declaration. 6133 6134 end Analyze_Variant_Part; 6135 6136 ---------------------------- 6137 -- Array_Type_Declaration -- 6138 ---------------------------- 6139 6140 procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is 6141 Component_Def : constant Node_Id := Component_Definition (Def); 6142 Component_Typ : constant Node_Id := Subtype_Indication (Component_Def); 6143 P : constant Node_Id := Parent (Def); 6144 Element_Type : Entity_Id; 6145 Implicit_Base : Entity_Id; 6146 Index : Node_Id; 6147 Nb_Index : Pos; 6148 Priv : Entity_Id; 6149 Related_Id : Entity_Id; 6150 Has_FLB_Index : Boolean := False; 6151 6152 begin 6153 if Nkind (Def) = N_Constrained_Array_Definition then 6154 Index := First (Discrete_Subtype_Definitions (Def)); 6155 else 6156 Index := First (Subtype_Marks (Def)); 6157 end if; 6158 6159 -- Find proper names for the implicit types which may be public. In case 6160 -- of anonymous arrays we use the name of the first object of that type 6161 -- as prefix. 6162 6163 if No (T) then 6164 Related_Id := Defining_Identifier (P); 6165 else 6166 Related_Id := T; 6167 end if; 6168 6169 Nb_Index := 1; 6170 while Present (Index) loop 6171 Analyze (Index); 6172 6173 -- Test for odd case of trying to index a type by the type itself 6174 6175 if Is_Entity_Name (Index) and then Entity (Index) = T then 6176 Error_Msg_N ("type& cannot be indexed by itself", Index); 6177 Set_Entity (Index, Standard_Boolean); 6178 Set_Etype (Index, Standard_Boolean); 6179 end if; 6180 6181 -- Add a subtype declaration for each index of private array type 6182 -- declaration whose type is also private. For example: 6183 6184 -- package Pkg is 6185 -- type Index is private; 6186 -- private 6187 -- type Table is array (Index) of ... 6188 -- end; 6189 6190 -- This is currently required by the expander for the internally 6191 -- generated equality subprogram of records with variant parts in 6192 -- which the type of some component is such a private type. And it 6193 -- also helps semantic analysis in peculiar cases where the array 6194 -- type is referenced from an instance but not the index directly. 6195 6196 if Is_Package_Or_Generic_Package (Current_Scope) 6197 and then In_Private_Part (Current_Scope) 6198 and then Has_Private_Declaration (Etype (Index)) 6199 and then Scope (Etype (Index)) = Current_Scope 6200 then 6201 declare 6202 Loc : constant Source_Ptr := Sloc (Def); 6203 Decl : Node_Id; 6204 New_E : Entity_Id; 6205 6206 begin 6207 New_E := Make_Temporary (Loc, 'T'); 6208 Set_Is_Internal (New_E); 6209 6210 Decl := 6211 Make_Subtype_Declaration (Loc, 6212 Defining_Identifier => New_E, 6213 Subtype_Indication => 6214 New_Occurrence_Of (Etype (Index), Loc)); 6215 6216 Insert_Before (Parent (Def), Decl); 6217 Analyze (Decl); 6218 Set_Etype (Index, New_E); 6219 6220 -- If the index is a range or a subtype indication it carries 6221 -- no entity. Example: 6222 6223 -- package Pkg is 6224 -- type T is private; 6225 -- private 6226 -- type T is new Natural; 6227 -- Table : array (T(1) .. T(10)) of Boolean; 6228 -- end Pkg; 6229 6230 -- Otherwise the type of the reference is its entity. 6231 6232 if Is_Entity_Name (Index) then 6233 Set_Entity (Index, New_E); 6234 end if; 6235 end; 6236 end if; 6237 6238 Make_Index (Index, P, Related_Id, Nb_Index); 6239 6240 -- In the case where we have an unconstrained array with an index 6241 -- given by a subtype_indication, this is necessarily a "fixed lower 6242 -- bound" index. We change the upper bound of that index to the upper 6243 -- bound of the index's subtype (denoted by the subtype_mark), since 6244 -- that upper bound was originally set by the parser to be the same 6245 -- as the lower bound. In truth, that upper bound corresponds to 6246 -- a box ("<>"), and could be set to Empty, but it's convenient to 6247 -- set it to the upper bound to avoid needing to add special tests 6248 -- in various places for an Empty upper bound, and in any case that 6249 -- accurately characterizes the index's range of values. 6250 6251 if Nkind (Def) = N_Unconstrained_Array_Definition 6252 and then Nkind (Index) = N_Subtype_Indication 6253 then 6254 declare 6255 Index_Subtype_High_Bound : constant Entity_Id := 6256 Type_High_Bound (Entity (Subtype_Mark (Index))); 6257 begin 6258 Set_High_Bound (Range_Expression (Constraint (Index)), 6259 Index_Subtype_High_Bound); 6260 6261 -- Record that the array type has one or more indexes with 6262 -- a fixed lower bound. 6263 6264 Has_FLB_Index := True; 6265 6266 -- Mark the index as belonging to an array type with a fixed 6267 -- lower bound. 6268 6269 Set_Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)); 6270 end; 6271 end if; 6272 6273 -- Check error of subtype with predicate for index type 6274 6275 Bad_Predicated_Subtype_Use 6276 ("subtype& has predicate, not allowed as index subtype", 6277 Index, Etype (Index)); 6278 6279 -- Move to next index 6280 6281 Next (Index); 6282 Nb_Index := Nb_Index + 1; 6283 end loop; 6284 6285 -- Process subtype indication if one is present 6286 6287 if Present (Component_Typ) then 6288 Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C'); 6289 Set_Etype (Component_Typ, Element_Type); 6290 6291 -- Ada 2005 (AI-230): Access Definition case 6292 6293 else pragma Assert (Present (Access_Definition (Component_Def))); 6294 6295 -- Indicate that the anonymous access type is created by the 6296 -- array type declaration. 6297 6298 Element_Type := Access_Definition 6299 (Related_Nod => P, 6300 N => Access_Definition (Component_Def)); 6301 Set_Is_Local_Anonymous_Access (Element_Type); 6302 6303 -- Propagate the parent. This field is needed if we have to generate 6304 -- the master_id associated with an anonymous access to task type 6305 -- component (see Expand_N_Full_Type_Declaration.Build_Master) 6306 6307 Copy_Parent (To => Element_Type, From => T); 6308 6309 -- Ada 2005 (AI-230): In case of components that are anonymous access 6310 -- types the level of accessibility depends on the enclosing type 6311 -- declaration 6312 6313 Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230) 6314 6315 -- Ada 2005 (AI-254) 6316 6317 declare 6318 CD : constant Node_Id := 6319 Access_To_Subprogram_Definition 6320 (Access_Definition (Component_Def)); 6321 begin 6322 if Present (CD) and then Protected_Present (CD) then 6323 Element_Type := 6324 Replace_Anonymous_Access_To_Protected_Subprogram (Def); 6325 end if; 6326 end; 6327 end if; 6328 6329 -- Constrained array case 6330 6331 if No (T) then 6332 -- We might be creating more than one itype with the same Related_Id, 6333 -- e.g. for an array object definition and its initial value. Give 6334 -- them unique suffixes, because GNATprove require distinct types to 6335 -- have different names. 6336 6337 T := Create_Itype (E_Void, P, Related_Id, 'T', Suffix_Index => -1); 6338 end if; 6339 6340 if Nkind (Def) = N_Constrained_Array_Definition then 6341 6342 if Ekind (T) in Incomplete_Or_Private_Kind then 6343 Reinit_Field_To_Zero (T, F_Stored_Constraint); 6344 else 6345 pragma Assert (Ekind (T) = E_Void); 6346 end if; 6347 6348 -- Establish Implicit_Base as unconstrained base type 6349 6350 Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B'); 6351 6352 Set_Etype (Implicit_Base, Implicit_Base); 6353 Set_Scope (Implicit_Base, Current_Scope); 6354 Set_Has_Delayed_Freeze (Implicit_Base); 6355 Set_Default_SSO (Implicit_Base); 6356 6357 -- The constrained array type is a subtype of the unconstrained one 6358 6359 Mutate_Ekind (T, E_Array_Subtype); 6360 Reinit_Size_Align (T); 6361 Set_Etype (T, Implicit_Base); 6362 Set_Scope (T, Current_Scope); 6363 Set_Is_Constrained (T); 6364 Set_First_Index (T, 6365 First (Discrete_Subtype_Definitions (Def))); 6366 Set_Has_Delayed_Freeze (T); 6367 6368 -- Complete setup of implicit base type 6369 6370 pragma Assert (not Known_Component_Size (Implicit_Base)); 6371 Set_Component_Type (Implicit_Base, Element_Type); 6372 Set_Finalize_Storage_Only 6373 (Implicit_Base, 6374 Finalize_Storage_Only (Element_Type)); 6375 Set_First_Index (Implicit_Base, First_Index (T)); 6376 Set_Has_Controlled_Component 6377 (Implicit_Base, 6378 Has_Controlled_Component (Element_Type) 6379 or else Is_Controlled (Element_Type)); 6380 Set_Packed_Array_Impl_Type 6381 (Implicit_Base, Empty); 6382 6383 Propagate_Concurrent_Flags (Implicit_Base, Element_Type); 6384 6385 -- Unconstrained array case 6386 6387 else pragma Assert (Nkind (Def) = N_Unconstrained_Array_Definition); 6388 6389 if Ekind (T) in Incomplete_Or_Private_Kind then 6390 Reinit_Field_To_Zero (T, F_Stored_Constraint); 6391 else 6392 pragma Assert (Ekind (T) = E_Void); 6393 end if; 6394 6395 Mutate_Ekind (T, E_Array_Type); 6396 Reinit_Size_Align (T); 6397 Set_Etype (T, T); 6398 Set_Scope (T, Current_Scope); 6399 pragma Assert (not Known_Component_Size (T)); 6400 Set_Is_Constrained (T, False); 6401 Set_Is_Fixed_Lower_Bound_Array_Subtype 6402 (T, Has_FLB_Index); 6403 Set_First_Index (T, First (Subtype_Marks (Def))); 6404 Set_Has_Delayed_Freeze (T, True); 6405 Propagate_Concurrent_Flags (T, Element_Type); 6406 Set_Has_Controlled_Component (T, Has_Controlled_Component 6407 (Element_Type) 6408 or else 6409 Is_Controlled (Element_Type)); 6410 Set_Finalize_Storage_Only (T, Finalize_Storage_Only 6411 (Element_Type)); 6412 Set_Default_SSO (T); 6413 end if; 6414 6415 -- Common attributes for both cases 6416 6417 Set_Component_Type (Base_Type (T), Element_Type); 6418 Set_Packed_Array_Impl_Type (T, Empty); 6419 6420 if Aliased_Present (Component_Definition (Def)) then 6421 Set_Has_Aliased_Components (Etype (T)); 6422 6423 -- AI12-001: All aliased objects are considered to be specified as 6424 -- independently addressable (RM C.6(8.1/4)). 6425 6426 Set_Has_Independent_Components (Etype (T)); 6427 end if; 6428 6429 -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the 6430 -- array type to ensure that objects of this type are initialized. 6431 6432 if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (Element_Type) then 6433 Set_Can_Never_Be_Null (T); 6434 6435 if Null_Exclusion_Present (Component_Definition (Def)) 6436 6437 -- No need to check itypes because in their case this check was 6438 -- done at their point of creation 6439 6440 and then not Is_Itype (Element_Type) 6441 then 6442 Error_Msg_N 6443 ("`NOT NULL` not allowed (null already excluded)", 6444 Subtype_Indication (Component_Definition (Def))); 6445 end if; 6446 end if; 6447 6448 Priv := Private_Component (Element_Type); 6449 6450 if Present (Priv) then 6451 6452 -- Check for circular definitions 6453 6454 if Priv = Any_Type then 6455 Set_Component_Type (Etype (T), Any_Type); 6456 6457 -- There is a gap in the visibility of operations on the composite 6458 -- type only if the component type is defined in a different scope. 6459 6460 elsif Scope (Priv) = Current_Scope then 6461 null; 6462 6463 elsif Is_Limited_Type (Priv) then 6464 Set_Is_Limited_Composite (Etype (T)); 6465 Set_Is_Limited_Composite (T); 6466 else 6467 Set_Is_Private_Composite (Etype (T)); 6468 Set_Is_Private_Composite (T); 6469 end if; 6470 end if; 6471 6472 -- A syntax error in the declaration itself may lead to an empty index 6473 -- list, in which case do a minimal patch. 6474 6475 if No (First_Index (T)) then 6476 Error_Msg_N ("missing index definition in array type declaration", T); 6477 6478 declare 6479 Indexes : constant List_Id := 6480 New_List (New_Occurrence_Of (Any_Id, Sloc (T))); 6481 begin 6482 Set_Discrete_Subtype_Definitions (Def, Indexes); 6483 Set_First_Index (T, First (Indexes)); 6484 return; 6485 end; 6486 end if; 6487 6488 -- Create a concatenation operator for the new type. Internal array 6489 -- types created for packed entities do not need such, they are 6490 -- compatible with the user-defined type. 6491 6492 if Number_Dimensions (T) = 1 6493 and then not Is_Packed_Array_Impl_Type (T) 6494 then 6495 New_Concatenation_Op (T); 6496 end if; 6497 6498 -- In the case of an unconstrained array the parser has already verified 6499 -- that all the indexes are unconstrained but we still need to make sure 6500 -- that the element type is constrained. 6501 6502 if not Is_Definite_Subtype (Element_Type) then 6503 Error_Msg_N 6504 ("unconstrained element type in array declaration", 6505 Subtype_Indication (Component_Def)); 6506 6507 elsif Is_Abstract_Type (Element_Type) then 6508 Error_Msg_N 6509 ("the type of a component cannot be abstract", 6510 Subtype_Indication (Component_Def)); 6511 end if; 6512 6513 -- There may be an invariant declared for the component type, but 6514 -- the construction of the component invariant checking procedure 6515 -- takes place during expansion. 6516 end Array_Type_Declaration; 6517 6518 ------------------------------------------------------ 6519 -- Replace_Anonymous_Access_To_Protected_Subprogram -- 6520 ------------------------------------------------------ 6521 6522 function Replace_Anonymous_Access_To_Protected_Subprogram 6523 (N : Node_Id) return Entity_Id 6524 is 6525 Loc : constant Source_Ptr := Sloc (N); 6526 6527 Curr_Scope : constant Scope_Stack_Entry := 6528 Scope_Stack.Table (Scope_Stack.Last); 6529 6530 Anon : constant Entity_Id := Make_Temporary (Loc, 'S'); 6531 6532 Acc : Node_Id; 6533 -- Access definition in declaration 6534 6535 Comp : Node_Id; 6536 -- Object definition or formal definition with an access definition 6537 6538 Decl : Node_Id; 6539 -- Declaration of anonymous access to subprogram type 6540 6541 Spec : Node_Id; 6542 -- Original specification in access to subprogram 6543 6544 P : Node_Id; 6545 6546 begin 6547 Set_Is_Internal (Anon); 6548 6549 case Nkind (N) is 6550 when N_Constrained_Array_Definition 6551 | N_Component_Declaration 6552 | N_Unconstrained_Array_Definition 6553 => 6554 Comp := Component_Definition (N); 6555 Acc := Access_Definition (Comp); 6556 6557 when N_Discriminant_Specification => 6558 Comp := Discriminant_Type (N); 6559 Acc := Comp; 6560 6561 when N_Parameter_Specification => 6562 Comp := Parameter_Type (N); 6563 Acc := Comp; 6564 6565 when N_Access_Function_Definition => 6566 Comp := Result_Definition (N); 6567 Acc := Comp; 6568 6569 when N_Object_Declaration => 6570 Comp := Object_Definition (N); 6571 Acc := Comp; 6572 6573 when N_Function_Specification => 6574 Comp := Result_Definition (N); 6575 Acc := Comp; 6576 6577 when others => 6578 raise Program_Error; 6579 end case; 6580 6581 Spec := Access_To_Subprogram_Definition (Acc); 6582 6583 Decl := 6584 Make_Full_Type_Declaration (Loc, 6585 Defining_Identifier => Anon, 6586 Type_Definition => Copy_Separate_Tree (Spec)); 6587 6588 Mark_Rewrite_Insertion (Decl); 6589 6590 -- Insert the new declaration in the nearest enclosing scope. If the 6591 -- parent is a body and N is its return type, the declaration belongs 6592 -- in the enclosing scope. Likewise if N is the type of a parameter. 6593 6594 P := Parent (N); 6595 6596 if Nkind (N) = N_Function_Specification 6597 and then Nkind (P) = N_Subprogram_Body 6598 then 6599 P := Parent (P); 6600 elsif Nkind (N) = N_Parameter_Specification 6601 and then Nkind (P) in N_Subprogram_Specification 6602 and then Nkind (Parent (P)) = N_Subprogram_Body 6603 then 6604 P := Parent (Parent (P)); 6605 end if; 6606 6607 while Present (P) and then not Has_Declarations (P) loop 6608 P := Parent (P); 6609 end loop; 6610 6611 pragma Assert (Present (P)); 6612 6613 if Nkind (P) = N_Package_Specification then 6614 Prepend (Decl, Visible_Declarations (P)); 6615 else 6616 Prepend (Decl, Declarations (P)); 6617 end if; 6618 6619 -- Replace the anonymous type with an occurrence of the new declaration. 6620 -- In all cases the rewritten node does not have the null-exclusion 6621 -- attribute because (if present) it was already inherited by the 6622 -- anonymous entity (Anon). Thus, in case of components we do not 6623 -- inherit this attribute. 6624 6625 if Nkind (N) = N_Parameter_Specification then 6626 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 6627 Set_Etype (Defining_Identifier (N), Anon); 6628 Set_Null_Exclusion_Present (N, False); 6629 6630 elsif Nkind (N) = N_Object_Declaration then 6631 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 6632 Set_Etype (Defining_Identifier (N), Anon); 6633 6634 elsif Nkind (N) = N_Access_Function_Definition then 6635 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 6636 6637 elsif Nkind (N) = N_Function_Specification then 6638 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 6639 Set_Etype (Defining_Unit_Name (N), Anon); 6640 6641 else 6642 Rewrite (Comp, 6643 Make_Component_Definition (Loc, 6644 Subtype_Indication => New_Occurrence_Of (Anon, Loc))); 6645 end if; 6646 6647 Mark_Rewrite_Insertion (Comp); 6648 6649 if Nkind (N) in N_Object_Declaration | N_Access_Function_Definition 6650 or else (Nkind (Parent (N)) = N_Full_Type_Declaration 6651 and then not Is_Type (Current_Scope)) 6652 then 6653 6654 -- Declaration can be analyzed in the current scope. 6655 6656 Analyze (Decl); 6657 6658 else 6659 -- Temporarily remove the current scope (record or subprogram) from 6660 -- the stack to add the new declarations to the enclosing scope. 6661 -- The anonymous entity is an Itype with the proper attributes. 6662 6663 Scope_Stack.Decrement_Last; 6664 Analyze (Decl); 6665 Set_Is_Itype (Anon); 6666 Set_Associated_Node_For_Itype (Anon, N); 6667 Scope_Stack.Append (Curr_Scope); 6668 end if; 6669 6670 Mutate_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type); 6671 Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target); 6672 return Anon; 6673 end Replace_Anonymous_Access_To_Protected_Subprogram; 6674 6675 ------------------------------------- 6676 -- Build_Access_Subprogram_Wrapper -- 6677 ------------------------------------- 6678 6679 procedure Build_Access_Subprogram_Wrapper (Decl : Node_Id) is 6680 Loc : constant Source_Ptr := Sloc (Decl); 6681 Id : constant Entity_Id := Defining_Identifier (Decl); 6682 Type_Def : constant Node_Id := Type_Definition (Decl); 6683 Specs : constant List_Id := 6684 Parameter_Specifications (Type_Def); 6685 Profile : constant List_Id := New_List; 6686 Subp : constant Entity_Id := Make_Temporary (Loc, 'A'); 6687 6688 Contracts : constant List_Id := New_List; 6689 Form_P : Node_Id; 6690 New_P : Node_Id; 6691 New_Decl : Node_Id; 6692 Spec : Node_Id; 6693 6694 procedure Replace_Type_Name (Expr : Node_Id); 6695 -- In the expressions for contract aspects, replace occurrences of the 6696 -- access type with the name of the subprogram entity, as needed, e.g. 6697 -- for 'Result. Aspects that are not contracts, e.g. Size or Alignment) 6698 -- remain on the original access type declaration. What about expanded 6699 -- names denoting formals, whose prefix in source is the type name ??? 6700 6701 ----------------------- 6702 -- Replace_Type_Name -- 6703 ----------------------- 6704 6705 procedure Replace_Type_Name (Expr : Node_Id) is 6706 function Process (N : Node_Id) return Traverse_Result; 6707 function Process (N : Node_Id) return Traverse_Result is 6708 begin 6709 if Nkind (N) = N_Attribute_Reference 6710 and then Is_Entity_Name (Prefix (N)) 6711 and then Chars (Prefix (N)) = Chars (Id) 6712 then 6713 Set_Prefix (N, Make_Identifier (Sloc (N), Chars (Subp))); 6714 end if; 6715 6716 return OK; 6717 end Process; 6718 6719 procedure Traverse is new Traverse_Proc (Process); 6720 begin 6721 Traverse (Expr); 6722 end Replace_Type_Name; 6723 6724 begin 6725 if Ekind (Id) in E_Access_Subprogram_Type 6726 | E_Access_Protected_Subprogram_Type 6727 | E_Anonymous_Access_Protected_Subprogram_Type 6728 | E_Anonymous_Access_Subprogram_Type 6729 then 6730 null; 6731 6732 else 6733 Error_Msg_N 6734 ("illegal pre/postcondition on access type", Decl); 6735 return; 6736 end if; 6737 6738 declare 6739 Asp : Node_Id; 6740 A_Id : Aspect_Id; 6741 Cond : Node_Id; 6742 Expr : Node_Id; 6743 6744 begin 6745 Asp := First (Aspect_Specifications (Decl)); 6746 while Present (Asp) loop 6747 A_Id := Get_Aspect_Id (Chars (Identifier (Asp))); 6748 if A_Id = Aspect_Pre or else A_Id = Aspect_Post then 6749 Cond := Asp; 6750 Expr := Expression (Cond); 6751 Replace_Type_Name (Expr); 6752 Next (Asp); 6753 6754 Remove (Cond); 6755 Append (Cond, Contracts); 6756 6757 else 6758 Next (Asp); 6759 end if; 6760 end loop; 6761 end; 6762 6763 -- If there are no contract aspects, no need for a wrapper. 6764 6765 if Is_Empty_List (Contracts) then 6766 return; 6767 end if; 6768 6769 Form_P := First (Specs); 6770 6771 while Present (Form_P) loop 6772 New_P := New_Copy_Tree (Form_P); 6773 Set_Defining_Identifier (New_P, 6774 Make_Defining_Identifier 6775 (Loc, Chars (Defining_Identifier (Form_P)))); 6776 Append (New_P, Profile); 6777 Next (Form_P); 6778 end loop; 6779 6780 -- Add to parameter specifications the access parameter that is passed 6781 -- in from an indirect call. 6782 6783 Append ( 6784 Make_Parameter_Specification (Loc, 6785 Defining_Identifier => Make_Temporary (Loc, 'P'), 6786 Parameter_Type => New_Occurrence_Of (Id, Loc)), 6787 Profile); 6788 6789 if Nkind (Type_Def) = N_Access_Procedure_Definition then 6790 Spec := 6791 Make_Procedure_Specification (Loc, 6792 Defining_Unit_Name => Subp, 6793 Parameter_Specifications => Profile); 6794 Mutate_Ekind (Subp, E_Procedure); 6795 else 6796 Spec := 6797 Make_Function_Specification (Loc, 6798 Defining_Unit_Name => Subp, 6799 Parameter_Specifications => Profile, 6800 Result_Definition => 6801 New_Copy_Tree 6802 (Result_Definition (Type_Definition (Decl)))); 6803 Mutate_Ekind (Subp, E_Function); 6804 end if; 6805 6806 New_Decl := 6807 Make_Subprogram_Declaration (Loc, Specification => Spec); 6808 Set_Aspect_Specifications (New_Decl, Contracts); 6809 Set_Is_Wrapper (Subp); 6810 6811 -- The wrapper is declared in the freezing actions to facilitate its 6812 -- identification and thus avoid handling it as a primitive operation 6813 -- of a tagged type (see Is_Access_To_Subprogram_Wrapper); otherwise it 6814 -- may be handled as a dispatching operation and erroneously registered 6815 -- in a dispatch table. 6816 6817 if not GNATprove_Mode then 6818 Append_Freeze_Action (Id, New_Decl); 6819 6820 -- Under GNATprove mode there is no such problem but we do not declare 6821 -- it in the freezing actions since they are not analyzed under this 6822 -- mode. 6823 6824 else 6825 Insert_After (Decl, New_Decl); 6826 end if; 6827 6828 Set_Access_Subprogram_Wrapper (Designated_Type (Id), Subp); 6829 Build_Access_Subprogram_Wrapper_Body (Decl, New_Decl); 6830 end Build_Access_Subprogram_Wrapper; 6831 6832 ------------------------------- 6833 -- Build_Derived_Access_Type -- 6834 ------------------------------- 6835 6836 procedure Build_Derived_Access_Type 6837 (N : Node_Id; 6838 Parent_Type : Entity_Id; 6839 Derived_Type : Entity_Id) 6840 is 6841 S : constant Node_Id := Subtype_Indication (Type_Definition (N)); 6842 6843 Desig_Type : Entity_Id; 6844 Discr : Entity_Id; 6845 Discr_Con_Elist : Elist_Id; 6846 Discr_Con_El : Elmt_Id; 6847 Subt : Entity_Id; 6848 6849 begin 6850 -- Set the designated type so it is available in case this is an access 6851 -- to a self-referential type, e.g. a standard list type with a next 6852 -- pointer. Will be reset after subtype is built. 6853 6854 Set_Directly_Designated_Type 6855 (Derived_Type, Designated_Type (Parent_Type)); 6856 6857 Subt := Process_Subtype (S, N); 6858 6859 if Nkind (S) /= N_Subtype_Indication 6860 and then Subt /= Base_Type (Subt) 6861 then 6862 Mutate_Ekind (Derived_Type, E_Access_Subtype); 6863 end if; 6864 6865 if Ekind (Derived_Type) = E_Access_Subtype then 6866 declare 6867 Pbase : constant Entity_Id := Base_Type (Parent_Type); 6868 Ibase : constant Entity_Id := 6869 Create_Itype (Ekind (Pbase), N, Derived_Type, 'B'); 6870 Svg_Chars : constant Name_Id := Chars (Ibase); 6871 Svg_Next_E : constant Entity_Id := Next_Entity (Ibase); 6872 Svg_Prev_E : constant Entity_Id := Prev_Entity (Ibase); 6873 6874 begin 6875 Copy_Node (Pbase, Ibase); 6876 6877 -- Restore Itype status after Copy_Node 6878 6879 Set_Is_Itype (Ibase); 6880 Set_Associated_Node_For_Itype (Ibase, N); 6881 6882 Set_Chars (Ibase, Svg_Chars); 6883 Set_Prev_Entity (Ibase, Svg_Prev_E); 6884 Set_Next_Entity (Ibase, Svg_Next_E); 6885 Set_Sloc (Ibase, Sloc (Derived_Type)); 6886 Set_Scope (Ibase, Scope (Derived_Type)); 6887 Set_Freeze_Node (Ibase, Empty); 6888 Set_Is_Frozen (Ibase, False); 6889 Set_Comes_From_Source (Ibase, False); 6890 Set_Is_First_Subtype (Ibase, False); 6891 6892 Set_Etype (Ibase, Pbase); 6893 Set_Etype (Derived_Type, Ibase); 6894 end; 6895 end if; 6896 6897 Set_Directly_Designated_Type 6898 (Derived_Type, Designated_Type (Subt)); 6899 6900 Set_Is_Constrained (Derived_Type, Is_Constrained (Subt)); 6901 Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type)); 6902 Set_Size_Info (Derived_Type, Parent_Type); 6903 Copy_RM_Size (To => Derived_Type, From => Parent_Type); 6904 Set_Depends_On_Private (Derived_Type, 6905 Has_Private_Component (Derived_Type)); 6906 Conditional_Delay (Derived_Type, Subt); 6907 6908 if Is_Access_Subprogram_Type (Derived_Type) 6909 and then Is_Base_Type (Derived_Type) 6910 then 6911 Set_Can_Use_Internal_Rep 6912 (Derived_Type, Can_Use_Internal_Rep (Parent_Type)); 6913 end if; 6914 6915 -- Ada 2005 (AI-231): Set the null-exclusion attribute, and verify 6916 -- that it is not redundant. 6917 6918 if Null_Exclusion_Present (Type_Definition (N)) then 6919 Set_Can_Never_Be_Null (Derived_Type); 6920 6921 elsif Can_Never_Be_Null (Parent_Type) then 6922 Set_Can_Never_Be_Null (Derived_Type); 6923 end if; 6924 6925 -- Note: we do not copy the Storage_Size_Variable, since we always go to 6926 -- the root type for this information. 6927 6928 -- Apply range checks to discriminants for derived record case 6929 -- ??? THIS CODE SHOULD NOT BE HERE REALLY. 6930 6931 Desig_Type := Designated_Type (Derived_Type); 6932 6933 if Is_Composite_Type (Desig_Type) 6934 and then (not Is_Array_Type (Desig_Type)) 6935 and then Has_Discriminants (Desig_Type) 6936 and then Base_Type (Desig_Type) /= Desig_Type 6937 then 6938 Discr_Con_Elist := Discriminant_Constraint (Desig_Type); 6939 Discr_Con_El := First_Elmt (Discr_Con_Elist); 6940 6941 Discr := First_Discriminant (Base_Type (Desig_Type)); 6942 while Present (Discr_Con_El) loop 6943 Apply_Range_Check (Node (Discr_Con_El), Etype (Discr)); 6944 Next_Elmt (Discr_Con_El); 6945 Next_Discriminant (Discr); 6946 end loop; 6947 end if; 6948 end Build_Derived_Access_Type; 6949 6950 ------------------------------ 6951 -- Build_Derived_Array_Type -- 6952 ------------------------------ 6953 6954 procedure Build_Derived_Array_Type 6955 (N : Node_Id; 6956 Parent_Type : Entity_Id; 6957 Derived_Type : Entity_Id) 6958 is 6959 Loc : constant Source_Ptr := Sloc (N); 6960 Tdef : constant Node_Id := Type_Definition (N); 6961 Indic : constant Node_Id := Subtype_Indication (Tdef); 6962 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 6963 Implicit_Base : Entity_Id := Empty; 6964 New_Indic : Node_Id; 6965 6966 procedure Make_Implicit_Base; 6967 -- If the parent subtype is constrained, the derived type is a subtype 6968 -- of an implicit base type derived from the parent base. 6969 6970 ------------------------ 6971 -- Make_Implicit_Base -- 6972 ------------------------ 6973 6974 procedure Make_Implicit_Base is 6975 begin 6976 Implicit_Base := 6977 Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); 6978 6979 Mutate_Ekind (Implicit_Base, Ekind (Parent_Base)); 6980 Set_Etype (Implicit_Base, Parent_Base); 6981 6982 Copy_Array_Subtype_Attributes (Implicit_Base, Parent_Base); 6983 Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base); 6984 6985 Set_Has_Delayed_Freeze (Implicit_Base, True); 6986 end Make_Implicit_Base; 6987 6988 -- Start of processing for Build_Derived_Array_Type 6989 6990 begin 6991 if not Is_Constrained (Parent_Type) then 6992 if Nkind (Indic) /= N_Subtype_Indication then 6993 Mutate_Ekind (Derived_Type, E_Array_Type); 6994 6995 Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); 6996 Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type); 6997 6998 Set_Has_Delayed_Freeze (Derived_Type, True); 6999 7000 else 7001 Make_Implicit_Base; 7002 Set_Etype (Derived_Type, Implicit_Base); 7003 7004 New_Indic := 7005 Make_Subtype_Declaration (Loc, 7006 Defining_Identifier => Derived_Type, 7007 Subtype_Indication => 7008 Make_Subtype_Indication (Loc, 7009 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc), 7010 Constraint => Constraint (Indic))); 7011 7012 Rewrite (N, New_Indic); 7013 Analyze (N); 7014 end if; 7015 7016 else 7017 if Nkind (Indic) /= N_Subtype_Indication then 7018 Make_Implicit_Base; 7019 7020 Mutate_Ekind (Derived_Type, Ekind (Parent_Type)); 7021 Set_Etype (Derived_Type, Implicit_Base); 7022 Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); 7023 7024 else 7025 Error_Msg_N ("illegal constraint on constrained type", Indic); 7026 end if; 7027 end if; 7028 7029 -- If parent type is not a derived type itself, and is declared in 7030 -- closed scope (e.g. a subprogram), then we must explicitly introduce 7031 -- the new type's concatenation operator since Derive_Subprograms 7032 -- will not inherit the parent's operator. If the parent type is 7033 -- unconstrained, the operator is of the unconstrained base type. 7034 7035 if Number_Dimensions (Parent_Type) = 1 7036 and then not Is_Limited_Type (Parent_Type) 7037 and then not Is_Derived_Type (Parent_Type) 7038 and then not Is_Package_Or_Generic_Package 7039 (Scope (Base_Type (Parent_Type))) 7040 then 7041 if not Is_Constrained (Parent_Type) 7042 and then Is_Constrained (Derived_Type) 7043 then 7044 New_Concatenation_Op (Implicit_Base); 7045 else 7046 New_Concatenation_Op (Derived_Type); 7047 end if; 7048 end if; 7049 end Build_Derived_Array_Type; 7050 7051 ----------------------------------- 7052 -- Build_Derived_Concurrent_Type -- 7053 ----------------------------------- 7054 7055 procedure Build_Derived_Concurrent_Type 7056 (N : Node_Id; 7057 Parent_Type : Entity_Id; 7058 Derived_Type : Entity_Id) 7059 is 7060 Loc : constant Source_Ptr := Sloc (N); 7061 Def : constant Node_Id := Type_Definition (N); 7062 Indic : constant Node_Id := Subtype_Indication (Def); 7063 7064 Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C'); 7065 Corr_Decl : Node_Id; 7066 Corr_Decl_Needed : Boolean; 7067 -- If the derived type has fewer discriminants than its parent, the 7068 -- corresponding record is also a derived type, in order to account for 7069 -- the bound discriminants. We create a full type declaration for it in 7070 -- this case. 7071 7072 Constraint_Present : constant Boolean := 7073 Nkind (Indic) = N_Subtype_Indication; 7074 7075 D_Constraint : Node_Id; 7076 New_Constraint : Elist_Id := No_Elist; 7077 Old_Disc : Entity_Id; 7078 New_Disc : Entity_Id; 7079 New_N : Node_Id; 7080 7081 begin 7082 Set_Stored_Constraint (Derived_Type, No_Elist); 7083 Corr_Decl_Needed := False; 7084 Old_Disc := Empty; 7085 7086 if Present (Discriminant_Specifications (N)) 7087 and then Constraint_Present 7088 then 7089 Old_Disc := First_Discriminant (Parent_Type); 7090 New_Disc := First (Discriminant_Specifications (N)); 7091 while Present (New_Disc) and then Present (Old_Disc) loop 7092 Next_Discriminant (Old_Disc); 7093 Next (New_Disc); 7094 end loop; 7095 end if; 7096 7097 if Present (Old_Disc) and then Expander_Active then 7098 7099 -- The new type has fewer discriminants, so we need to create a new 7100 -- corresponding record, which is derived from the corresponding 7101 -- record of the parent, and has a stored constraint that captures 7102 -- the values of the discriminant constraints. The corresponding 7103 -- record is needed only if expander is active and code generation is 7104 -- enabled. 7105 7106 -- The type declaration for the derived corresponding record has the 7107 -- same discriminant part and constraints as the current declaration. 7108 -- Copy the unanalyzed tree to build declaration. 7109 7110 Corr_Decl_Needed := True; 7111 New_N := Copy_Separate_Tree (N); 7112 7113 Corr_Decl := 7114 Make_Full_Type_Declaration (Loc, 7115 Defining_Identifier => Corr_Record, 7116 Discriminant_Specifications => 7117 Discriminant_Specifications (New_N), 7118 Type_Definition => 7119 Make_Derived_Type_Definition (Loc, 7120 Subtype_Indication => 7121 Make_Subtype_Indication (Loc, 7122 Subtype_Mark => 7123 New_Occurrence_Of 7124 (Corresponding_Record_Type (Parent_Type), Loc), 7125 Constraint => 7126 Constraint 7127 (Subtype_Indication (Type_Definition (New_N)))))); 7128 end if; 7129 7130 -- Copy Storage_Size and Relative_Deadline variables if task case 7131 7132 if Is_Task_Type (Parent_Type) then 7133 Set_Storage_Size_Variable (Derived_Type, 7134 Storage_Size_Variable (Parent_Type)); 7135 Set_Relative_Deadline_Variable (Derived_Type, 7136 Relative_Deadline_Variable (Parent_Type)); 7137 end if; 7138 7139 if Present (Discriminant_Specifications (N)) then 7140 Push_Scope (Derived_Type); 7141 Check_Or_Process_Discriminants (N, Derived_Type); 7142 7143 if Constraint_Present then 7144 New_Constraint := 7145 Expand_To_Stored_Constraint 7146 (Parent_Type, 7147 Build_Discriminant_Constraints 7148 (Parent_Type, Indic, True)); 7149 end if; 7150 7151 End_Scope; 7152 7153 elsif Constraint_Present then 7154 7155 -- Build an unconstrained derived type and rewrite the derived type 7156 -- as a subtype of this new base type. 7157 7158 declare 7159 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 7160 New_Base : Entity_Id; 7161 New_Decl : Node_Id; 7162 New_Indic : Node_Id; 7163 7164 begin 7165 New_Base := 7166 Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B'); 7167 7168 New_Decl := 7169 Make_Full_Type_Declaration (Loc, 7170 Defining_Identifier => New_Base, 7171 Type_Definition => 7172 Make_Derived_Type_Definition (Loc, 7173 Abstract_Present => Abstract_Present (Def), 7174 Limited_Present => Limited_Present (Def), 7175 Subtype_Indication => 7176 New_Occurrence_Of (Parent_Base, Loc))); 7177 7178 Mark_Rewrite_Insertion (New_Decl); 7179 Insert_Before (N, New_Decl); 7180 Analyze (New_Decl); 7181 7182 New_Indic := 7183 Make_Subtype_Indication (Loc, 7184 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 7185 Constraint => Relocate_Node (Constraint (Indic))); 7186 7187 Rewrite (N, 7188 Make_Subtype_Declaration (Loc, 7189 Defining_Identifier => Derived_Type, 7190 Subtype_Indication => New_Indic)); 7191 7192 Analyze (N); 7193 return; 7194 end; 7195 end if; 7196 7197 -- By default, operations and private data are inherited from parent. 7198 -- However, in the presence of bound discriminants, a new corresponding 7199 -- record will be created, see below. 7200 7201 Set_Has_Discriminants 7202 (Derived_Type, Has_Discriminants (Parent_Type)); 7203 Set_Corresponding_Record_Type 7204 (Derived_Type, Corresponding_Record_Type (Parent_Type)); 7205 7206 -- Is_Constrained is set according the parent subtype, but is set to 7207 -- False if the derived type is declared with new discriminants. 7208 7209 Set_Is_Constrained 7210 (Derived_Type, 7211 (Is_Constrained (Parent_Type) or else Constraint_Present) 7212 and then not Present (Discriminant_Specifications (N))); 7213 7214 if Constraint_Present then 7215 if not Has_Discriminants (Parent_Type) then 7216 Error_Msg_N ("untagged parent must have discriminants", N); 7217 7218 elsif Present (Discriminant_Specifications (N)) then 7219 7220 -- Verify that new discriminants are used to constrain old ones 7221 7222 D_Constraint := First (Constraints (Constraint (Indic))); 7223 7224 Old_Disc := First_Discriminant (Parent_Type); 7225 7226 while Present (D_Constraint) loop 7227 if Nkind (D_Constraint) /= N_Discriminant_Association then 7228 7229 -- Positional constraint. If it is a reference to a new 7230 -- discriminant, it constrains the corresponding old one. 7231 7232 if Nkind (D_Constraint) = N_Identifier then 7233 New_Disc := First_Discriminant (Derived_Type); 7234 while Present (New_Disc) loop 7235 exit when Chars (New_Disc) = Chars (D_Constraint); 7236 Next_Discriminant (New_Disc); 7237 end loop; 7238 7239 if Present (New_Disc) then 7240 Set_Corresponding_Discriminant (New_Disc, Old_Disc); 7241 end if; 7242 end if; 7243 7244 Next_Discriminant (Old_Disc); 7245 7246 -- if this is a named constraint, search by name for the old 7247 -- discriminants constrained by the new one. 7248 7249 elsif Nkind (Expression (D_Constraint)) = N_Identifier then 7250 7251 -- Find new discriminant with that name 7252 7253 New_Disc := First_Discriminant (Derived_Type); 7254 while Present (New_Disc) loop 7255 exit when 7256 Chars (New_Disc) = Chars (Expression (D_Constraint)); 7257 Next_Discriminant (New_Disc); 7258 end loop; 7259 7260 if Present (New_Disc) then 7261 7262 -- Verify that new discriminant renames some discriminant 7263 -- of the parent type, and associate the new discriminant 7264 -- with one or more old ones that it renames. 7265 7266 declare 7267 Selector : Node_Id; 7268 7269 begin 7270 Selector := First (Selector_Names (D_Constraint)); 7271 while Present (Selector) loop 7272 Old_Disc := First_Discriminant (Parent_Type); 7273 while Present (Old_Disc) loop 7274 exit when Chars (Old_Disc) = Chars (Selector); 7275 Next_Discriminant (Old_Disc); 7276 end loop; 7277 7278 if Present (Old_Disc) then 7279 Set_Corresponding_Discriminant 7280 (New_Disc, Old_Disc); 7281 end if; 7282 7283 Next (Selector); 7284 end loop; 7285 end; 7286 end if; 7287 end if; 7288 7289 Next (D_Constraint); 7290 end loop; 7291 7292 New_Disc := First_Discriminant (Derived_Type); 7293 while Present (New_Disc) loop 7294 if No (Corresponding_Discriminant (New_Disc)) then 7295 Error_Msg_NE 7296 ("new discriminant& must constrain old one", N, New_Disc); 7297 7298 -- If a new discriminant is used in the constraint, then its 7299 -- subtype must be statically compatible with the subtype of 7300 -- the parent discriminant (RM 3.7(15)). 7301 7302 else 7303 Check_Constraining_Discriminant 7304 (New_Disc, Corresponding_Discriminant (New_Disc)); 7305 end if; 7306 7307 Next_Discriminant (New_Disc); 7308 end loop; 7309 end if; 7310 7311 elsif Present (Discriminant_Specifications (N)) then 7312 Error_Msg_N 7313 ("missing discriminant constraint in untagged derivation", N); 7314 end if; 7315 7316 -- The entity chain of the derived type includes the new discriminants 7317 -- but shares operations with the parent. 7318 7319 if Present (Discriminant_Specifications (N)) then 7320 Old_Disc := First_Discriminant (Parent_Type); 7321 while Present (Old_Disc) loop 7322 if No (Next_Entity (Old_Disc)) 7323 or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant 7324 then 7325 Link_Entities 7326 (Last_Entity (Derived_Type), Next_Entity (Old_Disc)); 7327 exit; 7328 end if; 7329 7330 Next_Discriminant (Old_Disc); 7331 end loop; 7332 7333 else 7334 Set_First_Entity (Derived_Type, First_Entity (Parent_Type)); 7335 if Has_Discriminants (Parent_Type) then 7336 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 7337 Set_Discriminant_Constraint ( 7338 Derived_Type, Discriminant_Constraint (Parent_Type)); 7339 end if; 7340 end if; 7341 7342 Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type)); 7343 7344 Set_Has_Completion (Derived_Type); 7345 7346 if Corr_Decl_Needed then 7347 Set_Stored_Constraint (Derived_Type, New_Constraint); 7348 Insert_After (N, Corr_Decl); 7349 Analyze (Corr_Decl); 7350 Set_Corresponding_Record_Type (Derived_Type, Corr_Record); 7351 end if; 7352 end Build_Derived_Concurrent_Type; 7353 7354 ------------------------------------ 7355 -- Build_Derived_Enumeration_Type -- 7356 ------------------------------------ 7357 7358 procedure Build_Derived_Enumeration_Type 7359 (N : Node_Id; 7360 Parent_Type : Entity_Id; 7361 Derived_Type : Entity_Id) 7362 is 7363 function Bound_Belongs_To_Type (B : Node_Id) return Boolean; 7364 -- When the type declaration includes a constraint, we generate 7365 -- a subtype declaration of an anonymous base type, with the constraint 7366 -- given in the original type declaration. Conceptually, the bounds 7367 -- are converted to the new base type, and this conversion freezes 7368 -- (prematurely) that base type, when the bounds are simply literals. 7369 -- As a result, a representation clause for the derived type is then 7370 -- rejected or ignored. This procedure recognizes the simple case of 7371 -- literal bounds, which allows us to indicate that the conversions 7372 -- are not freeze points, and the subsequent representation clause 7373 -- can be accepted. 7374 -- A similar approach might be used to resolve the long-standing 7375 -- problem of premature freezing of derived numeric types ??? 7376 7377 function Bound_Belongs_To_Type (B : Node_Id) return Boolean is 7378 begin 7379 return Nkind (B) = N_Type_Conversion 7380 and then Is_Entity_Name (Expression (B)) 7381 and then Ekind (Entity (Expression (B))) = E_Enumeration_Literal; 7382 end Bound_Belongs_To_Type; 7383 7384 Loc : constant Source_Ptr := Sloc (N); 7385 Def : constant Node_Id := Type_Definition (N); 7386 Indic : constant Node_Id := Subtype_Indication (Def); 7387 Implicit_Base : Entity_Id; 7388 Literal : Entity_Id; 7389 New_Lit : Entity_Id; 7390 Literals_List : List_Id; 7391 Type_Decl : Node_Id; 7392 Hi, Lo : Node_Id; 7393 Rang_Expr : Node_Id; 7394 7395 begin 7396 -- Since types Standard.Character and Standard.[Wide_]Wide_Character do 7397 -- not have explicit literals lists we need to process types derived 7398 -- from them specially. This is handled by Derived_Standard_Character. 7399 -- If the parent type is a generic type, there are no literals either, 7400 -- and we construct the same skeletal representation as for the generic 7401 -- parent type. 7402 7403 if Is_Standard_Character_Type (Parent_Type) then 7404 Derived_Standard_Character (N, Parent_Type, Derived_Type); 7405 7406 elsif Is_Generic_Type (Root_Type (Parent_Type)) then 7407 declare 7408 Lo : Node_Id; 7409 Hi : Node_Id; 7410 7411 begin 7412 if Nkind (Indic) /= N_Subtype_Indication then 7413 Lo := 7414 Make_Attribute_Reference (Loc, 7415 Attribute_Name => Name_First, 7416 Prefix => New_Occurrence_Of (Derived_Type, Loc)); 7417 Set_Etype (Lo, Derived_Type); 7418 7419 Hi := 7420 Make_Attribute_Reference (Loc, 7421 Attribute_Name => Name_Last, 7422 Prefix => New_Occurrence_Of (Derived_Type, Loc)); 7423 Set_Etype (Hi, Derived_Type); 7424 7425 Set_Scalar_Range (Derived_Type, 7426 Make_Range (Loc, 7427 Low_Bound => Lo, 7428 High_Bound => Hi)); 7429 else 7430 7431 -- Analyze subtype indication and verify compatibility 7432 -- with parent type. 7433 7434 if Base_Type (Process_Subtype (Indic, N)) /= 7435 Base_Type (Parent_Type) 7436 then 7437 Error_Msg_N 7438 ("illegal constraint for formal discrete type", N); 7439 end if; 7440 end if; 7441 end; 7442 7443 else 7444 -- If a constraint is present, analyze the bounds to catch 7445 -- premature usage of the derived literals. 7446 7447 if Nkind (Indic) = N_Subtype_Indication 7448 and then Nkind (Range_Expression (Constraint (Indic))) = N_Range 7449 then 7450 Analyze (Low_Bound (Range_Expression (Constraint (Indic)))); 7451 Analyze (High_Bound (Range_Expression (Constraint (Indic)))); 7452 end if; 7453 7454 -- Introduce an implicit base type for the derived type even if there 7455 -- is no constraint attached to it, since this seems closer to the 7456 -- Ada semantics. Build a full type declaration tree for the derived 7457 -- type using the implicit base type as the defining identifier. Then 7458 -- build a subtype declaration tree which applies the constraint (if 7459 -- any) have it replace the derived type declaration. 7460 7461 Literal := First_Literal (Parent_Type); 7462 Literals_List := New_List; 7463 while Present (Literal) 7464 and then Ekind (Literal) = E_Enumeration_Literal 7465 loop 7466 -- Literals of the derived type have the same representation as 7467 -- those of the parent type, but this representation can be 7468 -- overridden by an explicit representation clause. Indicate 7469 -- that there is no explicit representation given yet. These 7470 -- derived literals are implicit operations of the new type, 7471 -- and can be overridden by explicit ones. 7472 7473 if Nkind (Literal) = N_Defining_Character_Literal then 7474 New_Lit := 7475 Make_Defining_Character_Literal (Loc, Chars (Literal)); 7476 else 7477 New_Lit := Make_Defining_Identifier (Loc, Chars (Literal)); 7478 end if; 7479 7480 Mutate_Ekind (New_Lit, E_Enumeration_Literal); 7481 Set_Enumeration_Pos (New_Lit, Enumeration_Pos (Literal)); 7482 Set_Enumeration_Rep (New_Lit, Enumeration_Rep (Literal)); 7483 Set_Enumeration_Rep_Expr (New_Lit, Empty); 7484 Set_Alias (New_Lit, Literal); 7485 Set_Is_Known_Valid (New_Lit, True); 7486 7487 Append (New_Lit, Literals_List); 7488 Next_Literal (Literal); 7489 end loop; 7490 7491 Implicit_Base := 7492 Make_Defining_Identifier (Sloc (Derived_Type), 7493 Chars => New_External_Name (Chars (Derived_Type), 'B')); 7494 7495 -- Indicate the proper nature of the derived type. This must be done 7496 -- before analysis of the literals, to recognize cases when a literal 7497 -- may be hidden by a previous explicit function definition (cf. 7498 -- c83031a). 7499 7500 Mutate_Ekind (Derived_Type, E_Enumeration_Subtype); 7501 Set_Etype (Derived_Type, Implicit_Base); 7502 7503 Type_Decl := 7504 Make_Full_Type_Declaration (Loc, 7505 Defining_Identifier => Implicit_Base, 7506 Discriminant_Specifications => No_List, 7507 Type_Definition => 7508 Make_Enumeration_Type_Definition (Loc, Literals_List)); 7509 7510 Mark_Rewrite_Insertion (Type_Decl); 7511 Insert_Before (N, Type_Decl); 7512 Analyze (Type_Decl); 7513 7514 -- The anonymous base now has a full declaration, but this base 7515 -- is not a first subtype. 7516 7517 Set_Is_First_Subtype (Implicit_Base, False); 7518 7519 -- After the implicit base is analyzed its Etype needs to be changed 7520 -- to reflect the fact that it is derived from the parent type which 7521 -- was ignored during analysis. We also set the size at this point. 7522 7523 Set_Etype (Implicit_Base, Parent_Type); 7524 7525 Set_Size_Info (Implicit_Base, Parent_Type); 7526 Set_RM_Size (Implicit_Base, RM_Size (Parent_Type)); 7527 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type)); 7528 7529 -- Copy other flags from parent type 7530 7531 Set_Has_Non_Standard_Rep 7532 (Implicit_Base, Has_Non_Standard_Rep 7533 (Parent_Type)); 7534 Set_Has_Pragma_Ordered 7535 (Implicit_Base, Has_Pragma_Ordered 7536 (Parent_Type)); 7537 Set_Has_Delayed_Freeze (Implicit_Base); 7538 7539 -- Process the subtype indication including a validation check on the 7540 -- constraint, if any. If a constraint is given, its bounds must be 7541 -- implicitly converted to the new type. 7542 7543 if Nkind (Indic) = N_Subtype_Indication then 7544 declare 7545 R : constant Node_Id := 7546 Range_Expression (Constraint (Indic)); 7547 7548 begin 7549 if Nkind (R) = N_Range then 7550 Hi := Build_Scalar_Bound 7551 (High_Bound (R), Parent_Type, Implicit_Base); 7552 Lo := Build_Scalar_Bound 7553 (Low_Bound (R), Parent_Type, Implicit_Base); 7554 7555 else 7556 -- Constraint is a Range attribute. Replace with explicit 7557 -- mention of the bounds of the prefix, which must be a 7558 -- subtype. 7559 7560 Analyze (Prefix (R)); 7561 Hi := 7562 Convert_To (Implicit_Base, 7563 Make_Attribute_Reference (Loc, 7564 Attribute_Name => Name_Last, 7565 Prefix => 7566 New_Occurrence_Of (Entity (Prefix (R)), Loc))); 7567 7568 Lo := 7569 Convert_To (Implicit_Base, 7570 Make_Attribute_Reference (Loc, 7571 Attribute_Name => Name_First, 7572 Prefix => 7573 New_Occurrence_Of (Entity (Prefix (R)), Loc))); 7574 end if; 7575 end; 7576 7577 else 7578 Hi := 7579 Build_Scalar_Bound 7580 (Type_High_Bound (Parent_Type), 7581 Parent_Type, Implicit_Base); 7582 Lo := 7583 Build_Scalar_Bound 7584 (Type_Low_Bound (Parent_Type), 7585 Parent_Type, Implicit_Base); 7586 end if; 7587 7588 Rang_Expr := 7589 Make_Range (Loc, 7590 Low_Bound => Lo, 7591 High_Bound => Hi); 7592 7593 -- If we constructed a default range for the case where no range 7594 -- was given, then the expressions in the range must not freeze 7595 -- since they do not correspond to expressions in the source. 7596 -- However, if the type inherits predicates the expressions will 7597 -- be elaborated earlier and must freeze. 7598 7599 if (Nkind (Indic) /= N_Subtype_Indication 7600 or else 7601 (Bound_Belongs_To_Type (Lo) and then Bound_Belongs_To_Type (Hi))) 7602 and then not Has_Predicates (Derived_Type) 7603 then 7604 Set_Must_Not_Freeze (Lo); 7605 Set_Must_Not_Freeze (Hi); 7606 Set_Must_Not_Freeze (Rang_Expr); 7607 end if; 7608 7609 Rewrite (N, 7610 Make_Subtype_Declaration (Loc, 7611 Defining_Identifier => Derived_Type, 7612 Subtype_Indication => 7613 Make_Subtype_Indication (Loc, 7614 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc), 7615 Constraint => 7616 Make_Range_Constraint (Loc, 7617 Range_Expression => Rang_Expr)))); 7618 7619 Analyze (N); 7620 7621 -- Propagate the aspects from the original type declaration to the 7622 -- declaration of the implicit base. 7623 7624 Move_Aspects (From => Original_Node (N), To => Type_Decl); 7625 7626 -- Apply a range check. Since this range expression doesn't have an 7627 -- Etype, we have to specifically pass the Source_Typ parameter. Is 7628 -- this right??? 7629 7630 if Nkind (Indic) = N_Subtype_Indication then 7631 Apply_Range_Check 7632 (Range_Expression (Constraint (Indic)), Parent_Type, 7633 Source_Typ => Entity (Subtype_Mark (Indic))); 7634 end if; 7635 end if; 7636 end Build_Derived_Enumeration_Type; 7637 7638 -------------------------------- 7639 -- Build_Derived_Numeric_Type -- 7640 -------------------------------- 7641 7642 procedure Build_Derived_Numeric_Type 7643 (N : Node_Id; 7644 Parent_Type : Entity_Id; 7645 Derived_Type : Entity_Id) 7646 is 7647 Loc : constant Source_Ptr := Sloc (N); 7648 Tdef : constant Node_Id := Type_Definition (N); 7649 Indic : constant Node_Id := Subtype_Indication (Tdef); 7650 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 7651 No_Constraint : constant Boolean := Nkind (Indic) /= 7652 N_Subtype_Indication; 7653 Implicit_Base : Entity_Id; 7654 7655 Lo : Node_Id; 7656 Hi : Node_Id; 7657 7658 begin 7659 -- Process the subtype indication including a validation check on 7660 -- the constraint if any. 7661 7662 Discard_Node (Process_Subtype (Indic, N)); 7663 7664 -- Introduce an implicit base type for the derived type even if there 7665 -- is no constraint attached to it, since this seems closer to the Ada 7666 -- semantics. 7667 7668 Implicit_Base := 7669 Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); 7670 7671 Set_Etype (Implicit_Base, Parent_Base); 7672 Mutate_Ekind (Implicit_Base, Ekind (Parent_Base)); 7673 Set_Size_Info (Implicit_Base, Parent_Base); 7674 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base)); 7675 Set_Parent (Implicit_Base, Parent (Derived_Type)); 7676 Set_Is_Known_Valid (Implicit_Base, Is_Known_Valid (Parent_Base)); 7677 Set_Is_Volatile (Implicit_Base, Is_Volatile (Parent_Base)); 7678 7679 -- Set RM Size for discrete type or decimal fixed-point type 7680 -- Ordinary fixed-point is excluded, why??? 7681 7682 if Is_Discrete_Type (Parent_Base) 7683 or else Is_Decimal_Fixed_Point_Type (Parent_Base) 7684 then 7685 Set_RM_Size (Implicit_Base, RM_Size (Parent_Base)); 7686 end if; 7687 7688 Set_Has_Delayed_Freeze (Implicit_Base); 7689 7690 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); 7691 Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); 7692 7693 Set_Scalar_Range (Implicit_Base, 7694 Make_Range (Loc, 7695 Low_Bound => Lo, 7696 High_Bound => Hi)); 7697 7698 if Has_Infinities (Parent_Base) then 7699 Set_Includes_Infinities (Scalar_Range (Implicit_Base)); 7700 end if; 7701 7702 -- The Derived_Type, which is the entity of the declaration, is a 7703 -- subtype of the implicit base. Its Ekind is a subtype, even in the 7704 -- absence of an explicit constraint. 7705 7706 Set_Etype (Derived_Type, Implicit_Base); 7707 7708 -- If we did not have a constraint, then the Ekind is set from the 7709 -- parent type (otherwise Process_Subtype has set the bounds) 7710 7711 if No_Constraint then 7712 Mutate_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type))); 7713 end if; 7714 7715 -- If we did not have a range constraint, then set the range from the 7716 -- parent type. Otherwise, the Process_Subtype call has set the bounds. 7717 7718 if No_Constraint or else not Has_Range_Constraint (Indic) then 7719 Set_Scalar_Range (Derived_Type, 7720 Make_Range (Loc, 7721 Low_Bound => New_Copy_Tree (Type_Low_Bound (Parent_Type)), 7722 High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type)))); 7723 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 7724 7725 if Has_Infinities (Parent_Type) then 7726 Set_Includes_Infinities (Scalar_Range (Derived_Type)); 7727 end if; 7728 7729 Set_Is_Known_Valid (Derived_Type, Is_Known_Valid (Parent_Type)); 7730 end if; 7731 7732 Set_Is_Descendant_Of_Address (Derived_Type, 7733 Is_Descendant_Of_Address (Parent_Type)); 7734 Set_Is_Descendant_Of_Address (Implicit_Base, 7735 Is_Descendant_Of_Address (Parent_Type)); 7736 7737 -- Set remaining type-specific fields, depending on numeric type 7738 7739 if Is_Modular_Integer_Type (Parent_Type) then 7740 Set_Modulus (Implicit_Base, Modulus (Parent_Base)); 7741 7742 Set_Non_Binary_Modulus 7743 (Implicit_Base, Non_Binary_Modulus (Parent_Base)); 7744 7745 Set_Is_Known_Valid 7746 (Implicit_Base, Is_Known_Valid (Parent_Base)); 7747 7748 elsif Is_Floating_Point_Type (Parent_Type) then 7749 7750 -- Digits of base type is always copied from the digits value of 7751 -- the parent base type, but the digits of the derived type will 7752 -- already have been set if there was a constraint present. 7753 7754 Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); 7755 Set_Float_Rep (Implicit_Base, Float_Rep (Parent_Base)); 7756 7757 if No_Constraint then 7758 Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type)); 7759 end if; 7760 7761 elsif Is_Fixed_Point_Type (Parent_Type) then 7762 7763 -- Small of base type and derived type are always copied from the 7764 -- parent base type, since smalls never change. The delta of the 7765 -- base type is also copied from the parent base type. However the 7766 -- delta of the derived type will have been set already if a 7767 -- constraint was present. 7768 7769 Set_Small_Value (Derived_Type, Small_Value (Parent_Base)); 7770 Set_Small_Value (Implicit_Base, Small_Value (Parent_Base)); 7771 Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base)); 7772 7773 if No_Constraint then 7774 Set_Delta_Value (Derived_Type, Delta_Value (Parent_Type)); 7775 end if; 7776 7777 -- The scale and machine radix in the decimal case are always 7778 -- copied from the parent base type. 7779 7780 if Is_Decimal_Fixed_Point_Type (Parent_Type) then 7781 Set_Scale_Value (Derived_Type, Scale_Value (Parent_Base)); 7782 Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base)); 7783 7784 Set_Machine_Radix_10 7785 (Derived_Type, Machine_Radix_10 (Parent_Base)); 7786 Set_Machine_Radix_10 7787 (Implicit_Base, Machine_Radix_10 (Parent_Base)); 7788 7789 Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); 7790 7791 if No_Constraint then 7792 Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base)); 7793 7794 else 7795 -- the analysis of the subtype_indication sets the 7796 -- digits value of the derived type. 7797 7798 null; 7799 end if; 7800 end if; 7801 end if; 7802 7803 if Is_Integer_Type (Parent_Type) then 7804 Set_Has_Shift_Operator 7805 (Implicit_Base, Has_Shift_Operator (Parent_Type)); 7806 end if; 7807 7808 -- The type of the bounds is that of the parent type, and they 7809 -- must be converted to the derived type. 7810 7811 Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); 7812 7813 -- The implicit_base should be frozen when the derived type is frozen, 7814 -- but note that it is used in the conversions of the bounds. For fixed 7815 -- types we delay the determination of the bounds until the proper 7816 -- freezing point. For other numeric types this is rejected by GCC, for 7817 -- reasons that are currently unclear (???), so we choose to freeze the 7818 -- implicit base now. In the case of integers and floating point types 7819 -- this is harmless because subsequent representation clauses cannot 7820 -- affect anything, but it is still baffling that we cannot use the 7821 -- same mechanism for all derived numeric types. 7822 7823 -- There is a further complication: actually some representation 7824 -- clauses can affect the implicit base type. For example, attribute 7825 -- definition clauses for stream-oriented attributes need to set the 7826 -- corresponding TSS entries on the base type, and this normally 7827 -- cannot be done after the base type is frozen, so the circuitry in 7828 -- Sem_Ch13.New_Stream_Subprogram must account for this possibility 7829 -- and not use Set_TSS in this case. 7830 7831 -- There are also consequences for the case of delayed representation 7832 -- aspects for some cases. For example, a Size aspect is delayed and 7833 -- should not be evaluated to the freeze point. This early freezing 7834 -- means that the size attribute evaluation happens too early??? 7835 7836 if Is_Fixed_Point_Type (Parent_Type) then 7837 Conditional_Delay (Implicit_Base, Parent_Type); 7838 else 7839 Freeze_Before (N, Implicit_Base); 7840 end if; 7841 end Build_Derived_Numeric_Type; 7842 7843 -------------------------------- 7844 -- Build_Derived_Private_Type -- 7845 -------------------------------- 7846 7847 procedure Build_Derived_Private_Type 7848 (N : Node_Id; 7849 Parent_Type : Entity_Id; 7850 Derived_Type : Entity_Id; 7851 Is_Completion : Boolean; 7852 Derive_Subps : Boolean := True) 7853 is 7854 Loc : constant Source_Ptr := Sloc (N); 7855 Par_Base : constant Entity_Id := Base_Type (Parent_Type); 7856 Par_Scope : constant Entity_Id := Scope (Par_Base); 7857 Full_N : constant Node_Id := New_Copy_Tree (N); 7858 Full_Der : Entity_Id := New_Copy (Derived_Type); 7859 Full_P : Entity_Id; 7860 7861 function Available_Full_View (Typ : Entity_Id) return Entity_Id; 7862 -- Return the Full_View or Underlying_Full_View of Typ, whichever is 7863 -- present (they cannot be both present for the same type), or Empty. 7864 7865 procedure Build_Full_Derivation; 7866 -- Build full derivation, i.e. derive from the full view 7867 7868 procedure Copy_And_Build; 7869 -- Copy derived type declaration, replace parent with its full view, 7870 -- and build derivation 7871 7872 ------------------------- 7873 -- Available_Full_View -- 7874 ------------------------- 7875 7876 function Available_Full_View (Typ : Entity_Id) return Entity_Id is 7877 begin 7878 if Present (Full_View (Typ)) then 7879 return Full_View (Typ); 7880 7881 elsif Present (Underlying_Full_View (Typ)) then 7882 7883 -- We should be called on a type with an underlying full view 7884 -- only by means of the recursive call made in Copy_And_Build 7885 -- through the first call to Build_Derived_Type, or else if 7886 -- the parent scope is being analyzed because we are deriving 7887 -- a completion. 7888 7889 pragma Assert (Is_Completion or else In_Private_Part (Par_Scope)); 7890 7891 return Underlying_Full_View (Typ); 7892 7893 else 7894 return Empty; 7895 end if; 7896 end Available_Full_View; 7897 7898 --------------------------- 7899 -- Build_Full_Derivation -- 7900 --------------------------- 7901 7902 procedure Build_Full_Derivation is 7903 begin 7904 -- If parent scope is not open, install the declarations 7905 7906 if not In_Open_Scopes (Par_Scope) then 7907 Install_Private_Declarations (Par_Scope); 7908 Install_Visible_Declarations (Par_Scope); 7909 Copy_And_Build; 7910 Uninstall_Declarations (Par_Scope); 7911 7912 -- If parent scope is open and in another unit, and parent has a 7913 -- completion, then the derivation is taking place in the visible 7914 -- part of a child unit. In that case retrieve the full view of 7915 -- the parent momentarily. 7916 7917 elsif not In_Same_Source_Unit (N, Parent_Type) 7918 and then Present (Full_View (Parent_Type)) 7919 then 7920 Full_P := Full_View (Parent_Type); 7921 Exchange_Declarations (Parent_Type); 7922 Copy_And_Build; 7923 Exchange_Declarations (Full_P); 7924 7925 -- Otherwise it is a local derivation 7926 7927 else 7928 Copy_And_Build; 7929 end if; 7930 end Build_Full_Derivation; 7931 7932 -------------------- 7933 -- Copy_And_Build -- 7934 -------------------- 7935 7936 procedure Copy_And_Build is 7937 Full_Parent : Entity_Id := Parent_Type; 7938 7939 begin 7940 -- If the parent is itself derived from another private type, 7941 -- installing the private declarations has not affected its 7942 -- privacy status, so use its own full view explicitly. 7943 7944 if Is_Private_Type (Full_Parent) 7945 and then Present (Full_View (Full_Parent)) 7946 then 7947 Full_Parent := Full_View (Full_Parent); 7948 end if; 7949 7950 -- If the full view is itself derived from another private type 7951 -- and has got an underlying full view, and this is done for a 7952 -- completion, i.e. to build the underlying full view of the type, 7953 -- then use this underlying full view. We cannot do that if this 7954 -- is not a completion, i.e. to build the full view of the type, 7955 -- because this would break the privacy of the parent type, except 7956 -- if the parent scope is being analyzed because we are deriving a 7957 -- completion. 7958 7959 if Is_Private_Type (Full_Parent) 7960 and then Present (Underlying_Full_View (Full_Parent)) 7961 and then (Is_Completion or else In_Private_Part (Par_Scope)) 7962 then 7963 Full_Parent := Underlying_Full_View (Full_Parent); 7964 end if; 7965 7966 -- For private, record, concurrent, access and almost all enumeration 7967 -- types, the derivation from the full view requires a fully-fledged 7968 -- declaration. In the other cases, just use an itype. 7969 7970 if Is_Private_Type (Full_Parent) 7971 or else Is_Record_Type (Full_Parent) 7972 or else Is_Concurrent_Type (Full_Parent) 7973 or else Is_Access_Type (Full_Parent) 7974 or else 7975 (Is_Enumeration_Type (Full_Parent) 7976 and then not Is_Standard_Character_Type (Full_Parent) 7977 and then not Is_Generic_Type (Root_Type (Full_Parent))) 7978 then 7979 -- Copy and adjust declaration to provide a completion for what 7980 -- is originally a private declaration. Indicate that full view 7981 -- is internally generated. 7982 7983 Set_Comes_From_Source (Full_N, False); 7984 Set_Comes_From_Source (Full_Der, False); 7985 Set_Parent (Full_Der, Full_N); 7986 Set_Defining_Identifier (Full_N, Full_Der); 7987 7988 -- If there are no constraints, adjust the subtype mark 7989 7990 if Nkind (Subtype_Indication (Type_Definition (Full_N))) /= 7991 N_Subtype_Indication 7992 then 7993 Set_Subtype_Indication 7994 (Type_Definition (Full_N), 7995 New_Occurrence_Of (Full_Parent, Sloc (Full_N))); 7996 end if; 7997 7998 Insert_After (N, Full_N); 7999 8000 -- Build full view of derived type from full view of parent which 8001 -- is now installed. Subprograms have been derived on the partial 8002 -- view, the completion does not derive them anew. 8003 8004 if Is_Record_Type (Full_Parent) then 8005 8006 -- If parent type is tagged, the completion inherits the proper 8007 -- primitive operations. 8008 8009 if Is_Tagged_Type (Parent_Type) then 8010 Build_Derived_Record_Type 8011 (Full_N, Full_Parent, Full_Der, Derive_Subps); 8012 else 8013 Build_Derived_Record_Type 8014 (Full_N, Full_Parent, Full_Der, Derive_Subps => False); 8015 end if; 8016 8017 else 8018 -- If the parent type is private, this is not a completion and 8019 -- we build the full derivation recursively as a completion. 8020 8021 Build_Derived_Type 8022 (Full_N, Full_Parent, Full_Der, 8023 Is_Completion => Is_Private_Type (Full_Parent), 8024 Derive_Subps => False); 8025 end if; 8026 8027 -- The full declaration has been introduced into the tree and 8028 -- processed in the step above. It should not be analyzed again 8029 -- (when encountered later in the current list of declarations) 8030 -- to prevent spurious name conflicts. The full entity remains 8031 -- invisible. 8032 8033 Set_Analyzed (Full_N); 8034 8035 else 8036 Full_Der := 8037 Make_Defining_Identifier (Sloc (Derived_Type), 8038 Chars => Chars (Derived_Type)); 8039 Set_Is_Itype (Full_Der); 8040 Set_Associated_Node_For_Itype (Full_Der, N); 8041 Set_Parent (Full_Der, N); 8042 Build_Derived_Type 8043 (N, Full_Parent, Full_Der, 8044 Is_Completion => False, Derive_Subps => False); 8045 end if; 8046 8047 Set_Has_Private_Declaration (Full_Der); 8048 Set_Has_Private_Declaration (Derived_Type); 8049 8050 Set_Scope (Full_Der, Scope (Derived_Type)); 8051 Set_Is_First_Subtype (Full_Der, Is_First_Subtype (Derived_Type)); 8052 Set_Has_Size_Clause (Full_Der, False); 8053 Set_Has_Alignment_Clause (Full_Der, False); 8054 Set_Has_Delayed_Freeze (Full_Der); 8055 Set_Is_Frozen (Full_Der, False); 8056 Set_Freeze_Node (Full_Der, Empty); 8057 Set_Depends_On_Private (Full_Der, Has_Private_Component (Full_Der)); 8058 Set_Is_Public (Full_Der, Is_Public (Derived_Type)); 8059 8060 -- The convention on the base type may be set in the private part 8061 -- and not propagated to the subtype until later, so we obtain the 8062 -- convention from the base type of the parent. 8063 8064 Set_Convention (Full_Der, Convention (Base_Type (Full_Parent))); 8065 end Copy_And_Build; 8066 8067 -- Start of processing for Build_Derived_Private_Type 8068 8069 begin 8070 if Is_Tagged_Type (Parent_Type) then 8071 Full_P := Full_View (Parent_Type); 8072 8073 -- A type extension of a type with unknown discriminants is an 8074 -- indefinite type that the back-end cannot handle directly. 8075 -- We treat it as a private type, and build a completion that is 8076 -- derived from the full view of the parent, and hopefully has 8077 -- known discriminants. 8078 8079 -- If the full view of the parent type has an underlying record view, 8080 -- use it to generate the underlying record view of this derived type 8081 -- (required for chains of derivations with unknown discriminants). 8082 8083 -- Minor optimization: we avoid the generation of useless underlying 8084 -- record view entities if the private type declaration has unknown 8085 -- discriminants but its corresponding full view has no 8086 -- discriminants. 8087 8088 if Has_Unknown_Discriminants (Parent_Type) 8089 and then Present (Full_P) 8090 and then (Has_Discriminants (Full_P) 8091 or else Present (Underlying_Record_View (Full_P))) 8092 and then not In_Open_Scopes (Par_Scope) 8093 and then Expander_Active 8094 then 8095 declare 8096 Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T'); 8097 New_Ext : constant Node_Id := 8098 Copy_Separate_Tree 8099 (Record_Extension_Part (Type_Definition (N))); 8100 Decl : Node_Id; 8101 8102 begin 8103 Build_Derived_Record_Type 8104 (N, Parent_Type, Derived_Type, Derive_Subps); 8105 8106 -- Build anonymous completion, as a derivation from the full 8107 -- view of the parent. This is not a completion in the usual 8108 -- sense, because the current type is not private. 8109 8110 Decl := 8111 Make_Full_Type_Declaration (Loc, 8112 Defining_Identifier => Full_Der, 8113 Type_Definition => 8114 Make_Derived_Type_Definition (Loc, 8115 Subtype_Indication => 8116 New_Copy_Tree 8117 (Subtype_Indication (Type_Definition (N))), 8118 Record_Extension_Part => New_Ext)); 8119 8120 -- If the parent type has an underlying record view, use it 8121 -- here to build the new underlying record view. 8122 8123 if Present (Underlying_Record_View (Full_P)) then 8124 pragma Assert 8125 (Nkind (Subtype_Indication (Type_Definition (Decl))) 8126 = N_Identifier); 8127 Set_Entity (Subtype_Indication (Type_Definition (Decl)), 8128 Underlying_Record_View (Full_P)); 8129 end if; 8130 8131 Install_Private_Declarations (Par_Scope); 8132 Install_Visible_Declarations (Par_Scope); 8133 Insert_Before (N, Decl); 8134 8135 -- Mark entity as an underlying record view before analysis, 8136 -- to avoid generating the list of its primitive operations 8137 -- (which is not really required for this entity) and thus 8138 -- prevent spurious errors associated with missing overriding 8139 -- of abstract primitives (overridden only for Derived_Type). 8140 8141 Mutate_Ekind (Full_Der, E_Record_Type); 8142 Set_Is_Underlying_Record_View (Full_Der); 8143 Set_Default_SSO (Full_Der); 8144 Set_No_Reordering (Full_Der, No_Component_Reordering); 8145 8146 Analyze (Decl); 8147 8148 pragma Assert (Has_Discriminants (Full_Der) 8149 and then not Has_Unknown_Discriminants (Full_Der)); 8150 8151 Uninstall_Declarations (Par_Scope); 8152 8153 -- Freeze the underlying record view, to prevent generation of 8154 -- useless dispatching information, which is simply shared with 8155 -- the real derived type. 8156 8157 Set_Is_Frozen (Full_Der); 8158 8159 -- If the derived type has access discriminants, create 8160 -- references to their anonymous types now, to prevent 8161 -- back-end problems when their first use is in generated 8162 -- bodies of primitives. 8163 8164 declare 8165 E : Entity_Id; 8166 8167 begin 8168 E := First_Entity (Full_Der); 8169 8170 while Present (E) loop 8171 if Ekind (E) = E_Discriminant 8172 and then Ekind (Etype (E)) = E_Anonymous_Access_Type 8173 then 8174 Build_Itype_Reference (Etype (E), Decl); 8175 end if; 8176 8177 Next_Entity (E); 8178 end loop; 8179 end; 8180 8181 -- Set up links between real entity and underlying record view 8182 8183 Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der)); 8184 Set_Underlying_Record_View (Base_Type (Full_Der), Derived_Type); 8185 end; 8186 8187 -- If discriminants are known, build derived record 8188 8189 else 8190 Build_Derived_Record_Type 8191 (N, Parent_Type, Derived_Type, Derive_Subps); 8192 end if; 8193 8194 return; 8195 8196 elsif Has_Discriminants (Parent_Type) then 8197 8198 -- Build partial view of derived type from partial view of parent. 8199 -- This must be done before building the full derivation because the 8200 -- second derivation will modify the discriminants of the first and 8201 -- the discriminants are chained with the rest of the components in 8202 -- the full derivation. 8203 8204 Build_Derived_Record_Type 8205 (N, Parent_Type, Derived_Type, Derive_Subps); 8206 8207 -- Build the full derivation if this is not the anonymous derived 8208 -- base type created by Build_Derived_Record_Type in the constrained 8209 -- case (see point 5. of its head comment) since we build it for the 8210 -- derived subtype. 8211 8212 if Present (Available_Full_View (Parent_Type)) 8213 and then not Is_Itype (Derived_Type) 8214 then 8215 declare 8216 Der_Base : constant Entity_Id := Base_Type (Derived_Type); 8217 Discr : Entity_Id; 8218 Last_Discr : Entity_Id; 8219 8220 begin 8221 -- If this is not a completion, construct the implicit full 8222 -- view by deriving from the full view of the parent type. 8223 -- But if this is a completion, the derived private type 8224 -- being built is a full view and the full derivation can 8225 -- only be its underlying full view. 8226 8227 Build_Full_Derivation; 8228 8229 if not Is_Completion then 8230 Set_Full_View (Derived_Type, Full_Der); 8231 else 8232 Set_Underlying_Full_View (Derived_Type, Full_Der); 8233 Set_Is_Underlying_Full_View (Full_Der); 8234 end if; 8235 8236 if not Is_Base_Type (Derived_Type) then 8237 Set_Full_View (Der_Base, Base_Type (Full_Der)); 8238 end if; 8239 8240 -- Copy the discriminant list from full view to the partial 8241 -- view (base type and its subtype). Gigi requires that the 8242 -- partial and full views have the same discriminants. 8243 8244 -- Note that since the partial view points to discriminants 8245 -- in the full view, their scope will be that of the full 8246 -- view. This might cause some front end problems and need 8247 -- adjustment??? 8248 8249 Discr := First_Discriminant (Base_Type (Full_Der)); 8250 Set_First_Entity (Der_Base, Discr); 8251 8252 loop 8253 Last_Discr := Discr; 8254 Next_Discriminant (Discr); 8255 exit when No (Discr); 8256 end loop; 8257 8258 Set_Last_Entity (Der_Base, Last_Discr); 8259 Set_First_Entity (Derived_Type, First_Entity (Der_Base)); 8260 Set_Last_Entity (Derived_Type, Last_Entity (Der_Base)); 8261 end; 8262 end if; 8263 8264 elsif Present (Available_Full_View (Parent_Type)) 8265 and then Has_Discriminants (Available_Full_View (Parent_Type)) 8266 then 8267 if Has_Unknown_Discriminants (Parent_Type) 8268 and then Nkind (Subtype_Indication (Type_Definition (N))) = 8269 N_Subtype_Indication 8270 then 8271 Error_Msg_N 8272 ("cannot constrain type with unknown discriminants", 8273 Subtype_Indication (Type_Definition (N))); 8274 return; 8275 end if; 8276 8277 -- If this is not a completion, construct the implicit full view by 8278 -- deriving from the full view of the parent type. But if this is a 8279 -- completion, the derived private type being built is a full view 8280 -- and the full derivation can only be its underlying full view. 8281 8282 Build_Full_Derivation; 8283 8284 if not Is_Completion then 8285 Set_Full_View (Derived_Type, Full_Der); 8286 else 8287 Set_Underlying_Full_View (Derived_Type, Full_Der); 8288 Set_Is_Underlying_Full_View (Full_Der); 8289 end if; 8290 8291 -- In any case, the primitive operations are inherited from the 8292 -- parent type, not from the internal full view. 8293 8294 Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type)); 8295 8296 if Derive_Subps then 8297 -- Initialize the list of primitive operations to an empty list, 8298 -- to cover tagged types as well as untagged types. For untagged 8299 -- types this is used either to analyze the call as legal when 8300 -- Extensions_Allowed is True, or to issue a better error message 8301 -- otherwise. 8302 8303 Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); 8304 8305 Derive_Subprograms (Parent_Type, Derived_Type); 8306 end if; 8307 8308 Set_Stored_Constraint (Derived_Type, No_Elist); 8309 Set_Is_Constrained 8310 (Derived_Type, Is_Constrained (Available_Full_View (Parent_Type))); 8311 8312 else 8313 -- Untagged type, No discriminants on either view 8314 8315 if Nkind (Subtype_Indication (Type_Definition (N))) = 8316 N_Subtype_Indication 8317 then 8318 Error_Msg_N 8319 ("illegal constraint on type without discriminants", N); 8320 end if; 8321 8322 if Present (Discriminant_Specifications (N)) 8323 and then Present (Available_Full_View (Parent_Type)) 8324 and then not Is_Tagged_Type (Available_Full_View (Parent_Type)) 8325 then 8326 Error_Msg_N ("cannot add discriminants to untagged type", N); 8327 end if; 8328 8329 Set_Stored_Constraint (Derived_Type, No_Elist); 8330 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 8331 8332 Set_Is_Controlled_Active 8333 (Derived_Type, Is_Controlled_Active (Parent_Type)); 8334 8335 Set_Disable_Controlled 8336 (Derived_Type, Disable_Controlled (Parent_Type)); 8337 8338 Set_Has_Controlled_Component 8339 (Derived_Type, Has_Controlled_Component (Parent_Type)); 8340 8341 -- Direct controlled types do not inherit Finalize_Storage_Only flag 8342 8343 if not Is_Controlled (Parent_Type) then 8344 Set_Finalize_Storage_Only 8345 (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type)); 8346 end if; 8347 8348 -- If this is not a completion, construct the implicit full view by 8349 -- deriving from the full view of the parent type. But if this is a 8350 -- completion, the derived private type being built is a full view 8351 -- and the full derivation can only be its underlying full view. 8352 8353 -- ??? If the parent type is untagged private and its completion is 8354 -- tagged, this mechanism will not work because we cannot derive from 8355 -- the tagged full view unless we have an extension. 8356 8357 if Present (Available_Full_View (Parent_Type)) 8358 and then not Is_Tagged_Type (Available_Full_View (Parent_Type)) 8359 and then not Error_Posted (N) 8360 then 8361 Build_Full_Derivation; 8362 8363 if not Is_Completion then 8364 Set_Full_View (Derived_Type, Full_Der); 8365 else 8366 Set_Underlying_Full_View (Derived_Type, Full_Der); 8367 Set_Is_Underlying_Full_View (Full_Der); 8368 end if; 8369 end if; 8370 end if; 8371 8372 Set_Has_Unknown_Discriminants (Derived_Type, 8373 Has_Unknown_Discriminants (Parent_Type)); 8374 8375 if Is_Private_Type (Derived_Type) then 8376 Set_Private_Dependents (Derived_Type, New_Elmt_List); 8377 end if; 8378 8379 -- If the parent base type is in scope, add the derived type to its 8380 -- list of private dependents, because its full view may become 8381 -- visible subsequently (in a nested private part, a body, or in a 8382 -- further child unit). 8383 8384 if Is_Private_Type (Par_Base) and then In_Open_Scopes (Par_Scope) then 8385 Append_Elmt (Derived_Type, Private_Dependents (Parent_Type)); 8386 8387 -- Check for unusual case where a type completed by a private 8388 -- derivation occurs within a package nested in a child unit, and 8389 -- the parent is declared in an ancestor. 8390 8391 if Is_Child_Unit (Scope (Current_Scope)) 8392 and then Is_Completion 8393 and then In_Private_Part (Current_Scope) 8394 and then Scope (Parent_Type) /= Current_Scope 8395 8396 -- Note that if the parent has a completion in the private part, 8397 -- (which is itself a derivation from some other private type) 8398 -- it is that completion that is visible, there is no full view 8399 -- available, and no special processing is needed. 8400 8401 and then Present (Full_View (Parent_Type)) 8402 then 8403 -- In this case, the full view of the parent type will become 8404 -- visible in the body of the enclosing child, and only then will 8405 -- the current type be possibly non-private. Build an underlying 8406 -- full view that will be installed when the enclosing child body 8407 -- is compiled. 8408 8409 if Present (Underlying_Full_View (Derived_Type)) then 8410 Full_Der := Underlying_Full_View (Derived_Type); 8411 else 8412 Build_Full_Derivation; 8413 Set_Underlying_Full_View (Derived_Type, Full_Der); 8414 Set_Is_Underlying_Full_View (Full_Der); 8415 end if; 8416 8417 -- The full view will be used to swap entities on entry/exit to 8418 -- the body, and must appear in the entity list for the package. 8419 8420 Append_Entity (Full_Der, Scope (Derived_Type)); 8421 end if; 8422 end if; 8423 end Build_Derived_Private_Type; 8424 8425 ------------------------------- 8426 -- Build_Derived_Record_Type -- 8427 ------------------------------- 8428 8429 -- 1. INTRODUCTION 8430 8431 -- Ideally we would like to use the same model of type derivation for 8432 -- tagged and untagged record types. Unfortunately this is not quite 8433 -- possible because the semantics of representation clauses is different 8434 -- for tagged and untagged records under inheritance. Consider the 8435 -- following: 8436 8437 -- type R (...) is [tagged] record ... end record; 8438 -- type T (...) is new R (...) [with ...]; 8439 8440 -- The representation clauses for T can specify a completely different 8441 -- record layout from R's. Hence the same component can be placed in two 8442 -- very different positions in objects of type T and R. If R and T are 8443 -- tagged types, representation clauses for T can only specify the layout 8444 -- of non inherited components, thus components that are common in R and T 8445 -- have the same position in objects of type R and T. 8446 8447 -- This has two implications. The first is that the entire tree for R's 8448 -- declaration needs to be copied for T in the untagged case, so that T 8449 -- can be viewed as a record type of its own with its own representation 8450 -- clauses. The second implication is the way we handle discriminants. 8451 -- Specifically, in the untagged case we need a way to communicate to Gigi 8452 -- what are the real discriminants in the record, while for the semantics 8453 -- we need to consider those introduced by the user to rename the 8454 -- discriminants in the parent type. This is handled by introducing the 8455 -- notion of stored discriminants. See below for more. 8456 8457 -- Fortunately the way regular components are inherited can be handled in 8458 -- the same way in tagged and untagged types. 8459 8460 -- To complicate things a bit more the private view of a private extension 8461 -- cannot be handled in the same way as the full view (for one thing the 8462 -- semantic rules are somewhat different). We will explain what differs 8463 -- below. 8464 8465 -- 2. DISCRIMINANTS UNDER INHERITANCE 8466 8467 -- The semantic rules governing the discriminants of derived types are 8468 -- quite subtle. 8469 8470 -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new 8471 -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART] 8472 8473 -- If parent type has discriminants, then the discriminants that are 8474 -- declared in the derived type are [3.4 (11)]: 8475 8476 -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if 8477 -- there is one; 8478 8479 -- o Otherwise, each discriminant of the parent type (implicitly declared 8480 -- in the same order with the same specifications). In this case, the 8481 -- discriminants are said to be "inherited", or if unknown in the parent 8482 -- are also unknown in the derived type. 8483 8484 -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]: 8485 8486 -- o The parent subtype must be constrained; 8487 8488 -- o If the parent type is not a tagged type, then each discriminant of 8489 -- the derived type must be used in the constraint defining a parent 8490 -- subtype. [Implementation note: This ensures that the new discriminant 8491 -- can share storage with an existing discriminant.] 8492 8493 -- For the derived type each discriminant of the parent type is either 8494 -- inherited, constrained to equal some new discriminant of the derived 8495 -- type, or constrained to the value of an expression. 8496 8497 -- When inherited or constrained to equal some new discriminant, the 8498 -- parent discriminant and the discriminant of the derived type are said 8499 -- to "correspond". 8500 8501 -- If a discriminant of the parent type is constrained to a specific value 8502 -- in the derived type definition, then the discriminant is said to be 8503 -- "specified" by that derived type definition. 8504 8505 -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES 8506 8507 -- We have spoken about stored discriminants in point 1 (introduction) 8508 -- above. There are two sorts of stored discriminants: implicit and 8509 -- explicit. As long as the derived type inherits the same discriminants as 8510 -- the root record type, stored discriminants are the same as regular 8511 -- discriminants, and are said to be implicit. However, if any discriminant 8512 -- in the root type was renamed in the derived type, then the derived 8513 -- type will contain explicit stored discriminants. Explicit stored 8514 -- discriminants are discriminants in addition to the semantically visible 8515 -- discriminants defined for the derived type. Stored discriminants are 8516 -- used by Gigi to figure out what are the physical discriminants in 8517 -- objects of the derived type (see precise definition in einfo.ads). 8518 -- As an example, consider the following: 8519 8520 -- type R (D1, D2, D3 : Int) is record ... end record; 8521 -- type T1 is new R; 8522 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1); 8523 -- type T3 is new T2; 8524 -- type T4 (Y : Int) is new T3 (Y, 99); 8525 8526 -- The following table summarizes the discriminants and stored 8527 -- discriminants in R and T1 through T4: 8528 8529 -- Type Discrim Stored Discrim Comment 8530 -- R (D1, D2, D3) (D1, D2, D3) Stored discrims implicit in R 8531 -- T1 (D1, D2, D3) (D1, D2, D3) Stored discrims implicit in T1 8532 -- T2 (X1, X2) (D1, D2, D3) Stored discrims EXPLICIT in T2 8533 -- T3 (X1, X2) (D1, D2, D3) Stored discrims EXPLICIT in T3 8534 -- T4 (Y) (D1, D2, D3) Stored discrims EXPLICIT in T4 8535 8536 -- Field Corresponding_Discriminant (abbreviated CD below) allows us to 8537 -- find the corresponding discriminant in the parent type, while 8538 -- Original_Record_Component (abbreviated ORC below) the actual physical 8539 -- component that is renamed. Finally the field Is_Completely_Hidden 8540 -- (abbreviated ICH below) is set for all explicit stored discriminants 8541 -- (see einfo.ads for more info). For the above example this gives: 8542 8543 -- Discrim CD ORC ICH 8544 -- ^^^^^^^ ^^ ^^^ ^^^ 8545 -- D1 in R empty itself no 8546 -- D2 in R empty itself no 8547 -- D3 in R empty itself no 8548 8549 -- D1 in T1 D1 in R itself no 8550 -- D2 in T1 D2 in R itself no 8551 -- D3 in T1 D3 in R itself no 8552 8553 -- X1 in T2 D3 in T1 D3 in T2 no 8554 -- X2 in T2 D1 in T1 D1 in T2 no 8555 -- D1 in T2 empty itself yes 8556 -- D2 in T2 empty itself yes 8557 -- D3 in T2 empty itself yes 8558 8559 -- X1 in T3 X1 in T2 D3 in T3 no 8560 -- X2 in T3 X2 in T2 D1 in T3 no 8561 -- D1 in T3 empty itself yes 8562 -- D2 in T3 empty itself yes 8563 -- D3 in T3 empty itself yes 8564 8565 -- Y in T4 X1 in T3 D3 in T4 no 8566 -- D1 in T4 empty itself yes 8567 -- D2 in T4 empty itself yes 8568 -- D3 in T4 empty itself yes 8569 8570 -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES 8571 8572 -- Type derivation for tagged types is fairly straightforward. If no 8573 -- discriminants are specified by the derived type, these are inherited 8574 -- from the parent. No explicit stored discriminants are ever necessary. 8575 -- The only manipulation that is done to the tree is that of adding a 8576 -- _parent field with parent type and constrained to the same constraint 8577 -- specified for the parent in the derived type definition. For instance: 8578 8579 -- type R (D1, D2, D3 : Int) is tagged record ... end record; 8580 -- type T1 is new R with null record; 8581 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record; 8582 8583 -- are changed into: 8584 8585 -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record 8586 -- _parent : R (D1, D2, D3); 8587 -- end record; 8588 8589 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record 8590 -- _parent : T1 (X2, 88, X1); 8591 -- end record; 8592 8593 -- The discriminants actually present in R, T1 and T2 as well as their CD, 8594 -- ORC and ICH fields are: 8595 8596 -- Discrim CD ORC ICH 8597 -- ^^^^^^^ ^^ ^^^ ^^^ 8598 -- D1 in R empty itself no 8599 -- D2 in R empty itself no 8600 -- D3 in R empty itself no 8601 8602 -- D1 in T1 D1 in R D1 in R no 8603 -- D2 in T1 D2 in R D2 in R no 8604 -- D3 in T1 D3 in R D3 in R no 8605 8606 -- X1 in T2 D3 in T1 D3 in R no 8607 -- X2 in T2 D1 in T1 D1 in R no 8608 8609 -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS 8610 -- 8611 -- Regardless of whether we dealing with a tagged or untagged type 8612 -- we will transform all derived type declarations of the form 8613 -- 8614 -- type T is new R (...) [with ...]; 8615 -- or 8616 -- subtype S is R (...); 8617 -- type T is new S [with ...]; 8618 -- into 8619 -- type BT is new R [with ...]; 8620 -- subtype T is BT (...); 8621 -- 8622 -- That is, the base derived type is constrained only if it has no 8623 -- discriminants. The reason for doing this is that GNAT's semantic model 8624 -- assumes that a base type with discriminants is unconstrained. 8625 -- 8626 -- Note that, strictly speaking, the above transformation is not always 8627 -- correct. Consider for instance the following excerpt from ACVC b34011a: 8628 -- 8629 -- procedure B34011A is 8630 -- type REC (D : integer := 0) is record 8631 -- I : Integer; 8632 -- end record; 8633 8634 -- package P is 8635 -- type T6 is new Rec; 8636 -- function F return T6; 8637 -- end P; 8638 8639 -- use P; 8640 -- package Q6 is 8641 -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F. 8642 -- end Q6; 8643 -- 8644 -- The definition of Q6.U is illegal. However transforming Q6.U into 8645 8646 -- type BaseU is new T6; 8647 -- subtype U is BaseU (Q6.F.I) 8648 8649 -- turns U into a legal subtype, which is incorrect. To avoid this problem 8650 -- we always analyze the constraint (in this case (Q6.F.I)) before applying 8651 -- the transformation described above. 8652 8653 -- There is another instance where the above transformation is incorrect. 8654 -- Consider: 8655 8656 -- package Pack is 8657 -- type Base (D : Integer) is tagged null record; 8658 -- procedure P (X : Base); 8659 8660 -- type Der is new Base (2) with null record; 8661 -- procedure P (X : Der); 8662 -- end Pack; 8663 8664 -- Then the above transformation turns this into 8665 8666 -- type Der_Base is new Base with null record; 8667 -- -- procedure P (X : Base) is implicitly inherited here 8668 -- -- as procedure P (X : Der_Base). 8669 8670 -- subtype Der is Der_Base (2); 8671 -- procedure P (X : Der); 8672 -- -- The overriding of P (X : Der_Base) is illegal since we 8673 -- -- have a parameter conformance problem. 8674 8675 -- To get around this problem, after having semantically processed Der_Base 8676 -- and the rewritten subtype declaration for Der, we copy Der_Base field 8677 -- Discriminant_Constraint from Der so that when parameter conformance is 8678 -- checked when P is overridden, no semantic errors are flagged. 8679 8680 -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS 8681 8682 -- Regardless of whether we are dealing with a tagged or untagged type 8683 -- we will transform all derived type declarations of the form 8684 8685 -- type R (D1, .., Dn : ...) is [tagged] record ...; 8686 -- type T is new R [with ...]; 8687 -- into 8688 -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...]; 8689 8690 -- The reason for such transformation is that it allows us to implement a 8691 -- very clean form of component inheritance as explained below. 8692 8693 -- Note that this transformation is not achieved by direct tree rewriting 8694 -- and manipulation, but rather by redoing the semantic actions that the 8695 -- above transformation will entail. This is done directly in routine 8696 -- Inherit_Components. 8697 8698 -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE 8699 8700 -- In both tagged and untagged derived types, regular non discriminant 8701 -- components are inherited in the derived type from the parent type. In 8702 -- the absence of discriminants component, inheritance is straightforward 8703 -- as components can simply be copied from the parent. 8704 8705 -- If the parent has discriminants, inheriting components constrained with 8706 -- these discriminants requires caution. Consider the following example: 8707 8708 -- type R (D1, D2 : Positive) is [tagged] record 8709 -- S : String (D1 .. D2); 8710 -- end record; 8711 8712 -- type T1 is new R [with null record]; 8713 -- type T2 (X : positive) is new R (1, X) [with null record]; 8714 8715 -- As explained in 6. above, T1 is rewritten as 8716 -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record]; 8717 -- which makes the treatment for T1 and T2 identical. 8718 8719 -- What we want when inheriting S, is that references to D1 and D2 in R are 8720 -- replaced with references to their correct constraints, i.e. D1 and D2 in 8721 -- T1 and 1 and X in T2. So all R's discriminant references are replaced 8722 -- with either discriminant references in the derived type or expressions. 8723 -- This replacement is achieved as follows: before inheriting R's 8724 -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is 8725 -- created in the scope of T1 (resp. scope of T2) so that discriminants D1 8726 -- and D2 of T1 are visible (resp. discriminant X of T2 is visible). 8727 -- For T2, for instance, this has the effect of replacing String (D1 .. D2) 8728 -- by String (1 .. X). 8729 8730 -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS 8731 8732 -- We explain here the rules governing private type extensions relevant to 8733 -- type derivation. These rules are explained on the following example: 8734 8735 -- type D [(...)] is new A [(...)] with private; <-- partial view 8736 -- type D [(...)] is new P [(...)] with null record; <-- full view 8737 8738 -- Type A is called the ancestor subtype of the private extension. 8739 -- Type P is the parent type of the full view of the private extension. It 8740 -- must be A or a type derived from A. 8741 8742 -- The rules concerning the discriminants of private type extensions are 8743 -- [7.3(10-13)]: 8744 8745 -- o If a private extension inherits known discriminants from the ancestor 8746 -- subtype, then the full view must also inherit its discriminants from 8747 -- the ancestor subtype and the parent subtype of the full view must be 8748 -- constrained if and only if the ancestor subtype is constrained. 8749 8750 -- o If a partial view has unknown discriminants, then the full view may 8751 -- define a definite or an indefinite subtype, with or without 8752 -- discriminants. 8753 8754 -- o If a partial view has neither known nor unknown discriminants, then 8755 -- the full view must define a definite subtype. 8756 8757 -- o If the ancestor subtype of a private extension has constrained 8758 -- discriminants, then the parent subtype of the full view must impose a 8759 -- statically matching constraint on those discriminants. 8760 8761 -- This means that only the following forms of private extensions are 8762 -- allowed: 8763 8764 -- type D is new A with private; <-- partial view 8765 -- type D is new P with null record; <-- full view 8766 8767 -- If A has no discriminants than P has no discriminants, otherwise P must 8768 -- inherit A's discriminants. 8769 8770 -- type D is new A (...) with private; <-- partial view 8771 -- type D is new P (:::) with null record; <-- full view 8772 8773 -- P must inherit A's discriminants and (...) and (:::) must statically 8774 -- match. 8775 8776 -- subtype A is R (...); 8777 -- type D is new A with private; <-- partial view 8778 -- type D is new P with null record; <-- full view 8779 8780 -- P must have inherited R's discriminants and must be derived from A or 8781 -- any of its subtypes. 8782 8783 -- type D (..) is new A with private; <-- partial view 8784 -- type D (..) is new P [(:::)] with null record; <-- full view 8785 8786 -- No specific constraints on P's discriminants or constraint (:::). 8787 -- Note that A can be unconstrained, but the parent subtype P must either 8788 -- be constrained or (:::) must be present. 8789 8790 -- type D (..) is new A [(...)] with private; <-- partial view 8791 -- type D (..) is new P [(:::)] with null record; <-- full view 8792 8793 -- P's constraints on A's discriminants must statically match those 8794 -- imposed by (...). 8795 8796 -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS 8797 8798 -- The full view of a private extension is handled exactly as described 8799 -- above. The model chose for the private view of a private extension is 8800 -- the same for what concerns discriminants (i.e. they receive the same 8801 -- treatment as in the tagged case). However, the private view of the 8802 -- private extension always inherits the components of the parent base, 8803 -- without replacing any discriminant reference. Strictly speaking this is 8804 -- incorrect. However, Gigi never uses this view to generate code so this 8805 -- is a purely semantic issue. In theory, a set of transformations similar 8806 -- to those given in 5. and 6. above could be applied to private views of 8807 -- private extensions to have the same model of component inheritance as 8808 -- for non private extensions. However, this is not done because it would 8809 -- further complicate private type processing. Semantically speaking, this 8810 -- leaves us in an uncomfortable situation. As an example consider: 8811 8812 -- package Pack is 8813 -- type R (D : integer) is tagged record 8814 -- S : String (1 .. D); 8815 -- end record; 8816 -- procedure P (X : R); 8817 -- type T is new R (1) with private; 8818 -- private 8819 -- type T is new R (1) with null record; 8820 -- end; 8821 8822 -- This is transformed into: 8823 8824 -- package Pack is 8825 -- type R (D : integer) is tagged record 8826 -- S : String (1 .. D); 8827 -- end record; 8828 -- procedure P (X : R); 8829 -- type T is new R (1) with private; 8830 -- private 8831 -- type BaseT is new R with null record; 8832 -- subtype T is BaseT (1); 8833 -- end; 8834 8835 -- (strictly speaking the above is incorrect Ada) 8836 8837 -- From the semantic standpoint the private view of private extension T 8838 -- should be flagged as constrained since one can clearly have 8839 -- 8840 -- Obj : T; 8841 -- 8842 -- in a unit withing Pack. However, when deriving subprograms for the 8843 -- private view of private extension T, T must be seen as unconstrained 8844 -- since T has discriminants (this is a constraint of the current 8845 -- subprogram derivation model). Thus, when processing the private view of 8846 -- a private extension such as T, we first mark T as unconstrained, we 8847 -- process it, we perform program derivation and just before returning from 8848 -- Build_Derived_Record_Type we mark T as constrained. 8849 8850 -- ??? Are there are other uncomfortable cases that we will have to 8851 -- deal with. 8852 8853 -- 10. RECORD_TYPE_WITH_PRIVATE complications 8854 8855 -- Types that are derived from a visible record type and have a private 8856 -- extension present other peculiarities. They behave mostly like private 8857 -- types, but if they have primitive operations defined, these will not 8858 -- have the proper signatures for further inheritance, because other 8859 -- primitive operations will use the implicit base that we define for 8860 -- private derivations below. This affect subprogram inheritance (see 8861 -- Derive_Subprograms for details). We also derive the implicit base from 8862 -- the base type of the full view, so that the implicit base is a record 8863 -- type and not another private type, This avoids infinite loops. 8864 8865 procedure Build_Derived_Record_Type 8866 (N : Node_Id; 8867 Parent_Type : Entity_Id; 8868 Derived_Type : Entity_Id; 8869 Derive_Subps : Boolean := True) 8870 is 8871 Discriminant_Specs : constant Boolean := 8872 Present (Discriminant_Specifications (N)); 8873 Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type); 8874 Loc : constant Source_Ptr := Sloc (N); 8875 Private_Extension : constant Boolean := 8876 Nkind (N) = N_Private_Extension_Declaration; 8877 Assoc_List : Elist_Id; 8878 Constraint_Present : Boolean; 8879 Constrs : Elist_Id; 8880 Discrim : Entity_Id; 8881 Indic : Node_Id; 8882 Inherit_Discrims : Boolean := False; 8883 Last_Discrim : Entity_Id; 8884 New_Base : Entity_Id; 8885 New_Decl : Node_Id; 8886 New_Discrs : Elist_Id; 8887 New_Indic : Node_Id; 8888 Parent_Base : Entity_Id; 8889 Save_Etype : Entity_Id; 8890 Save_Discr_Constr : Elist_Id; 8891 Save_Next_Entity : Entity_Id; 8892 Type_Def : Node_Id; 8893 8894 Discs : Elist_Id := New_Elmt_List; 8895 -- An empty Discs list means that there were no constraints in the 8896 -- subtype indication or that there was an error processing it. 8897 8898 procedure Check_Generic_Ancestors; 8899 -- In Ada 2005 (AI-344), the restriction that a derived tagged type 8900 -- cannot be declared at a deeper level than its parent type is 8901 -- removed. The check on derivation within a generic body is also 8902 -- relaxed, but there's a restriction that a derived tagged type 8903 -- cannot be declared in a generic body if it's derived directly 8904 -- or indirectly from a formal type of that generic. This applies 8905 -- to progenitors as well. 8906 8907 ----------------------------- 8908 -- Check_Generic_Ancestors -- 8909 ----------------------------- 8910 8911 procedure Check_Generic_Ancestors is 8912 Ancestor_Type : Entity_Id; 8913 Intf_List : List_Id; 8914 Intf_Name : Node_Id; 8915 8916 procedure Check_Ancestor; 8917 -- For parent and progenitors. 8918 8919 -------------------- 8920 -- Check_Ancestor -- 8921 -------------------- 8922 8923 procedure Check_Ancestor is 8924 begin 8925 -- If the derived type does have a formal type as an ancestor 8926 -- then it's an error if the derived type is declared within 8927 -- the body of the generic unit that declares the formal type 8928 -- in its generic formal part. It's sufficient to check whether 8929 -- the ancestor type is declared inside the same generic body 8930 -- as the derived type (such as within a nested generic spec), 8931 -- in which case the derivation is legal. If the formal type is 8932 -- declared outside of that generic body, then it's certain 8933 -- that the derived type is declared within the generic body 8934 -- of the generic unit declaring the formal type. 8935 8936 if Is_Generic_Type (Ancestor_Type) 8937 and then Enclosing_Generic_Body (Ancestor_Type) /= 8938 Enclosing_Generic_Body (Derived_Type) 8939 then 8940 Error_Msg_NE 8941 ("ancestor type& is formal type of enclosing" 8942 & " generic unit (RM 3.9.1 (4/2))", 8943 Indic, Ancestor_Type); 8944 end if; 8945 end Check_Ancestor; 8946 8947 begin 8948 if Nkind (N) = N_Private_Extension_Declaration then 8949 Intf_List := Interface_List (N); 8950 else 8951 Intf_List := Interface_List (Type_Definition (N)); 8952 end if; 8953 8954 if Present (Enclosing_Generic_Body (Derived_Type)) then 8955 Ancestor_Type := Parent_Type; 8956 8957 while not Is_Generic_Type (Ancestor_Type) 8958 and then Etype (Ancestor_Type) /= Ancestor_Type 8959 loop 8960 Ancestor_Type := Etype (Ancestor_Type); 8961 end loop; 8962 8963 Check_Ancestor; 8964 8965 if Present (Intf_List) then 8966 Intf_Name := First (Intf_List); 8967 while Present (Intf_Name) loop 8968 Ancestor_Type := Entity (Intf_Name); 8969 Check_Ancestor; 8970 Next (Intf_Name); 8971 end loop; 8972 end if; 8973 end if; 8974 end Check_Generic_Ancestors; 8975 8976 -- Start of processing for Build_Derived_Record_Type 8977 8978 begin 8979 if Ekind (Parent_Type) = E_Record_Type_With_Private 8980 and then Present (Full_View (Parent_Type)) 8981 and then Has_Discriminants (Parent_Type) 8982 then 8983 Parent_Base := Base_Type (Full_View (Parent_Type)); 8984 else 8985 Parent_Base := Base_Type (Parent_Type); 8986 end if; 8987 8988 -- If the parent type is declared as a subtype of another private 8989 -- type with inherited discriminants, its generated base type is 8990 -- itself a record subtype. To further inherit the constraint we 8991 -- need to use its own base to have an unconstrained type on which 8992 -- to apply the inherited constraint. 8993 8994 if Ekind (Parent_Base) = E_Record_Subtype then 8995 Parent_Base := Base_Type (Parent_Base); 8996 end if; 8997 8998 -- AI05-0115: if this is a derivation from a private type in some 8999 -- other scope that may lead to invisible components for the derived 9000 -- type, mark it accordingly. 9001 9002 if Is_Private_Type (Parent_Type) then 9003 if Scope (Parent_Base) = Scope (Derived_Type) then 9004 null; 9005 9006 elsif In_Open_Scopes (Scope (Parent_Base)) 9007 and then In_Private_Part (Scope (Parent_Base)) 9008 then 9009 null; 9010 9011 else 9012 Set_Has_Private_Ancestor (Derived_Type); 9013 end if; 9014 9015 else 9016 Set_Has_Private_Ancestor 9017 (Derived_Type, Has_Private_Ancestor (Parent_Type)); 9018 end if; 9019 9020 -- Before we start the previously documented transformations, here is 9021 -- little fix for size and alignment of tagged types. Normally when we 9022 -- derive type D from type P, we copy the size and alignment of P as the 9023 -- default for D, and in the absence of explicit representation clauses 9024 -- for D, the size and alignment are indeed the same as the parent. 9025 9026 -- But this is wrong for tagged types, since fields may be added, and 9027 -- the default size may need to be larger, and the default alignment may 9028 -- need to be larger. 9029 9030 -- We therefore reset the size and alignment fields in the tagged case. 9031 -- Note that the size and alignment will in any case be at least as 9032 -- large as the parent type (since the derived type has a copy of the 9033 -- parent type in the _parent field) 9034 9035 -- The type is also marked as being tagged here, which is needed when 9036 -- processing components with a self-referential anonymous access type 9037 -- in the call to Check_Anonymous_Access_Components below. Note that 9038 -- this flag is also set later on for completeness. 9039 9040 if Is_Tagged then 9041 Set_Is_Tagged_Type (Derived_Type); 9042 Reinit_Size_Align (Derived_Type); 9043 end if; 9044 9045 -- STEP 0a: figure out what kind of derived type declaration we have 9046 9047 if Private_Extension then 9048 Type_Def := N; 9049 Mutate_Ekind (Derived_Type, E_Record_Type_With_Private); 9050 Set_Default_SSO (Derived_Type); 9051 Set_No_Reordering (Derived_Type, No_Component_Reordering); 9052 9053 else 9054 Type_Def := Type_Definition (N); 9055 9056 -- Ekind (Parent_Base) is not necessarily E_Record_Type since 9057 -- Parent_Base can be a private type or private extension. However, 9058 -- for tagged types with an extension the newly added fields are 9059 -- visible and hence the Derived_Type is always an E_Record_Type. 9060 -- (except that the parent may have its own private fields). 9061 -- For untagged types we preserve the Ekind of the Parent_Base. 9062 9063 if Present (Record_Extension_Part (Type_Def)) then 9064 Mutate_Ekind (Derived_Type, E_Record_Type); 9065 Set_Default_SSO (Derived_Type); 9066 Set_No_Reordering (Derived_Type, No_Component_Reordering); 9067 9068 -- Create internal access types for components with anonymous 9069 -- access types. 9070 9071 if Ada_Version >= Ada_2005 then 9072 Check_Anonymous_Access_Components 9073 (N, Derived_Type, Derived_Type, 9074 Component_List (Record_Extension_Part (Type_Def))); 9075 end if; 9076 9077 else 9078 Mutate_Ekind (Derived_Type, Ekind (Parent_Base)); 9079 end if; 9080 end if; 9081 9082 -- Indic can either be an N_Identifier if the subtype indication 9083 -- contains no constraint or an N_Subtype_Indication if the subtype 9084 -- indication has a constraint. In either case it can include an 9085 -- interface list. 9086 9087 Indic := Subtype_Indication (Type_Def); 9088 Constraint_Present := (Nkind (Indic) = N_Subtype_Indication); 9089 9090 -- Check that the type has visible discriminants. The type may be 9091 -- a private type with unknown discriminants whose full view has 9092 -- discriminants which are invisible. 9093 9094 if Constraint_Present then 9095 if not Has_Discriminants (Parent_Base) 9096 or else 9097 (Has_Unknown_Discriminants (Parent_Base) 9098 and then Is_Private_Type (Parent_Base)) 9099 then 9100 Error_Msg_N 9101 ("invalid constraint: type has no discriminant", 9102 Constraint (Indic)); 9103 9104 Constraint_Present := False; 9105 Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic))); 9106 9107 elsif Is_Constrained (Parent_Type) then 9108 Error_Msg_N 9109 ("invalid constraint: parent type is already constrained", 9110 Constraint (Indic)); 9111 9112 Constraint_Present := False; 9113 Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic))); 9114 end if; 9115 end if; 9116 9117 -- STEP 0b: If needed, apply transformation given in point 5. above 9118 9119 if not Private_Extension 9120 and then Has_Discriminants (Parent_Type) 9121 and then not Discriminant_Specs 9122 and then (Is_Constrained (Parent_Type) or else Constraint_Present) 9123 then 9124 -- First, we must analyze the constraint (see comment in point 5.) 9125 -- The constraint may come from the subtype indication of the full 9126 -- declaration. 9127 9128 if Constraint_Present then 9129 New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic); 9130 9131 -- If there is no explicit constraint, there might be one that is 9132 -- inherited from a constrained parent type. In that case verify that 9133 -- it conforms to the constraint in the partial view. In perverse 9134 -- cases the parent subtypes of the partial and full view can have 9135 -- different constraints. 9136 9137 elsif Present (Stored_Constraint (Parent_Type)) then 9138 New_Discrs := Stored_Constraint (Parent_Type); 9139 9140 else 9141 New_Discrs := No_Elist; 9142 end if; 9143 9144 if Has_Discriminants (Derived_Type) 9145 and then Has_Private_Declaration (Derived_Type) 9146 and then Present (Discriminant_Constraint (Derived_Type)) 9147 and then Present (New_Discrs) 9148 then 9149 -- Verify that constraints of the full view statically match 9150 -- those given in the partial view. 9151 9152 declare 9153 C1, C2 : Elmt_Id; 9154 9155 begin 9156 C1 := First_Elmt (New_Discrs); 9157 C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); 9158 while Present (C1) and then Present (C2) loop 9159 if Fully_Conformant_Expressions (Node (C1), Node (C2)) 9160 or else 9161 (Is_OK_Static_Expression (Node (C1)) 9162 and then Is_OK_Static_Expression (Node (C2)) 9163 and then 9164 Expr_Value (Node (C1)) = Expr_Value (Node (C2))) 9165 then 9166 null; 9167 9168 else 9169 if Constraint_Present then 9170 Error_Msg_N 9171 ("constraint not conformant to previous declaration", 9172 Node (C1)); 9173 else 9174 Error_Msg_N 9175 ("constraint of full view is incompatible " 9176 & "with partial view", N); 9177 end if; 9178 end if; 9179 9180 Next_Elmt (C1); 9181 Next_Elmt (C2); 9182 end loop; 9183 end; 9184 end if; 9185 9186 -- Insert and analyze the declaration for the unconstrained base type 9187 9188 New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B'); 9189 9190 New_Decl := 9191 Make_Full_Type_Declaration (Loc, 9192 Defining_Identifier => New_Base, 9193 Type_Definition => 9194 Make_Derived_Type_Definition (Loc, 9195 Abstract_Present => Abstract_Present (Type_Def), 9196 Limited_Present => Limited_Present (Type_Def), 9197 Subtype_Indication => 9198 New_Occurrence_Of (Parent_Base, Loc), 9199 Record_Extension_Part => 9200 Relocate_Node (Record_Extension_Part (Type_Def)), 9201 Interface_List => Interface_List (Type_Def))); 9202 9203 Set_Parent (New_Decl, Parent (N)); 9204 Mark_Rewrite_Insertion (New_Decl); 9205 Insert_Before (N, New_Decl); 9206 9207 -- In the extension case, make sure ancestor is frozen appropriately 9208 -- (see also non-discriminated case below). 9209 9210 if Present (Record_Extension_Part (Type_Def)) 9211 or else Is_Interface (Parent_Base) 9212 then 9213 Freeze_Before (New_Decl, Parent_Type); 9214 end if; 9215 9216 -- Note that this call passes False for the Derive_Subps parameter 9217 -- because subprogram derivation is deferred until after creating 9218 -- the subtype (see below). 9219 9220 Build_Derived_Type 9221 (New_Decl, Parent_Base, New_Base, 9222 Is_Completion => False, Derive_Subps => False); 9223 9224 -- ??? This needs re-examination to determine whether the 9225 -- above call can simply be replaced by a call to Analyze. 9226 9227 Set_Analyzed (New_Decl); 9228 9229 -- Insert and analyze the declaration for the constrained subtype 9230 9231 if Constraint_Present then 9232 New_Indic := 9233 Make_Subtype_Indication (Loc, 9234 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 9235 Constraint => Relocate_Node (Constraint (Indic))); 9236 9237 else 9238 declare 9239 Constr_List : constant List_Id := New_List; 9240 C : Elmt_Id; 9241 Expr : Node_Id; 9242 9243 begin 9244 C := First_Elmt (Discriminant_Constraint (Parent_Type)); 9245 while Present (C) loop 9246 Expr := Node (C); 9247 9248 -- It is safe here to call New_Copy_Tree since we called 9249 -- Force_Evaluation on each constraint previously 9250 -- in Build_Discriminant_Constraints. 9251 9252 Append (New_Copy_Tree (Expr), To => Constr_List); 9253 9254 Next_Elmt (C); 9255 end loop; 9256 9257 New_Indic := 9258 Make_Subtype_Indication (Loc, 9259 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 9260 Constraint => 9261 Make_Index_Or_Discriminant_Constraint (Loc, Constr_List)); 9262 end; 9263 end if; 9264 9265 Rewrite (N, 9266 Make_Subtype_Declaration (Loc, 9267 Defining_Identifier => Derived_Type, 9268 Subtype_Indication => New_Indic)); 9269 9270 Analyze (N); 9271 9272 -- Derivation of subprograms must be delayed until the full subtype 9273 -- has been established, to ensure proper overriding of subprograms 9274 -- inherited by full types. If the derivations occurred as part of 9275 -- the call to Build_Derived_Type above, then the check for type 9276 -- conformance would fail because earlier primitive subprograms 9277 -- could still refer to the full type prior the change to the new 9278 -- subtype and hence would not match the new base type created here. 9279 -- Subprograms are not derived, however, when Derive_Subps is False 9280 -- (since otherwise there could be redundant derivations). 9281 9282 if Derive_Subps then 9283 Derive_Subprograms (Parent_Type, Derived_Type); 9284 end if; 9285 9286 -- For tagged types the Discriminant_Constraint of the new base itype 9287 -- is inherited from the first subtype so that no subtype conformance 9288 -- problem arise when the first subtype overrides primitive 9289 -- operations inherited by the implicit base type. 9290 9291 if Is_Tagged then 9292 Set_Discriminant_Constraint 9293 (New_Base, Discriminant_Constraint (Derived_Type)); 9294 end if; 9295 9296 return; 9297 end if; 9298 9299 -- If we get here Derived_Type will have no discriminants or it will be 9300 -- a discriminated unconstrained base type. 9301 9302 -- STEP 1a: perform preliminary actions/checks for derived tagged types 9303 9304 if Is_Tagged then 9305 9306 -- The parent type is frozen for non-private extensions (RM 13.14(7)) 9307 -- The declaration of a specific descendant of an interface type 9308 -- freezes the interface type (RM 13.14). 9309 9310 if not Private_Extension or else Is_Interface (Parent_Base) then 9311 Freeze_Before (N, Parent_Type); 9312 end if; 9313 9314 if Ada_Version >= Ada_2005 then 9315 Check_Generic_Ancestors; 9316 9317 elsif Type_Access_Level (Derived_Type) /= 9318 Type_Access_Level (Parent_Type) 9319 and then not Is_Generic_Type (Derived_Type) 9320 then 9321 if Is_Controlled (Parent_Type) then 9322 Error_Msg_N 9323 ("controlled type must be declared at the library level", 9324 Indic); 9325 else 9326 Error_Msg_N 9327 ("type extension at deeper accessibility level than parent", 9328 Indic); 9329 end if; 9330 9331 else 9332 declare 9333 GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type); 9334 begin 9335 if Present (GB) 9336 and then GB /= Enclosing_Generic_Body (Parent_Base) 9337 then 9338 Error_Msg_NE 9339 ("parent type of& must not be outside generic body" 9340 & " (RM 3.9.1(4))", 9341 Indic, Derived_Type); 9342 end if; 9343 end; 9344 end if; 9345 end if; 9346 9347 -- Ada 2005 (AI-251) 9348 9349 if Ada_Version >= Ada_2005 and then Is_Tagged then 9350 9351 -- "The declaration of a specific descendant of an interface type 9352 -- freezes the interface type" (RM 13.14). 9353 9354 declare 9355 Iface : Node_Id; 9356 begin 9357 if Is_Non_Empty_List (Interface_List (Type_Def)) then 9358 Iface := First (Interface_List (Type_Def)); 9359 while Present (Iface) loop 9360 Freeze_Before (N, Etype (Iface)); 9361 Next (Iface); 9362 end loop; 9363 end if; 9364 end; 9365 end if; 9366 9367 -- STEP 1b : preliminary cleanup of the full view of private types 9368 9369 -- If the type is already marked as having discriminants, then it's the 9370 -- completion of a private type or private extension and we need to 9371 -- retain the discriminants from the partial view if the current 9372 -- declaration has Discriminant_Specifications so that we can verify 9373 -- conformance. However, we must remove any existing components that 9374 -- were inherited from the parent (and attached in Copy_And_Swap) 9375 -- because the full type inherits all appropriate components anyway, and 9376 -- we do not want the partial view's components interfering. 9377 9378 if Has_Discriminants (Derived_Type) and then Discriminant_Specs then 9379 Discrim := First_Discriminant (Derived_Type); 9380 loop 9381 Last_Discrim := Discrim; 9382 Next_Discriminant (Discrim); 9383 exit when No (Discrim); 9384 end loop; 9385 9386 Set_Last_Entity (Derived_Type, Last_Discrim); 9387 9388 -- In all other cases wipe out the list of inherited components (even 9389 -- inherited discriminants), it will be properly rebuilt here. 9390 9391 else 9392 Set_First_Entity (Derived_Type, Empty); 9393 Set_Last_Entity (Derived_Type, Empty); 9394 end if; 9395 9396 -- STEP 1c: Initialize some flags for the Derived_Type 9397 9398 -- The following flags must be initialized here so that 9399 -- Process_Discriminants can check that discriminants of tagged types do 9400 -- not have a default initial value and that access discriminants are 9401 -- only specified for limited records. For completeness, these flags are 9402 -- also initialized along with all the other flags below. 9403 9404 -- AI-419: Limitedness is not inherited from an interface parent, so to 9405 -- be limited in that case the type must be explicitly declared as 9406 -- limited. However, task and protected interfaces are always limited. 9407 9408 if Limited_Present (Type_Def) then 9409 Set_Is_Limited_Record (Derived_Type); 9410 9411 elsif Is_Limited_Record (Parent_Type) 9412 or else (Present (Full_View (Parent_Type)) 9413 and then Is_Limited_Record (Full_View (Parent_Type))) 9414 then 9415 if not Is_Interface (Parent_Type) 9416 or else Is_Concurrent_Interface (Parent_Type) 9417 then 9418 Set_Is_Limited_Record (Derived_Type); 9419 end if; 9420 end if; 9421 9422 -- STEP 2a: process discriminants of derived type if any 9423 9424 Push_Scope (Derived_Type); 9425 9426 if Discriminant_Specs then 9427 Set_Has_Unknown_Discriminants (Derived_Type, False); 9428 9429 -- The following call initializes fields Has_Discriminants and 9430 -- Discriminant_Constraint, unless we are processing the completion 9431 -- of a private type declaration. 9432 9433 Check_Or_Process_Discriminants (N, Derived_Type); 9434 9435 -- For untagged types, the constraint on the Parent_Type must be 9436 -- present and is used to rename the discriminants. 9437 9438 if not Is_Tagged and then not Has_Discriminants (Parent_Type) then 9439 Error_Msg_N ("untagged parent must have discriminants", Indic); 9440 9441 elsif not Is_Tagged and then not Constraint_Present then 9442 Error_Msg_N 9443 ("discriminant constraint needed for derived untagged records", 9444 Indic); 9445 9446 -- Otherwise the parent subtype must be constrained unless we have a 9447 -- private extension. 9448 9449 elsif not Constraint_Present 9450 and then not Private_Extension 9451 and then not Is_Constrained (Parent_Type) 9452 then 9453 Error_Msg_N 9454 ("unconstrained type not allowed in this context", Indic); 9455 9456 elsif Constraint_Present then 9457 -- The following call sets the field Corresponding_Discriminant 9458 -- for the discriminants in the Derived_Type. 9459 9460 Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True); 9461 9462 -- For untagged types all new discriminants must rename 9463 -- discriminants in the parent. For private extensions new 9464 -- discriminants cannot rename old ones (implied by [7.3(13)]). 9465 9466 Discrim := First_Discriminant (Derived_Type); 9467 while Present (Discrim) loop 9468 if not Is_Tagged 9469 and then No (Corresponding_Discriminant (Discrim)) 9470 then 9471 Error_Msg_N 9472 ("new discriminants must constrain old ones", Discrim); 9473 9474 elsif Private_Extension 9475 and then Present (Corresponding_Discriminant (Discrim)) 9476 then 9477 Error_Msg_N 9478 ("only static constraints allowed for parent" 9479 & " discriminants in the partial view", Indic); 9480 exit; 9481 end if; 9482 9483 -- If a new discriminant is used in the constraint, then its 9484 -- subtype must be statically compatible with the subtype of 9485 -- the parent discriminant (RM 3.7(15)). 9486 9487 if Present (Corresponding_Discriminant (Discrim)) then 9488 Check_Constraining_Discriminant 9489 (Discrim, Corresponding_Discriminant (Discrim)); 9490 end if; 9491 9492 Next_Discriminant (Discrim); 9493 end loop; 9494 9495 -- Check whether the constraints of the full view statically 9496 -- match those imposed by the parent subtype [7.3(13)]. 9497 9498 if Present (Stored_Constraint (Derived_Type)) then 9499 declare 9500 C1, C2 : Elmt_Id; 9501 9502 begin 9503 C1 := First_Elmt (Discs); 9504 C2 := First_Elmt (Stored_Constraint (Derived_Type)); 9505 while Present (C1) and then Present (C2) loop 9506 if not 9507 Fully_Conformant_Expressions (Node (C1), Node (C2)) 9508 then 9509 Error_Msg_N 9510 ("not conformant with previous declaration", 9511 Node (C1)); 9512 end if; 9513 9514 Next_Elmt (C1); 9515 Next_Elmt (C2); 9516 end loop; 9517 end; 9518 end if; 9519 end if; 9520 9521 -- STEP 2b: No new discriminants, inherit discriminants if any 9522 9523 else 9524 if Private_Extension then 9525 Set_Has_Unknown_Discriminants 9526 (Derived_Type, 9527 Has_Unknown_Discriminants (Parent_Type) 9528 or else Unknown_Discriminants_Present (N)); 9529 9530 -- The partial view of the parent may have unknown discriminants, 9531 -- but if the full view has discriminants and the parent type is 9532 -- in scope they must be inherited. 9533 9534 elsif Has_Unknown_Discriminants (Parent_Type) 9535 and then 9536 (not Has_Discriminants (Parent_Type) 9537 or else not In_Open_Scopes (Scope (Parent_Base))) 9538 then 9539 Set_Has_Unknown_Discriminants (Derived_Type); 9540 end if; 9541 9542 if not Has_Unknown_Discriminants (Derived_Type) 9543 and then not Has_Unknown_Discriminants (Parent_Base) 9544 and then Has_Discriminants (Parent_Type) 9545 then 9546 Inherit_Discrims := True; 9547 Set_Has_Discriminants 9548 (Derived_Type, True); 9549 Set_Discriminant_Constraint 9550 (Derived_Type, Discriminant_Constraint (Parent_Base)); 9551 end if; 9552 9553 -- The following test is true for private types (remember 9554 -- transformation 5. is not applied to those) and in an error 9555 -- situation. 9556 9557 if Constraint_Present then 9558 Discs := Build_Discriminant_Constraints (Parent_Type, Indic); 9559 end if; 9560 9561 -- For now mark a new derived type as constrained only if it has no 9562 -- discriminants. At the end of Build_Derived_Record_Type we properly 9563 -- set this flag in the case of private extensions. See comments in 9564 -- point 9. just before body of Build_Derived_Record_Type. 9565 9566 Set_Is_Constrained 9567 (Derived_Type, 9568 not (Inherit_Discrims 9569 or else Has_Unknown_Discriminants (Derived_Type))); 9570 end if; 9571 9572 -- STEP 3: initialize fields of derived type 9573 9574 Set_Is_Tagged_Type (Derived_Type, Is_Tagged); 9575 Set_Stored_Constraint (Derived_Type, No_Elist); 9576 9577 -- Ada 2005 (AI-251): Private type-declarations can implement interfaces 9578 -- but cannot be interfaces 9579 9580 if not Private_Extension 9581 and then Ekind (Derived_Type) /= E_Private_Type 9582 and then Ekind (Derived_Type) /= E_Limited_Private_Type 9583 then 9584 if Interface_Present (Type_Def) then 9585 Analyze_Interface_Declaration (Derived_Type, Type_Def); 9586 end if; 9587 9588 Set_Interfaces (Derived_Type, No_Elist); 9589 end if; 9590 9591 -- Fields inherited from the Parent_Type 9592 9593 Set_Has_Specified_Layout 9594 (Derived_Type, Has_Specified_Layout (Parent_Type)); 9595 Set_Is_Limited_Composite 9596 (Derived_Type, Is_Limited_Composite (Parent_Type)); 9597 Set_Is_Private_Composite 9598 (Derived_Type, Is_Private_Composite (Parent_Type)); 9599 9600 if Is_Tagged_Type (Parent_Type) then 9601 Set_No_Tagged_Streams_Pragma 9602 (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type)); 9603 end if; 9604 9605 -- Fields inherited from the Parent_Base 9606 9607 Set_Has_Controlled_Component 9608 (Derived_Type, Has_Controlled_Component (Parent_Base)); 9609 Set_Has_Non_Standard_Rep 9610 (Derived_Type, Has_Non_Standard_Rep (Parent_Base)); 9611 Set_Has_Primitive_Operations 9612 (Derived_Type, Has_Primitive_Operations (Parent_Base)); 9613 9614 -- Set fields for private derived types 9615 9616 if Is_Private_Type (Derived_Type) then 9617 Set_Depends_On_Private (Derived_Type, True); 9618 Set_Private_Dependents (Derived_Type, New_Elmt_List); 9619 end if; 9620 9621 -- Inherit fields for non-private types. If this is the completion of a 9622 -- derivation from a private type, the parent itself is private and the 9623 -- attributes come from its full view, which must be present. 9624 9625 if Is_Record_Type (Derived_Type) then 9626 declare 9627 Parent_Full : Entity_Id; 9628 9629 begin 9630 if Is_Private_Type (Parent_Base) 9631 and then not Is_Record_Type (Parent_Base) 9632 then 9633 Parent_Full := Full_View (Parent_Base); 9634 else 9635 Parent_Full := Parent_Base; 9636 end if; 9637 9638 Set_Component_Alignment 9639 (Derived_Type, Component_Alignment (Parent_Full)); 9640 Set_C_Pass_By_Copy 9641 (Derived_Type, C_Pass_By_Copy (Parent_Full)); 9642 Set_Has_Complex_Representation 9643 (Derived_Type, Has_Complex_Representation (Parent_Full)); 9644 9645 -- For untagged types, inherit the layout by default to avoid 9646 -- costly changes of representation for type conversions. 9647 9648 if not Is_Tagged then 9649 Set_Is_Packed (Derived_Type, Is_Packed (Parent_Full)); 9650 Set_No_Reordering (Derived_Type, No_Reordering (Parent_Full)); 9651 end if; 9652 end; 9653 end if; 9654 9655 -- Initialize the list of primitive operations to an empty list, 9656 -- to cover tagged types as well as untagged types. For untagged 9657 -- types this is used either to analyze the call as legal when 9658 -- Extensions_Allowed is True, or to issue a better error message 9659 -- otherwise. 9660 9661 Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); 9662 9663 -- Set fields for tagged types 9664 9665 if Is_Tagged then 9666 -- All tagged types defined in Ada.Finalization are controlled 9667 9668 if Chars (Scope (Derived_Type)) = Name_Finalization 9669 and then Chars (Scope (Scope (Derived_Type))) = Name_Ada 9670 and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard 9671 then 9672 Set_Is_Controlled_Active (Derived_Type); 9673 else 9674 Set_Is_Controlled_Active 9675 (Derived_Type, Is_Controlled_Active (Parent_Base)); 9676 end if; 9677 9678 -- Minor optimization: there is no need to generate the class-wide 9679 -- entity associated with an underlying record view. 9680 9681 if not Is_Underlying_Record_View (Derived_Type) then 9682 Make_Class_Wide_Type (Derived_Type); 9683 end if; 9684 9685 Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def)); 9686 9687 if Has_Discriminants (Derived_Type) 9688 and then Constraint_Present 9689 then 9690 Set_Stored_Constraint 9691 (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs)); 9692 end if; 9693 9694 if Ada_Version >= Ada_2005 then 9695 declare 9696 Ifaces_List : Elist_Id; 9697 9698 begin 9699 -- Checks rules 3.9.4 (13/2 and 14/2) 9700 9701 if Comes_From_Source (Derived_Type) 9702 and then not Is_Private_Type (Derived_Type) 9703 and then Is_Interface (Parent_Type) 9704 and then not Is_Interface (Derived_Type) 9705 then 9706 if Is_Task_Interface (Parent_Type) then 9707 Error_Msg_N 9708 ("(Ada 2005) task type required (RM 3.9.4 (13.2))", 9709 Derived_Type); 9710 9711 elsif Is_Protected_Interface (Parent_Type) then 9712 Error_Msg_N 9713 ("(Ada 2005) protected type required (RM 3.9.4 (14.2))", 9714 Derived_Type); 9715 end if; 9716 end if; 9717 9718 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) 9719 9720 Check_Interfaces (N, Type_Def); 9721 9722 -- Ada 2005 (AI-251): Collect the list of progenitors that are 9723 -- not already in the parents. 9724 9725 Collect_Interfaces 9726 (T => Derived_Type, 9727 Ifaces_List => Ifaces_List, 9728 Exclude_Parents => True); 9729 9730 Set_Interfaces (Derived_Type, Ifaces_List); 9731 9732 -- If the derived type is the anonymous type created for 9733 -- a declaration whose parent has a constraint, propagate 9734 -- the interface list to the source type. This must be done 9735 -- prior to the completion of the analysis of the source type 9736 -- because the components in the extension may contain current 9737 -- instances whose legality depends on some ancestor. 9738 9739 if Is_Itype (Derived_Type) then 9740 declare 9741 Def : constant Node_Id := 9742 Associated_Node_For_Itype (Derived_Type); 9743 begin 9744 if Present (Def) 9745 and then Nkind (Def) = N_Full_Type_Declaration 9746 then 9747 Set_Interfaces 9748 (Defining_Identifier (Def), Ifaces_List); 9749 end if; 9750 end; 9751 end if; 9752 9753 -- A type extension is automatically Ghost when one of its 9754 -- progenitors is Ghost (SPARK RM 6.9(9)). This property is 9755 -- also inherited when the parent type is Ghost, but this is 9756 -- done in Build_Derived_Type as the mechanism also handles 9757 -- untagged derivations. 9758 9759 if Implements_Ghost_Interface (Derived_Type) then 9760 Set_Is_Ghost_Entity (Derived_Type); 9761 end if; 9762 end; 9763 end if; 9764 end if; 9765 9766 -- STEP 4: Inherit components from the parent base and constrain them. 9767 -- Apply the second transformation described in point 6. above. 9768 9769 if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims) 9770 or else not Has_Discriminants (Parent_Type) 9771 or else not Is_Constrained (Parent_Type) 9772 then 9773 Constrs := Discs; 9774 else 9775 Constrs := Discriminant_Constraint (Parent_Type); 9776 end if; 9777 9778 Assoc_List := 9779 Inherit_Components 9780 (N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs); 9781 9782 -- STEP 5a: Copy the parent record declaration for untagged types 9783 9784 Set_Has_Implicit_Dereference 9785 (Derived_Type, Has_Implicit_Dereference (Parent_Type)); 9786 9787 if not Is_Tagged then 9788 9789 -- Discriminant_Constraint (Derived_Type) has been properly 9790 -- constructed. Save it and temporarily set it to Empty because we 9791 -- do not want the call to New_Copy_Tree below to mess this list. 9792 9793 if Has_Discriminants (Derived_Type) then 9794 Save_Discr_Constr := Discriminant_Constraint (Derived_Type); 9795 Set_Discriminant_Constraint (Derived_Type, No_Elist); 9796 else 9797 Save_Discr_Constr := No_Elist; 9798 end if; 9799 9800 -- Save the Etype field of Derived_Type. It is correctly set now, 9801 -- but the call to New_Copy tree may remap it to point to itself, 9802 -- which is not what we want. Ditto for the Next_Entity field. 9803 9804 Save_Etype := Etype (Derived_Type); 9805 Save_Next_Entity := Next_Entity (Derived_Type); 9806 9807 -- Assoc_List maps all stored discriminants in the Parent_Base to 9808 -- stored discriminants in the Derived_Type. It is fundamental that 9809 -- no types or itypes with discriminants other than the stored 9810 -- discriminants appear in the entities declared inside 9811 -- Derived_Type, since the back end cannot deal with it. 9812 9813 New_Decl := 9814 New_Copy_Tree 9815 (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc); 9816 Copy_Dimensions_Of_Components (Derived_Type); 9817 9818 -- Restore the fields saved prior to the New_Copy_Tree call 9819 -- and compute the stored constraint. 9820 9821 Set_Etype (Derived_Type, Save_Etype); 9822 Link_Entities (Derived_Type, Save_Next_Entity); 9823 9824 if Has_Discriminants (Derived_Type) then 9825 Set_Discriminant_Constraint 9826 (Derived_Type, Save_Discr_Constr); 9827 Set_Stored_Constraint 9828 (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs)); 9829 9830 Replace_Discriminants (Derived_Type, New_Decl); 9831 end if; 9832 9833 -- Insert the new derived type declaration 9834 9835 Rewrite (N, New_Decl); 9836 9837 -- STEP 5b: Complete the processing for record extensions in generics 9838 9839 -- There is no completion for record extensions declared in the 9840 -- parameter part of a generic, so we need to complete processing for 9841 -- these generic record extensions here. The Record_Type_Definition call 9842 -- will change the Ekind of the components from E_Void to E_Component. 9843 9844 elsif Private_Extension and then Is_Generic_Type (Derived_Type) then 9845 Record_Type_Definition (Empty, Derived_Type); 9846 9847 -- STEP 5c: Process the record extension for non private tagged types 9848 9849 elsif not Private_Extension then 9850 Expand_Record_Extension (Derived_Type, Type_Def); 9851 9852 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the 9853 -- implemented interfaces if we are in expansion mode 9854 9855 if Expander_Active 9856 and then Has_Interfaces (Derived_Type) 9857 then 9858 Add_Interface_Tag_Components (N, Derived_Type); 9859 end if; 9860 9861 -- Analyze the record extension 9862 9863 Record_Type_Definition 9864 (Record_Extension_Part (Type_Def), Derived_Type); 9865 end if; 9866 9867 End_Scope; 9868 9869 -- Nothing else to do if there is an error in the derivation. 9870 -- An unusual case: the full view may be derived from a type in an 9871 -- instance, when the partial view was used illegally as an actual 9872 -- in that instance, leading to a circular definition. 9873 9874 if Etype (Derived_Type) = Any_Type 9875 or else Etype (Parent_Type) = Derived_Type 9876 then 9877 return; 9878 end if; 9879 9880 -- Set delayed freeze and then derive subprograms, we need to do 9881 -- this in this order so that derived subprograms inherit the 9882 -- derived freeze if necessary. 9883 9884 Set_Has_Delayed_Freeze (Derived_Type); 9885 9886 if Derive_Subps then 9887 Derive_Subprograms (Parent_Type, Derived_Type); 9888 end if; 9889 9890 -- If we have a private extension which defines a constrained derived 9891 -- type mark as constrained here after we have derived subprograms. See 9892 -- comment on point 9. just above the body of Build_Derived_Record_Type. 9893 9894 if Private_Extension and then Inherit_Discrims then 9895 if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then 9896 Set_Is_Constrained (Derived_Type, True); 9897 Set_Discriminant_Constraint (Derived_Type, Discs); 9898 9899 elsif Is_Constrained (Parent_Type) then 9900 Set_Is_Constrained 9901 (Derived_Type, True); 9902 Set_Discriminant_Constraint 9903 (Derived_Type, Discriminant_Constraint (Parent_Type)); 9904 end if; 9905 end if; 9906 9907 -- Update the class-wide type, which shares the now-completed entity 9908 -- list with its specific type. In case of underlying record views, 9909 -- we do not generate the corresponding class wide entity. 9910 9911 if Is_Tagged 9912 and then not Is_Underlying_Record_View (Derived_Type) 9913 then 9914 Set_First_Entity 9915 (Class_Wide_Type (Derived_Type), First_Entity (Derived_Type)); 9916 Set_Last_Entity 9917 (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type)); 9918 end if; 9919 9920 Check_Function_Writable_Actuals (N); 9921 end Build_Derived_Record_Type; 9922 9923 ------------------------ 9924 -- Build_Derived_Type -- 9925 ------------------------ 9926 9927 procedure Build_Derived_Type 9928 (N : Node_Id; 9929 Parent_Type : Entity_Id; 9930 Derived_Type : Entity_Id; 9931 Is_Completion : Boolean; 9932 Derive_Subps : Boolean := True) 9933 is 9934 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 9935 9936 begin 9937 -- Set common attributes 9938 9939 if Ekind (Derived_Type) in Incomplete_Or_Private_Kind 9940 and then Ekind (Parent_Base) in Modular_Integer_Kind | Array_Kind 9941 then 9942 Reinit_Field_To_Zero (Derived_Type, F_Stored_Constraint); 9943 end if; 9944 9945 Set_Scope (Derived_Type, Current_Scope); 9946 Set_Etype (Derived_Type, Parent_Base); 9947 Mutate_Ekind (Derived_Type, Ekind (Parent_Base)); 9948 Propagate_Concurrent_Flags (Derived_Type, Parent_Base); 9949 9950 Set_Size_Info (Derived_Type, Parent_Type); 9951 Copy_RM_Size (To => Derived_Type, From => Parent_Type); 9952 9953 Set_Is_Controlled_Active 9954 (Derived_Type, Is_Controlled_Active (Parent_Type)); 9955 9956 Set_Disable_Controlled (Derived_Type, Disable_Controlled (Parent_Type)); 9957 Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); 9958 Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type)); 9959 9960 if Is_Tagged_Type (Derived_Type) then 9961 Set_No_Tagged_Streams_Pragma 9962 (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type)); 9963 end if; 9964 9965 -- If the parent has primitive routines and may have not-seen-yet aspect 9966 -- specifications (e.g., a Pack pragma), then set the derived type link 9967 -- in order to later diagnose "early derivation" issues. If in different 9968 -- compilation units, then "early derivation" cannot be an issue (and we 9969 -- don't like interunit references that go in the opposite direction of 9970 -- semantic dependencies). 9971 9972 if Has_Primitive_Operations (Parent_Type) 9973 and then Enclosing_Comp_Unit_Node (Parent_Type) = 9974 Enclosing_Comp_Unit_Node (Derived_Type) 9975 then 9976 Set_Derived_Type_Link (Parent_Base, Derived_Type); 9977 end if; 9978 9979 -- If the parent type is a private subtype, the convention on the base 9980 -- type may be set in the private part, and not propagated to the 9981 -- subtype until later, so we obtain the convention from the base type. 9982 9983 Set_Convention (Derived_Type, Convention (Parent_Base)); 9984 9985 if Is_Tagged_Type (Derived_Type) 9986 and then Present (Class_Wide_Type (Derived_Type)) 9987 then 9988 Set_Convention (Class_Wide_Type (Derived_Type), 9989 Convention (Class_Wide_Type (Parent_Base))); 9990 end if; 9991 9992 -- Set SSO default for record or array type 9993 9994 if (Is_Array_Type (Derived_Type) or else Is_Record_Type (Derived_Type)) 9995 and then Is_Base_Type (Derived_Type) 9996 then 9997 Set_Default_SSO (Derived_Type); 9998 end if; 9999 10000 -- A derived type inherits the Default_Initial_Condition pragma coming 10001 -- from any parent type within the derivation chain. 10002 10003 if Has_DIC (Parent_Type) then 10004 Set_Has_Inherited_DIC (Derived_Type); 10005 end if; 10006 10007 -- A derived type inherits any class-wide invariants coming from a 10008 -- parent type or an interface. Note that the invariant procedure of 10009 -- the parent type should not be inherited because the derived type may 10010 -- define invariants of its own. 10011 10012 if not Is_Interface (Derived_Type) then 10013 if Has_Inherited_Invariants (Parent_Type) 10014 or else Has_Inheritable_Invariants (Parent_Type) 10015 then 10016 Set_Has_Inherited_Invariants (Derived_Type); 10017 10018 elsif Is_Concurrent_Type (Derived_Type) 10019 or else Is_Tagged_Type (Derived_Type) 10020 then 10021 declare 10022 Iface : Entity_Id; 10023 Ifaces : Elist_Id; 10024 Iface_Elmt : Elmt_Id; 10025 10026 begin 10027 Collect_Interfaces 10028 (T => Derived_Type, 10029 Ifaces_List => Ifaces, 10030 Exclude_Parents => True); 10031 10032 if Present (Ifaces) then 10033 Iface_Elmt := First_Elmt (Ifaces); 10034 while Present (Iface_Elmt) loop 10035 Iface := Node (Iface_Elmt); 10036 10037 if Has_Inheritable_Invariants (Iface) then 10038 Set_Has_Inherited_Invariants (Derived_Type); 10039 exit; 10040 end if; 10041 10042 Next_Elmt (Iface_Elmt); 10043 end loop; 10044 end if; 10045 end; 10046 end if; 10047 end if; 10048 10049 -- We similarly inherit predicates. Note that for scalar derived types 10050 -- the predicate is inherited from the first subtype, and not from its 10051 -- (anonymous) base type. 10052 10053 if Has_Predicates (Parent_Type) 10054 or else Has_Predicates (First_Subtype (Parent_Type)) 10055 then 10056 Set_Has_Predicates (Derived_Type); 10057 end if; 10058 10059 -- The derived type inherits representation clauses from the parent 10060 -- type, and from any interfaces. 10061 10062 Inherit_Rep_Item_Chain (Derived_Type, Parent_Type); 10063 10064 declare 10065 Iface : Node_Id := First (Abstract_Interface_List (Derived_Type)); 10066 begin 10067 while Present (Iface) loop 10068 Inherit_Rep_Item_Chain (Derived_Type, Entity (Iface)); 10069 Next (Iface); 10070 end loop; 10071 end; 10072 10073 -- If the parent type has delayed rep aspects, then mark the derived 10074 -- type as possibly inheriting a delayed rep aspect. 10075 10076 if Has_Delayed_Rep_Aspects (Parent_Type) then 10077 Set_May_Inherit_Delayed_Rep_Aspects (Derived_Type); 10078 end if; 10079 10080 -- A derived type becomes Ghost when its parent type is also Ghost 10081 -- (SPARK RM 6.9(9)). Note that the Ghost-related attributes are not 10082 -- directly inherited because the Ghost policy in effect may differ. 10083 10084 if Is_Ghost_Entity (Parent_Type) then 10085 Set_Is_Ghost_Entity (Derived_Type); 10086 end if; 10087 10088 -- Type dependent processing 10089 10090 case Ekind (Parent_Type) is 10091 when Numeric_Kind => 10092 Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type); 10093 10094 when Array_Kind => 10095 Build_Derived_Array_Type (N, Parent_Type, Derived_Type); 10096 10097 when Class_Wide_Kind 10098 | E_Record_Subtype 10099 | E_Record_Type 10100 => 10101 Build_Derived_Record_Type 10102 (N, Parent_Type, Derived_Type, Derive_Subps); 10103 return; 10104 10105 when Enumeration_Kind => 10106 Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type); 10107 10108 when Access_Kind => 10109 Build_Derived_Access_Type (N, Parent_Type, Derived_Type); 10110 10111 when Incomplete_Or_Private_Kind => 10112 Build_Derived_Private_Type 10113 (N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps); 10114 10115 -- For discriminated types, the derivation includes deriving 10116 -- primitive operations. For others it is done below. 10117 10118 if Is_Tagged_Type (Parent_Type) 10119 or else Has_Discriminants (Parent_Type) 10120 or else (Present (Full_View (Parent_Type)) 10121 and then Has_Discriminants (Full_View (Parent_Type))) 10122 then 10123 return; 10124 end if; 10125 10126 when Concurrent_Kind => 10127 Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type); 10128 10129 when others => 10130 raise Program_Error; 10131 end case; 10132 10133 -- Nothing more to do if some error occurred 10134 10135 if Etype (Derived_Type) = Any_Type then 10136 return; 10137 end if; 10138 10139 -- If not already set, initialize the derived type's list of primitive 10140 -- operations to an empty element list. 10141 10142 if not Present (Direct_Primitive_Operations (Derived_Type)) then 10143 Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); 10144 10145 -- If Etype of the derived type is the base type (as opposed to 10146 -- a parent type) and doesn't have an associated list of primitive 10147 -- operations, then set the base type's primitive list to the 10148 -- derived type's list. The lists need to be shared in common 10149 -- between the two. 10150 10151 if Etype (Derived_Type) = Base_Type (Derived_Type) 10152 and then 10153 not Present (Direct_Primitive_Operations (Etype (Derived_Type))) 10154 then 10155 Set_Direct_Primitive_Operations 10156 (Etype (Derived_Type), 10157 Direct_Primitive_Operations (Derived_Type)); 10158 end if; 10159 end if; 10160 10161 -- Set delayed freeze and then derive subprograms, we need to do this 10162 -- in this order so that derived subprograms inherit the derived freeze 10163 -- if necessary. 10164 10165 Set_Has_Delayed_Freeze (Derived_Type); 10166 10167 if Derive_Subps then 10168 Derive_Subprograms (Parent_Type, Derived_Type); 10169 end if; 10170 10171 Set_Has_Primitive_Operations 10172 (Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type)); 10173 end Build_Derived_Type; 10174 10175 ----------------------- 10176 -- Build_Discriminal -- 10177 ----------------------- 10178 10179 procedure Build_Discriminal (Discrim : Entity_Id) is 10180 D_Minal : Entity_Id; 10181 CR_Disc : Entity_Id; 10182 10183 begin 10184 -- A discriminal has the same name as the discriminant 10185 10186 D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); 10187 10188 Mutate_Ekind (D_Minal, E_In_Parameter); 10189 Set_Mechanism (D_Minal, Default_Mechanism); 10190 Set_Etype (D_Minal, Etype (Discrim)); 10191 Set_Scope (D_Minal, Current_Scope); 10192 Set_Parent (D_Minal, Parent (Discrim)); 10193 10194 Set_Discriminal (Discrim, D_Minal); 10195 Set_Discriminal_Link (D_Minal, Discrim); 10196 10197 -- For task types, build at once the discriminants of the corresponding 10198 -- record, which are needed if discriminants are used in entry defaults 10199 -- and in family bounds. 10200 10201 if Is_Concurrent_Type (Current_Scope) 10202 or else 10203 Is_Limited_Type (Current_Scope) 10204 then 10205 CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); 10206 10207 Mutate_Ekind (CR_Disc, E_In_Parameter); 10208 Set_Mechanism (CR_Disc, Default_Mechanism); 10209 Set_Etype (CR_Disc, Etype (Discrim)); 10210 Set_Scope (CR_Disc, Current_Scope); 10211 Set_Discriminal_Link (CR_Disc, Discrim); 10212 Set_CR_Discriminant (Discrim, CR_Disc); 10213 end if; 10214 end Build_Discriminal; 10215 10216 ------------------------------------ 10217 -- Build_Discriminant_Constraints -- 10218 ------------------------------------ 10219 10220 function Build_Discriminant_Constraints 10221 (T : Entity_Id; 10222 Def : Node_Id; 10223 Derived_Def : Boolean := False) return Elist_Id 10224 is 10225 C : constant Node_Id := Constraint (Def); 10226 Nb_Discr : constant Nat := Number_Discriminants (T); 10227 10228 Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty); 10229 -- Saves the expression corresponding to a given discriminant in T 10230 10231 function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat; 10232 -- Return the Position number within array Discr_Expr of a discriminant 10233 -- D within the discriminant list of the discriminated type T. 10234 10235 procedure Process_Discriminant_Expression 10236 (Expr : Node_Id; 10237 D : Entity_Id); 10238 -- If this is a discriminant constraint on a partial view, do not 10239 -- generate an overflow check on the discriminant expression. The check 10240 -- will be generated when constraining the full view. Otherwise the 10241 -- backend creates duplicate symbols for the temporaries corresponding 10242 -- to the expressions to be checked, causing spurious assembler errors. 10243 10244 ------------------ 10245 -- Pos_Of_Discr -- 10246 ------------------ 10247 10248 function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is 10249 Disc : Entity_Id; 10250 10251 begin 10252 Disc := First_Discriminant (T); 10253 for J in Discr_Expr'Range loop 10254 if Disc = D then 10255 return J; 10256 end if; 10257 10258 Next_Discriminant (Disc); 10259 end loop; 10260 10261 -- Note: Since this function is called on discriminants that are 10262 -- known to belong to the discriminated type, falling through the 10263 -- loop with no match signals an internal compiler error. 10264 10265 raise Program_Error; 10266 end Pos_Of_Discr; 10267 10268 ------------------------------------- 10269 -- Process_Discriminant_Expression -- 10270 ------------------------------------- 10271 10272 procedure Process_Discriminant_Expression 10273 (Expr : Node_Id; 10274 D : Entity_Id) 10275 is 10276 BDT : constant Entity_Id := Base_Type (Etype (D)); 10277 10278 begin 10279 -- If this is a discriminant constraint on a partial view, do 10280 -- not generate an overflow on the discriminant expression. The 10281 -- check will be generated when constraining the full view. 10282 10283 if Is_Private_Type (T) 10284 and then Present (Full_View (T)) 10285 then 10286 Analyze_And_Resolve (Expr, BDT, Suppress => Overflow_Check); 10287 else 10288 Analyze_And_Resolve (Expr, BDT); 10289 end if; 10290 end Process_Discriminant_Expression; 10291 10292 -- Declarations local to Build_Discriminant_Constraints 10293 10294 Discr : Entity_Id; 10295 E : Entity_Id; 10296 Elist : constant Elist_Id := New_Elmt_List; 10297 10298 Constr : Node_Id; 10299 Expr : Node_Id; 10300 Id : Node_Id; 10301 Position : Nat; 10302 Found : Boolean; 10303 10304 Discrim_Present : Boolean := False; 10305 10306 -- Start of processing for Build_Discriminant_Constraints 10307 10308 begin 10309 -- The following loop will process positional associations only. 10310 -- For a positional association, the (single) discriminant is 10311 -- implicitly specified by position, in textual order (RM 3.7.2). 10312 10313 Discr := First_Discriminant (T); 10314 Constr := First (Constraints (C)); 10315 for D in Discr_Expr'Range loop 10316 exit when Nkind (Constr) = N_Discriminant_Association; 10317 10318 if No (Constr) then 10319 Error_Msg_N ("too few discriminants given in constraint", C); 10320 return New_Elmt_List; 10321 10322 elsif Nkind (Constr) = N_Range 10323 or else (Nkind (Constr) = N_Attribute_Reference 10324 and then Attribute_Name (Constr) = Name_Range) 10325 then 10326 Error_Msg_N 10327 ("a range is not a valid discriminant constraint", Constr); 10328 Discr_Expr (D) := Error; 10329 10330 elsif Nkind (Constr) = N_Subtype_Indication then 10331 Error_Msg_N 10332 ("a subtype indication is not a valid discriminant constraint", 10333 Constr); 10334 Discr_Expr (D) := Error; 10335 10336 else 10337 Process_Discriminant_Expression (Constr, Discr); 10338 Discr_Expr (D) := Constr; 10339 end if; 10340 10341 Next_Discriminant (Discr); 10342 Next (Constr); 10343 end loop; 10344 10345 if No (Discr) and then Present (Constr) then 10346 Error_Msg_N ("too many discriminants given in constraint", Constr); 10347 return New_Elmt_List; 10348 end if; 10349 10350 -- Named associations can be given in any order, but if both positional 10351 -- and named associations are used in the same discriminant constraint, 10352 -- then positional associations must occur first, at their normal 10353 -- position. Hence once a named association is used, the rest of the 10354 -- discriminant constraint must use only named associations. 10355 10356 while Present (Constr) loop 10357 10358 -- Positional association forbidden after a named association 10359 10360 if Nkind (Constr) /= N_Discriminant_Association then 10361 Error_Msg_N ("positional association follows named one", Constr); 10362 return New_Elmt_List; 10363 10364 -- Otherwise it is a named association 10365 10366 else 10367 -- E records the type of the discriminants in the named 10368 -- association. All the discriminants specified in the same name 10369 -- association must have the same type. 10370 10371 E := Empty; 10372 10373 -- Search the list of discriminants in T to see if the simple name 10374 -- given in the constraint matches any of them. 10375 10376 Id := First (Selector_Names (Constr)); 10377 while Present (Id) loop 10378 Found := False; 10379 10380 -- If Original_Discriminant is present, we are processing a 10381 -- generic instantiation and this is an instance node. We need 10382 -- to find the name of the corresponding discriminant in the 10383 -- actual record type T and not the name of the discriminant in 10384 -- the generic formal. Example: 10385 10386 -- generic 10387 -- type G (D : int) is private; 10388 -- package P is 10389 -- subtype W is G (D => 1); 10390 -- end package; 10391 -- type Rec (X : int) is record ... end record; 10392 -- package Q is new P (G => Rec); 10393 10394 -- At the point of the instantiation, formal type G is Rec 10395 -- and therefore when reanalyzing "subtype W is G (D => 1);" 10396 -- which really looks like "subtype W is Rec (D => 1);" at 10397 -- the point of instantiation, we want to find the discriminant 10398 -- that corresponds to D in Rec, i.e. X. 10399 10400 if Present (Original_Discriminant (Id)) 10401 and then In_Instance 10402 then 10403 Discr := Find_Corresponding_Discriminant (Id, T); 10404 Found := True; 10405 10406 else 10407 Discr := First_Discriminant (T); 10408 while Present (Discr) loop 10409 if Chars (Discr) = Chars (Id) then 10410 Found := True; 10411 exit; 10412 end if; 10413 10414 Next_Discriminant (Discr); 10415 end loop; 10416 10417 if not Found then 10418 Error_Msg_N ("& does not match any discriminant", Id); 10419 return New_Elmt_List; 10420 10421 -- If the parent type is a generic formal, preserve the 10422 -- name of the discriminant for subsequent instances. 10423 -- see comment at the beginning of this if statement. 10424 10425 elsif Is_Generic_Type (Root_Type (T)) then 10426 Set_Original_Discriminant (Id, Discr); 10427 end if; 10428 end if; 10429 10430 Position := Pos_Of_Discr (T, Discr); 10431 10432 if Present (Discr_Expr (Position)) then 10433 Error_Msg_N ("duplicate constraint for discriminant&", Id); 10434 10435 else 10436 -- Each discriminant specified in the same named association 10437 -- must be associated with a separate copy of the 10438 -- corresponding expression. 10439 10440 if Present (Next (Id)) then 10441 Expr := New_Copy_Tree (Expression (Constr)); 10442 Set_Parent (Expr, Parent (Expression (Constr))); 10443 else 10444 Expr := Expression (Constr); 10445 end if; 10446 10447 Discr_Expr (Position) := Expr; 10448 Process_Discriminant_Expression (Expr, Discr); 10449 end if; 10450 10451 -- A discriminant association with more than one discriminant 10452 -- name is only allowed if the named discriminants are all of 10453 -- the same type (RM 3.7.1(8)). 10454 10455 if E = Empty then 10456 E := Base_Type (Etype (Discr)); 10457 10458 elsif Base_Type (Etype (Discr)) /= E then 10459 Error_Msg_N 10460 ("all discriminants in an association " & 10461 "must have the same type", Id); 10462 end if; 10463 10464 Next (Id); 10465 end loop; 10466 end if; 10467 10468 Next (Constr); 10469 end loop; 10470 10471 -- A discriminant constraint must provide exactly one value for each 10472 -- discriminant of the type (RM 3.7.1(8)). 10473 10474 for J in Discr_Expr'Range loop 10475 if No (Discr_Expr (J)) then 10476 Error_Msg_N ("too few discriminants given in constraint", C); 10477 return New_Elmt_List; 10478 end if; 10479 end loop; 10480 10481 -- Determine if there are discriminant expressions in the constraint 10482 10483 for J in Discr_Expr'Range loop 10484 if Denotes_Discriminant 10485 (Discr_Expr (J), Check_Concurrent => True) 10486 then 10487 Discrim_Present := True; 10488 exit; 10489 end if; 10490 end loop; 10491 10492 -- Build an element list consisting of the expressions given in the 10493 -- discriminant constraint and apply the appropriate checks. The list 10494 -- is constructed after resolving any named discriminant associations 10495 -- and therefore the expressions appear in the textual order of the 10496 -- discriminants. 10497 10498 Discr := First_Discriminant (T); 10499 for J in Discr_Expr'Range loop 10500 if Discr_Expr (J) /= Error then 10501 Append_Elmt (Discr_Expr (J), Elist); 10502 10503 -- If any of the discriminant constraints is given by a 10504 -- discriminant and we are in a derived type declaration we 10505 -- have a discriminant renaming. Establish link between new 10506 -- and old discriminant. The new discriminant has an implicit 10507 -- dereference if the old one does. 10508 10509 if Denotes_Discriminant (Discr_Expr (J)) then 10510 if Derived_Def then 10511 declare 10512 New_Discr : constant Entity_Id := Entity (Discr_Expr (J)); 10513 10514 begin 10515 Set_Corresponding_Discriminant (New_Discr, Discr); 10516 Set_Has_Implicit_Dereference (New_Discr, 10517 Has_Implicit_Dereference (Discr)); 10518 end; 10519 end if; 10520 10521 -- Force the evaluation of non-discriminant expressions. 10522 -- If we have found a discriminant in the constraint 3.4(26) 10523 -- and 3.8(18) demand that no range checks are performed are 10524 -- after evaluation. If the constraint is for a component 10525 -- definition that has a per-object constraint, expressions are 10526 -- evaluated but not checked either. In all other cases perform 10527 -- a range check. 10528 10529 else 10530 if Discrim_Present then 10531 null; 10532 10533 elsif Parent_Kind (Parent (Def)) = N_Component_Declaration 10534 and then Has_Per_Object_Constraint 10535 (Defining_Identifier (Parent (Parent (Def)))) 10536 then 10537 null; 10538 10539 elsif Is_Access_Type (Etype (Discr)) then 10540 Apply_Constraint_Check (Discr_Expr (J), Etype (Discr)); 10541 10542 else 10543 Apply_Range_Check (Discr_Expr (J), Etype (Discr)); 10544 end if; 10545 10546 -- If the value of the discriminant may be visible in 10547 -- another unit or child unit, create an external name 10548 -- for it. We use the name of the object or component 10549 -- that carries the discriminated subtype. The code 10550 -- below may generate external symbols for the discriminant 10551 -- expression when not strictly needed, which is harmless. 10552 10553 if Expander_Active 10554 and then Comes_From_Source (Def) 10555 and then not Is_Subprogram (Current_Scope) 10556 then 10557 declare 10558 Id : Entity_Id := Empty; 10559 begin 10560 if Nkind (Parent (Def)) = N_Object_Declaration then 10561 Id := Defining_Identifier (Parent (Def)); 10562 10563 elsif Nkind (Parent (Def)) = N_Component_Definition 10564 and then 10565 Nkind (Parent (Parent (Def))) 10566 = N_Component_Declaration 10567 then 10568 Id := Defining_Identifier (Parent (Parent (Def))); 10569 end if; 10570 10571 if Present (Id) then 10572 Force_Evaluation ( 10573 Discr_Expr (J), 10574 Related_Id => Id, 10575 Discr_Number => J); 10576 else 10577 Force_Evaluation (Discr_Expr (J)); 10578 end if; 10579 end; 10580 else 10581 Force_Evaluation (Discr_Expr (J)); 10582 end if; 10583 end if; 10584 10585 -- Check that the designated type of an access discriminant's 10586 -- expression is not a class-wide type unless the discriminant's 10587 -- designated type is also class-wide. 10588 10589 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type 10590 and then not Is_Class_Wide_Type 10591 (Designated_Type (Etype (Discr))) 10592 and then Etype (Discr_Expr (J)) /= Any_Type 10593 and then Is_Class_Wide_Type 10594 (Designated_Type (Etype (Discr_Expr (J)))) 10595 then 10596 Wrong_Type (Discr_Expr (J), Etype (Discr)); 10597 10598 elsif Is_Access_Type (Etype (Discr)) 10599 and then not Is_Access_Constant (Etype (Discr)) 10600 and then Is_Access_Type (Etype (Discr_Expr (J))) 10601 and then Is_Access_Constant (Etype (Discr_Expr (J))) 10602 then 10603 Error_Msg_NE 10604 ("constraint for discriminant& must be access to variable", 10605 Def, Discr); 10606 end if; 10607 end if; 10608 10609 Next_Discriminant (Discr); 10610 end loop; 10611 10612 return Elist; 10613 end Build_Discriminant_Constraints; 10614 10615 --------------------------------- 10616 -- Build_Discriminated_Subtype -- 10617 --------------------------------- 10618 10619 procedure Build_Discriminated_Subtype 10620 (T : Entity_Id; 10621 Def_Id : Entity_Id; 10622 Elist : Elist_Id; 10623 Related_Nod : Node_Id; 10624 For_Access : Boolean := False) 10625 is 10626 Has_Discrs : constant Boolean := Has_Discriminants (T); 10627 Constrained : constant Boolean := 10628 (Has_Discrs 10629 and then not Is_Empty_Elmt_List (Elist) 10630 and then not Is_Class_Wide_Type (T)) 10631 or else Is_Constrained (T); 10632 10633 begin 10634 if Ekind (T) = E_Record_Type then 10635 Mutate_Ekind (Def_Id, E_Record_Subtype); 10636 10637 -- Inherit preelaboration flag from base, for types for which it 10638 -- may have been set: records, private types, protected types. 10639 10640 Set_Known_To_Have_Preelab_Init 10641 (Def_Id, Known_To_Have_Preelab_Init (T)); 10642 10643 elsif Ekind (T) = E_Task_Type then 10644 Mutate_Ekind (Def_Id, E_Task_Subtype); 10645 10646 elsif Ekind (T) = E_Protected_Type then 10647 Mutate_Ekind (Def_Id, E_Protected_Subtype); 10648 Set_Known_To_Have_Preelab_Init 10649 (Def_Id, Known_To_Have_Preelab_Init (T)); 10650 10651 elsif Is_Private_Type (T) then 10652 Mutate_Ekind (Def_Id, Subtype_Kind (Ekind (T))); 10653 Set_Known_To_Have_Preelab_Init 10654 (Def_Id, Known_To_Have_Preelab_Init (T)); 10655 10656 -- Private subtypes may have private dependents 10657 10658 Set_Private_Dependents (Def_Id, New_Elmt_List); 10659 10660 elsif Is_Class_Wide_Type (T) then 10661 Mutate_Ekind (Def_Id, E_Class_Wide_Subtype); 10662 10663 else 10664 -- Incomplete type. Attach subtype to list of dependents, to be 10665 -- completed with full view of parent type, unless is it the 10666 -- designated subtype of a record component within an init_proc. 10667 -- This last case arises for a component of an access type whose 10668 -- designated type is incomplete (e.g. a Taft Amendment type). 10669 -- The designated subtype is within an inner scope, and needs no 10670 -- elaboration, because only the access type is needed in the 10671 -- initialization procedure. 10672 10673 if Ekind (T) = E_Incomplete_Type then 10674 Mutate_Ekind (Def_Id, E_Incomplete_Subtype); 10675 else 10676 Mutate_Ekind (Def_Id, Ekind (T)); 10677 end if; 10678 10679 if For_Access and then Within_Init_Proc then 10680 null; 10681 else 10682 Append_Elmt (Def_Id, Private_Dependents (T)); 10683 end if; 10684 end if; 10685 10686 Set_Etype (Def_Id, T); 10687 Reinit_Size_Align (Def_Id); 10688 Set_Has_Discriminants (Def_Id, Has_Discrs); 10689 Set_Is_Constrained (Def_Id, Constrained); 10690 10691 Set_First_Entity (Def_Id, First_Entity (T)); 10692 Set_Last_Entity (Def_Id, Last_Entity (T)); 10693 Set_Has_Implicit_Dereference 10694 (Def_Id, Has_Implicit_Dereference (T)); 10695 Set_Has_Pragma_Unreferenced_Objects 10696 (Def_Id, Has_Pragma_Unreferenced_Objects (T)); 10697 10698 -- If the subtype is the completion of a private declaration, there may 10699 -- have been representation clauses for the partial view, and they must 10700 -- be preserved. Build_Derived_Type chains the inherited clauses with 10701 -- the ones appearing on the extension. If this comes from a subtype 10702 -- declaration, all clauses are inherited. 10703 10704 if No (First_Rep_Item (Def_Id)) then 10705 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 10706 end if; 10707 10708 if Is_Tagged_Type (T) then 10709 Set_Is_Tagged_Type (Def_Id); 10710 Set_No_Tagged_Streams_Pragma (Def_Id, No_Tagged_Streams_Pragma (T)); 10711 Make_Class_Wide_Type (Def_Id); 10712 end if; 10713 10714 Set_Stored_Constraint (Def_Id, No_Elist); 10715 10716 if Has_Discrs then 10717 Set_Discriminant_Constraint (Def_Id, Elist); 10718 Set_Stored_Constraint_From_Discriminant_Constraint (Def_Id); 10719 end if; 10720 10721 if Is_Tagged_Type (T) then 10722 10723 -- Ada 2005 (AI-251): In case of concurrent types we inherit the 10724 -- concurrent record type (which has the list of primitive 10725 -- operations). 10726 10727 if Ada_Version >= Ada_2005 10728 and then Is_Concurrent_Type (T) 10729 then 10730 Set_Corresponding_Record_Type (Def_Id, 10731 Corresponding_Record_Type (T)); 10732 else 10733 Set_Direct_Primitive_Operations (Def_Id, 10734 Direct_Primitive_Operations (T)); 10735 end if; 10736 10737 Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T)); 10738 end if; 10739 10740 -- Subtypes introduced by component declarations do not need to be 10741 -- marked as delayed, and do not get freeze nodes, because the semantics 10742 -- verifies that the parents of the subtypes are frozen before the 10743 -- enclosing record is frozen. 10744 10745 if not Is_Type (Scope (Def_Id)) then 10746 Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); 10747 10748 if Is_Private_Type (T) 10749 and then Present (Full_View (T)) 10750 then 10751 Conditional_Delay (Def_Id, Full_View (T)); 10752 else 10753 Conditional_Delay (Def_Id, T); 10754 end if; 10755 end if; 10756 10757 if Is_Record_Type (T) then 10758 Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T)); 10759 10760 if Has_Discrs 10761 and then not Is_Empty_Elmt_List (Elist) 10762 and then not For_Access 10763 then 10764 Create_Constrained_Components (Def_Id, Related_Nod, T, Elist); 10765 10766 elsif not Is_Private_Type (T) then 10767 Set_Cloned_Subtype (Def_Id, T); 10768 end if; 10769 end if; 10770 end Build_Discriminated_Subtype; 10771 10772 --------------------------- 10773 -- Build_Itype_Reference -- 10774 --------------------------- 10775 10776 procedure Build_Itype_Reference 10777 (Ityp : Entity_Id; 10778 Nod : Node_Id) 10779 is 10780 IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod)); 10781 begin 10782 10783 -- Itype references are only created for use by the back-end 10784 10785 if Inside_A_Generic then 10786 return; 10787 else 10788 Set_Itype (IR, Ityp); 10789 10790 -- If Nod is a library unit entity, then Insert_After won't work, 10791 -- because Nod is not a member of any list. Therefore, we use 10792 -- Add_Global_Declaration in this case. This can happen if we have a 10793 -- build-in-place library function, child unit or not. 10794 10795 if (Nkind (Nod) in N_Entity and then Is_Compilation_Unit (Nod)) 10796 or else (Nkind (Nod) in 10797 N_Defining_Program_Unit_Name | N_Subprogram_Declaration 10798 and then Is_Compilation_Unit (Defining_Entity (Nod))) 10799 then 10800 Add_Global_Declaration (IR); 10801 else 10802 Insert_After (Nod, IR); 10803 end if; 10804 end if; 10805 end Build_Itype_Reference; 10806 10807 ------------------------ 10808 -- Build_Scalar_Bound -- 10809 ------------------------ 10810 10811 function Build_Scalar_Bound 10812 (Bound : Node_Id; 10813 Par_T : Entity_Id; 10814 Der_T : Entity_Id) return Node_Id 10815 is 10816 New_Bound : Entity_Id; 10817 10818 begin 10819 -- Note: not clear why this is needed, how can the original bound 10820 -- be unanalyzed at this point? and if it is, what business do we 10821 -- have messing around with it? and why is the base type of the 10822 -- parent type the right type for the resolution. It probably is 10823 -- not. It is OK for the new bound we are creating, but not for 10824 -- the old one??? Still if it never happens, no problem. 10825 10826 Analyze_And_Resolve (Bound, Base_Type (Par_T)); 10827 10828 if Nkind (Bound) in N_Integer_Literal | N_Real_Literal then 10829 New_Bound := New_Copy (Bound); 10830 Set_Etype (New_Bound, Der_T); 10831 Set_Analyzed (New_Bound); 10832 10833 elsif Is_Entity_Name (Bound) then 10834 New_Bound := OK_Convert_To (Der_T, New_Copy (Bound)); 10835 10836 -- The following is almost certainly wrong. What business do we have 10837 -- relocating a node (Bound) that is presumably still attached to 10838 -- the tree elsewhere??? 10839 10840 else 10841 New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound)); 10842 end if; 10843 10844 Set_Etype (New_Bound, Der_T); 10845 return New_Bound; 10846 end Build_Scalar_Bound; 10847 10848 ------------------------------- 10849 -- Check_Abstract_Overriding -- 10850 ------------------------------- 10851 10852 procedure Check_Abstract_Overriding (T : Entity_Id) is 10853 Alias_Subp : Entity_Id; 10854 Elmt : Elmt_Id; 10855 Op_List : Elist_Id; 10856 Subp : Entity_Id; 10857 Type_Def : Node_Id; 10858 10859 procedure Check_Pragma_Implemented (Subp : Entity_Id); 10860 -- Ada 2012 (AI05-0030): Subprogram Subp overrides an interface routine 10861 -- which has pragma Implemented already set. Check whether Subp's entity 10862 -- kind conforms to the implementation kind of the overridden routine. 10863 10864 procedure Check_Pragma_Implemented 10865 (Subp : Entity_Id; 10866 Iface_Subp : Entity_Id); 10867 -- Ada 2012 (AI05-0030): Subprogram Subp overrides interface routine 10868 -- Iface_Subp and both entities have pragma Implemented already set on 10869 -- them. Check whether the two implementation kinds are conforming. 10870 10871 procedure Inherit_Pragma_Implemented 10872 (Subp : Entity_Id; 10873 Iface_Subp : Entity_Id); 10874 -- Ada 2012 (AI05-0030): Interface primitive Subp overrides interface 10875 -- subprogram Iface_Subp which has been marked by pragma Implemented. 10876 -- Propagate the implementation kind of Iface_Subp to Subp. 10877 10878 ------------------------------ 10879 -- Check_Pragma_Implemented -- 10880 ------------------------------ 10881 10882 procedure Check_Pragma_Implemented (Subp : Entity_Id) is 10883 Iface_Alias : constant Entity_Id := Interface_Alias (Subp); 10884 Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias); 10885 Subp_Alias : constant Entity_Id := Alias (Subp); 10886 Contr_Typ : Entity_Id; 10887 Impl_Subp : Entity_Id; 10888 10889 begin 10890 -- Subp must have an alias since it is a hidden entity used to link 10891 -- an interface subprogram to its overriding counterpart. 10892 10893 pragma Assert (Present (Subp_Alias)); 10894 10895 -- Handle aliases to synchronized wrappers 10896 10897 Impl_Subp := Subp_Alias; 10898 10899 if Is_Primitive_Wrapper (Impl_Subp) then 10900 Impl_Subp := Wrapped_Entity (Impl_Subp); 10901 end if; 10902 10903 -- Extract the type of the controlling formal 10904 10905 Contr_Typ := Etype (First_Formal (Subp_Alias)); 10906 10907 if Is_Concurrent_Record_Type (Contr_Typ) then 10908 Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ); 10909 end if; 10910 10911 -- An interface subprogram whose implementation kind is By_Entry must 10912 -- be implemented by an entry. 10913 10914 if Impl_Kind = Name_By_Entry 10915 and then Ekind (Impl_Subp) /= E_Entry 10916 then 10917 Error_Msg_Node_2 := Iface_Alias; 10918 Error_Msg_NE 10919 ("type & must implement abstract subprogram & with an entry", 10920 Subp_Alias, Contr_Typ); 10921 10922 elsif Impl_Kind = Name_By_Protected_Procedure then 10923 10924 -- An interface subprogram whose implementation kind is By_ 10925 -- Protected_Procedure cannot be implemented by a primitive 10926 -- procedure of a task type. 10927 10928 if Ekind (Contr_Typ) /= E_Protected_Type then 10929 Error_Msg_Node_2 := Contr_Typ; 10930 Error_Msg_NE 10931 ("interface subprogram & cannot be implemented by a " 10932 & "primitive procedure of task type &", 10933 Subp_Alias, Iface_Alias); 10934 10935 -- An interface subprogram whose implementation kind is By_ 10936 -- Protected_Procedure must be implemented by a procedure. 10937 10938 elsif Ekind (Impl_Subp) /= E_Procedure then 10939 Error_Msg_Node_2 := Iface_Alias; 10940 Error_Msg_NE 10941 ("type & must implement abstract subprogram & with a " 10942 & "procedure", Subp_Alias, Contr_Typ); 10943 10944 elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented)) 10945 and then Implementation_Kind (Impl_Subp) /= Impl_Kind 10946 then 10947 Error_Msg_Name_1 := Impl_Kind; 10948 Error_Msg_N 10949 ("overriding operation& must have synchronization%", 10950 Subp_Alias); 10951 end if; 10952 10953 -- If primitive has Optional synchronization, overriding operation 10954 -- must match if it has an explicit synchronization. 10955 10956 elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented)) 10957 and then Implementation_Kind (Impl_Subp) /= Impl_Kind 10958 then 10959 Error_Msg_Name_1 := Impl_Kind; 10960 Error_Msg_N 10961 ("overriding operation& must have synchronization%", Subp_Alias); 10962 end if; 10963 end Check_Pragma_Implemented; 10964 10965 ------------------------------ 10966 -- Check_Pragma_Implemented -- 10967 ------------------------------ 10968 10969 procedure Check_Pragma_Implemented 10970 (Subp : Entity_Id; 10971 Iface_Subp : Entity_Id) 10972 is 10973 Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); 10974 Subp_Kind : constant Name_Id := Implementation_Kind (Subp); 10975 10976 begin 10977 -- Ada 2012 (AI05-0030): The implementation kinds of an overridden 10978 -- and overriding subprogram are different. In general this is an 10979 -- error except when the implementation kind of the overridden 10980 -- subprograms is By_Any or Optional. 10981 10982 if Iface_Kind /= Subp_Kind 10983 and then Iface_Kind /= Name_By_Any 10984 and then Iface_Kind /= Name_Optional 10985 then 10986 if Iface_Kind = Name_By_Entry then 10987 Error_Msg_N 10988 ("incompatible implementation kind, overridden subprogram " & 10989 "is marked By_Entry", Subp); 10990 else 10991 Error_Msg_N 10992 ("incompatible implementation kind, overridden subprogram " & 10993 "is marked By_Protected_Procedure", Subp); 10994 end if; 10995 end if; 10996 end Check_Pragma_Implemented; 10997 10998 -------------------------------- 10999 -- Inherit_Pragma_Implemented -- 11000 -------------------------------- 11001 11002 procedure Inherit_Pragma_Implemented 11003 (Subp : Entity_Id; 11004 Iface_Subp : Entity_Id) 11005 is 11006 Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); 11007 Loc : constant Source_Ptr := Sloc (Subp); 11008 Impl_Prag : Node_Id; 11009 11010 begin 11011 -- Since the implementation kind is stored as a representation item 11012 -- rather than a flag, create a pragma node. 11013 11014 Impl_Prag := 11015 Make_Pragma (Loc, 11016 Chars => Name_Implemented, 11017 Pragma_Argument_Associations => New_List ( 11018 Make_Pragma_Argument_Association (Loc, 11019 Expression => New_Occurrence_Of (Subp, Loc)), 11020 11021 Make_Pragma_Argument_Association (Loc, 11022 Expression => Make_Identifier (Loc, Iface_Kind)))); 11023 11024 -- The pragma doesn't need to be analyzed because it is internally 11025 -- built. It is safe to directly register it as a rep item since we 11026 -- are only interested in the characters of the implementation kind. 11027 11028 Record_Rep_Item (Subp, Impl_Prag); 11029 end Inherit_Pragma_Implemented; 11030 11031 -- Start of processing for Check_Abstract_Overriding 11032 11033 begin 11034 Op_List := Primitive_Operations (T); 11035 11036 -- Loop to check primitive operations 11037 11038 Elmt := First_Elmt (Op_List); 11039 while Present (Elmt) loop 11040 Subp := Node (Elmt); 11041 Alias_Subp := Alias (Subp); 11042 11043 -- Inherited subprograms are identified by the fact that they do not 11044 -- come from source, and the associated source location is the 11045 -- location of the first subtype of the derived type. 11046 11047 -- Ada 2005 (AI-228): Apply the rules of RM-3.9.3(6/2) for 11048 -- subprograms that "require overriding". 11049 11050 -- Special exception, do not complain about failure to override the 11051 -- stream routines _Input and _Output, as well as the primitive 11052 -- operations used in dispatching selects since we always provide 11053 -- automatic overridings for these subprograms. 11054 11055 -- The partial view of T may have been a private extension, for 11056 -- which inherited functions dispatching on result are abstract. 11057 -- If the full view is a null extension, there is no need for 11058 -- overriding in Ada 2005, but wrappers need to be built for them 11059 -- (see exp_ch3, Build_Controlling_Function_Wrappers). 11060 11061 if Is_Null_Extension (T) 11062 and then Has_Controlling_Result (Subp) 11063 and then Ada_Version >= Ada_2005 11064 and then Present (Alias_Subp) 11065 and then not Comes_From_Source (Subp) 11066 and then not Is_Abstract_Subprogram (Alias_Subp) 11067 and then not Is_Access_Type (Etype (Subp)) 11068 then 11069 null; 11070 11071 -- Ada 2005 (AI-251): Internal entities of interfaces need no 11072 -- processing because this check is done with the aliased 11073 -- entity 11074 11075 elsif Present (Interface_Alias (Subp)) then 11076 null; 11077 11078 -- AI12-0042: Test for rule in 7.3.2(6.1/4), that requires overriding 11079 -- of a visible private primitive inherited from an ancestor with 11080 -- the aspect Type_Invariant'Class, unless the inherited primitive 11081 -- is abstract. 11082 11083 elsif not Is_Abstract_Subprogram (Subp) 11084 and then not Comes_From_Source (Subp) -- An inherited subprogram 11085 and then Requires_Overriding (Subp) 11086 and then Present (Alias_Subp) 11087 and then Has_Invariants (Etype (T)) 11088 and then Present (Get_Pragma (Etype (T), Pragma_Invariant)) 11089 and then Class_Present (Get_Pragma (Etype (T), Pragma_Invariant)) 11090 and then Is_Private_Primitive (Alias_Subp) 11091 then 11092 Error_Msg_NE 11093 ("inherited private primitive & must be overridden", T, Subp); 11094 Error_Msg_N 11095 ("\because ancestor type has 'Type_'Invariant''Class " & 11096 "(RM 7.3.2(6.1))", T); 11097 11098 elsif (Is_Abstract_Subprogram (Subp) 11099 or else Requires_Overriding (Subp) 11100 or else 11101 (Has_Controlling_Result (Subp) 11102 and then Present (Alias_Subp) 11103 and then not Comes_From_Source (Subp) 11104 and then Sloc (Subp) = Sloc (First_Subtype (T)))) 11105 and then not Is_TSS (Subp, TSS_Stream_Input) 11106 and then not Is_TSS (Subp, TSS_Stream_Output) 11107 and then not Is_Abstract_Type (T) 11108 and then not Is_Predefined_Interface_Primitive (Subp) 11109 11110 -- Ada 2005 (AI-251): Do not consider hidden entities associated 11111 -- with abstract interface types because the check will be done 11112 -- with the aliased entity (otherwise we generate a duplicated 11113 -- error message). 11114 11115 and then not Present (Interface_Alias (Subp)) 11116 then 11117 if Present (Alias_Subp) then 11118 11119 -- Only perform the check for a derived subprogram when the 11120 -- type has an explicit record extension. This avoids incorrect 11121 -- flagging of abstract subprograms for the case of a type 11122 -- without an extension that is derived from a formal type 11123 -- with a tagged actual (can occur within a private part). 11124 11125 -- Ada 2005 (AI-391): In the case of an inherited function with 11126 -- a controlling result of the type, the rule does not apply if 11127 -- the type is a null extension (unless the parent function 11128 -- itself is abstract, in which case the function must still be 11129 -- be overridden). The expander will generate an overriding 11130 -- wrapper function calling the parent subprogram (see 11131 -- Exp_Ch3.Make_Controlling_Wrapper_Functions). 11132 11133 Type_Def := Type_Definition (Parent (T)); 11134 11135 if Nkind (Type_Def) = N_Derived_Type_Definition 11136 and then Present (Record_Extension_Part (Type_Def)) 11137 and then 11138 (Ada_Version < Ada_2005 11139 or else not Is_Null_Extension (T) 11140 or else Ekind (Subp) = E_Procedure 11141 or else not Has_Controlling_Result (Subp) 11142 or else Is_Abstract_Subprogram (Alias_Subp) 11143 or else Requires_Overriding (Subp) 11144 or else Is_Access_Type (Etype (Subp))) 11145 then 11146 -- Avoid reporting error in case of abstract predefined 11147 -- primitive inherited from interface type because the 11148 -- body of internally generated predefined primitives 11149 -- of tagged types are generated later by Freeze_Type 11150 11151 if Is_Interface (Root_Type (T)) 11152 and then Is_Abstract_Subprogram (Subp) 11153 and then Is_Predefined_Dispatching_Operation (Subp) 11154 and then not Comes_From_Source (Ultimate_Alias (Subp)) 11155 then 11156 null; 11157 11158 -- A null extension is not obliged to override an inherited 11159 -- procedure subject to pragma Extensions_Visible with value 11160 -- False and at least one controlling OUT parameter 11161 -- (SPARK RM 6.1.7(6)). 11162 11163 elsif Is_Null_Extension (T) 11164 and then Is_EVF_Procedure (Subp) 11165 then 11166 null; 11167 11168 -- Subprogram renamings cannot be overridden 11169 11170 elsif Comes_From_Source (Subp) 11171 and then Present (Alias (Subp)) 11172 then 11173 null; 11174 11175 -- Skip reporting the error on Ada 2022 only subprograms 11176 -- that require overriding if we are not in Ada 2022 mode. 11177 11178 elsif Ada_Version < Ada_2022 11179 and then Requires_Overriding (Subp) 11180 and then Is_Ada_2022_Only (Ultimate_Alias (Subp)) 11181 then 11182 null; 11183 11184 else 11185 Error_Msg_NE 11186 ("type must be declared abstract or & overridden", 11187 T, Subp); 11188 11189 -- Traverse the whole chain of aliased subprograms to 11190 -- complete the error notification. This is especially 11191 -- useful for traceability of the chain of entities when 11192 -- the subprogram corresponds with an interface 11193 -- subprogram (which may be defined in another package). 11194 11195 if Present (Alias_Subp) then 11196 declare 11197 E : Entity_Id; 11198 11199 begin 11200 E := Subp; 11201 while Present (Alias (E)) loop 11202 11203 -- Avoid reporting redundant errors on entities 11204 -- inherited from interfaces 11205 11206 if Sloc (E) /= Sloc (T) then 11207 Error_Msg_Sloc := Sloc (E); 11208 Error_Msg_NE 11209 ("\& has been inherited #", T, Subp); 11210 end if; 11211 11212 E := Alias (E); 11213 end loop; 11214 11215 Error_Msg_Sloc := Sloc (E); 11216 11217 -- AI05-0068: report if there is an overriding 11218 -- non-abstract subprogram that is invisible. 11219 11220 if Is_Hidden (E) 11221 and then not Is_Abstract_Subprogram (E) 11222 then 11223 Error_Msg_NE 11224 ("\& subprogram# is not visible", 11225 T, Subp); 11226 11227 -- Clarify the case where a non-null extension must 11228 -- override inherited procedure subject to pragma 11229 -- Extensions_Visible with value False and at least 11230 -- one controlling OUT param. 11231 11232 elsif Is_EVF_Procedure (E) then 11233 Error_Msg_NE 11234 ("\& # is subject to Extensions_Visible False", 11235 T, Subp); 11236 11237 else 11238 Error_Msg_NE 11239 ("\& has been inherited from subprogram #", 11240 T, Subp); 11241 end if; 11242 end; 11243 end if; 11244 end if; 11245 11246 -- Ada 2005 (AI-345): Protected or task type implementing 11247 -- abstract interfaces. 11248 11249 elsif Is_Concurrent_Record_Type (T) 11250 and then Present (Interfaces (T)) 11251 then 11252 -- There is no need to check here RM 9.4(11.9/3) since we 11253 -- are processing the corresponding record type and the 11254 -- mode of the overriding subprograms was verified by 11255 -- Check_Conformance when the corresponding concurrent 11256 -- type declaration was analyzed. 11257 11258 Error_Msg_NE 11259 ("interface subprogram & must be overridden", T, Subp); 11260 11261 -- Examine primitive operations of synchronized type to find 11262 -- homonyms that have the wrong profile. 11263 11264 declare 11265 Prim : Entity_Id; 11266 11267 begin 11268 Prim := First_Entity (Corresponding_Concurrent_Type (T)); 11269 while Present (Prim) loop 11270 if Chars (Prim) = Chars (Subp) then 11271 Error_Msg_NE 11272 ("profile is not type conformant with prefixed " 11273 & "view profile of inherited operation&", 11274 Prim, Subp); 11275 end if; 11276 11277 Next_Entity (Prim); 11278 end loop; 11279 end; 11280 end if; 11281 11282 else 11283 Error_Msg_Node_2 := T; 11284 Error_Msg_N 11285 ("abstract subprogram& not allowed for type&", Subp); 11286 11287 -- Also post unconditional warning on the type (unconditional 11288 -- so that if there are more than one of these cases, we get 11289 -- them all, and not just the first one). 11290 11291 Error_Msg_Node_2 := Subp; 11292 Error_Msg_N ("nonabstract type& has abstract subprogram&!", T); 11293 end if; 11294 11295 -- A subprogram subject to pragma Extensions_Visible with value 11296 -- "True" cannot override a subprogram subject to the same pragma 11297 -- with value "False" (SPARK RM 6.1.7(5)). 11298 11299 elsif Extensions_Visible_Status (Subp) = Extensions_Visible_True 11300 and then Present (Overridden_Operation (Subp)) 11301 and then Extensions_Visible_Status (Overridden_Operation (Subp)) = 11302 Extensions_Visible_False 11303 then 11304 Error_Msg_Sloc := Sloc (Overridden_Operation (Subp)); 11305 Error_Msg_N 11306 ("subprogram & with Extensions_Visible True cannot override " 11307 & "subprogram # with Extensions_Visible False", Subp); 11308 end if; 11309 11310 -- Ada 2012 (AI05-0030): Perform checks related to pragma Implemented 11311 11312 -- Subp is an expander-generated procedure which maps an interface 11313 -- alias to a protected wrapper. The interface alias is flagged by 11314 -- pragma Implemented. Ensure that Subp is a procedure when the 11315 -- implementation kind is By_Protected_Procedure or an entry when 11316 -- By_Entry. 11317 11318 if Ada_Version >= Ada_2012 11319 and then Is_Hidden (Subp) 11320 and then Present (Interface_Alias (Subp)) 11321 and then Has_Rep_Pragma (Interface_Alias (Subp), Name_Implemented) 11322 then 11323 Check_Pragma_Implemented (Subp); 11324 end if; 11325 11326 -- Subp is an interface primitive which overrides another interface 11327 -- primitive marked with pragma Implemented. 11328 11329 if Ada_Version >= Ada_2012 11330 and then Present (Overridden_Operation (Subp)) 11331 and then Has_Rep_Pragma 11332 (Overridden_Operation (Subp), Name_Implemented) 11333 then 11334 -- If the overriding routine is also marked by Implemented, check 11335 -- that the two implementation kinds are conforming. 11336 11337 if Has_Rep_Pragma (Subp, Name_Implemented) then 11338 Check_Pragma_Implemented 11339 (Subp => Subp, 11340 Iface_Subp => Overridden_Operation (Subp)); 11341 11342 -- Otherwise the overriding routine inherits the implementation 11343 -- kind from the overridden subprogram. 11344 11345 else 11346 Inherit_Pragma_Implemented 11347 (Subp => Subp, 11348 Iface_Subp => Overridden_Operation (Subp)); 11349 end if; 11350 end if; 11351 11352 -- Ada 2005 (AI95-0414) and Ada 2022 (AI12-0269): Diagnose failure to 11353 -- match No_Return in parent, but do it unconditionally in Ada 95 too 11354 -- for procedures, since this is our pragma. 11355 11356 if Present (Overridden_Operation (Subp)) 11357 and then No_Return (Overridden_Operation (Subp)) 11358 then 11359 11360 -- If the subprogram is a renaming, check that the renamed 11361 -- subprogram is No_Return. 11362 11363 if Present (Renamed_Or_Alias (Subp)) then 11364 if not No_Return (Renamed_Or_Alias (Subp)) then 11365 Error_Msg_NE ("subprogram & must be No_Return", 11366 Subp, 11367 Renamed_Or_Alias (Subp)); 11368 Error_Msg_N ("\since renaming & overrides No_Return " 11369 & "subprogram (RM 6.5.1(6/2))", 11370 Subp); 11371 end if; 11372 11373 -- Make sure that the subprogram itself is No_Return. 11374 11375 elsif not No_Return (Subp) then 11376 Error_Msg_N ("overriding subprogram & must be No_Return", Subp); 11377 Error_Msg_N 11378 ("\since overridden subprogram is No_Return (RM 6.5.1(6/2))", 11379 Subp); 11380 end if; 11381 end if; 11382 11383 -- If the operation is a wrapper for a synchronized primitive, it 11384 -- may be called indirectly through a dispatching select. We assume 11385 -- that it will be referenced elsewhere indirectly, and suppress 11386 -- warnings about an unused entity. 11387 11388 if Is_Primitive_Wrapper (Subp) 11389 and then Present (Wrapped_Entity (Subp)) 11390 then 11391 Set_Referenced (Wrapped_Entity (Subp)); 11392 end if; 11393 11394 Next_Elmt (Elmt); 11395 end loop; 11396 end Check_Abstract_Overriding; 11397 11398 ------------------------------------------------ 11399 -- Check_Access_Discriminant_Requires_Limited -- 11400 ------------------------------------------------ 11401 11402 procedure Check_Access_Discriminant_Requires_Limited 11403 (D : Node_Id; 11404 Loc : Node_Id) 11405 is 11406 begin 11407 -- A discriminant_specification for an access discriminant shall appear 11408 -- only in the declaration for a task or protected type, or for a type 11409 -- with the reserved word 'limited' in its definition or in one of its 11410 -- ancestors (RM 3.7(10)). 11411 11412 -- AI-0063: The proper condition is that type must be immutably limited, 11413 -- or else be a partial view. 11414 11415 if Nkind (Discriminant_Type (D)) = N_Access_Definition then 11416 if Is_Limited_View (Current_Scope) 11417 or else 11418 (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration 11419 and then Limited_Present (Parent (Current_Scope))) 11420 then 11421 null; 11422 11423 else 11424 Error_Msg_N 11425 ("access discriminants allowed only for limited types", Loc); 11426 end if; 11427 end if; 11428 end Check_Access_Discriminant_Requires_Limited; 11429 11430 ----------------------------------- 11431 -- Check_Aliased_Component_Types -- 11432 ----------------------------------- 11433 11434 procedure Check_Aliased_Component_Types (T : Entity_Id) is 11435 C : Entity_Id; 11436 11437 begin 11438 -- ??? Also need to check components of record extensions, but not 11439 -- components of protected types (which are always limited). 11440 11441 -- Ada 2005: AI-363 relaxes this rule, to allow heap objects of such 11442 -- types to be unconstrained. This is safe because it is illegal to 11443 -- create access subtypes to such types with explicit discriminant 11444 -- constraints. 11445 11446 if not Is_Limited_Type (T) then 11447 if Ekind (T) = E_Record_Type then 11448 C := First_Component (T); 11449 while Present (C) loop 11450 if Is_Aliased (C) 11451 and then Has_Discriminants (Etype (C)) 11452 and then not Is_Constrained (Etype (C)) 11453 and then not In_Instance_Body 11454 and then Ada_Version < Ada_2005 11455 then 11456 Error_Msg_N 11457 ("aliased component must be constrained (RM 3.6(11))", 11458 C); 11459 end if; 11460 11461 Next_Component (C); 11462 end loop; 11463 11464 elsif Ekind (T) = E_Array_Type then 11465 if Has_Aliased_Components (T) 11466 and then Has_Discriminants (Component_Type (T)) 11467 and then not Is_Constrained (Component_Type (T)) 11468 and then not In_Instance_Body 11469 and then Ada_Version < Ada_2005 11470 then 11471 Error_Msg_N 11472 ("aliased component type must be constrained (RM 3.6(11))", 11473 T); 11474 end if; 11475 end if; 11476 end if; 11477 end Check_Aliased_Component_Types; 11478 11479 -------------------------------------- 11480 -- Check_Anonymous_Access_Component -- 11481 -------------------------------------- 11482 11483 procedure Check_Anonymous_Access_Component 11484 (Typ_Decl : Node_Id; 11485 Typ : Entity_Id; 11486 Prev : Entity_Id; 11487 Comp_Def : Node_Id; 11488 Access_Def : Node_Id) 11489 is 11490 Loc : constant Source_Ptr := Sloc (Comp_Def); 11491 Anon_Access : Entity_Id; 11492 Acc_Def : Node_Id; 11493 Decl : Node_Id; 11494 Type_Def : Node_Id; 11495 11496 procedure Build_Incomplete_Type_Declaration; 11497 -- If the record type contains components that include an access to the 11498 -- current record, then create an incomplete type declaration for the 11499 -- record, to be used as the designated type of the anonymous access. 11500 -- This is done only once, and only if there is no previous partial 11501 -- view of the type. 11502 11503 function Designates_T (Subt : Node_Id) return Boolean; 11504 -- Check whether a node designates the enclosing record type, or 'Class 11505 -- of that type 11506 11507 function Mentions_T (Acc_Def : Node_Id) return Boolean; 11508 -- Check whether an access definition includes a reference to 11509 -- the enclosing record type. The reference can be a subtype mark 11510 -- in the access definition itself, a 'Class attribute reference, or 11511 -- recursively a reference appearing in a parameter specification 11512 -- or result definition of an access_to_subprogram definition. 11513 11514 -------------------------------------- 11515 -- Build_Incomplete_Type_Declaration -- 11516 -------------------------------------- 11517 11518 procedure Build_Incomplete_Type_Declaration is 11519 Decl : Node_Id; 11520 Inc_T : Entity_Id; 11521 H : Entity_Id; 11522 11523 -- Is_Tagged indicates whether the type is tagged. It is tagged if 11524 -- it's "is new ... with record" or else "is tagged record ...". 11525 11526 Typ_Def : constant Node_Id := 11527 (if Nkind (Typ_Decl) = N_Full_Type_Declaration 11528 then Type_Definition (Typ_Decl) else Empty); 11529 Is_Tagged : constant Boolean := 11530 Present (Typ_Def) 11531 and then 11532 ((Nkind (Typ_Def) = N_Derived_Type_Definition 11533 and then 11534 Present (Record_Extension_Part (Typ_Def))) 11535 or else 11536 (Nkind (Typ_Def) = N_Record_Definition 11537 and then Tagged_Present (Typ_Def))); 11538 11539 begin 11540 -- If there is a previous partial view, no need to create a new one 11541 -- If the partial view, given by Prev, is incomplete, If Prev is 11542 -- a private declaration, full declaration is flagged accordingly. 11543 11544 if Prev /= Typ then 11545 if Is_Tagged then 11546 Make_Class_Wide_Type (Prev); 11547 Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); 11548 Set_Etype (Class_Wide_Type (Typ), Typ); 11549 end if; 11550 11551 return; 11552 11553 elsif Has_Private_Declaration (Typ) then 11554 11555 -- If we refer to T'Class inside T, and T is the completion of a 11556 -- private type, then make sure the class-wide type exists. 11557 11558 if Is_Tagged then 11559 Make_Class_Wide_Type (Typ); 11560 end if; 11561 11562 return; 11563 11564 -- If there was a previous anonymous access type, the incomplete 11565 -- type declaration will have been created already. 11566 11567 elsif Present (Current_Entity (Typ)) 11568 and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type 11569 and then Full_View (Current_Entity (Typ)) = Typ 11570 then 11571 if Is_Tagged 11572 and then Comes_From_Source (Current_Entity (Typ)) 11573 and then not Is_Tagged_Type (Current_Entity (Typ)) 11574 then 11575 Make_Class_Wide_Type (Typ); 11576 Error_Msg_N 11577 ("incomplete view of tagged type should be declared tagged??", 11578 Parent (Current_Entity (Typ))); 11579 end if; 11580 return; 11581 11582 else 11583 Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); 11584 Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); 11585 11586 -- Type has already been inserted into the current scope. Remove 11587 -- it, and add incomplete declaration for type, so that subsequent 11588 -- anonymous access types can use it. The entity is unchained from 11589 -- the homonym list and from immediate visibility. After analysis, 11590 -- the entity in the incomplete declaration becomes immediately 11591 -- visible in the record declaration that follows. 11592 11593 H := Current_Entity (Typ); 11594 11595 if H = Typ then 11596 Set_Name_Entity_Id (Chars (Typ), Homonym (Typ)); 11597 else 11598 while Present (H) 11599 and then Homonym (H) /= Typ 11600 loop 11601 H := Homonym (Typ); 11602 end loop; 11603 11604 Set_Homonym (H, Homonym (Typ)); 11605 end if; 11606 11607 Insert_Before (Typ_Decl, Decl); 11608 Analyze (Decl); 11609 Set_Full_View (Inc_T, Typ); 11610 11611 if Is_Tagged then 11612 11613 -- Create a common class-wide type for both views, and set the 11614 -- Etype of the class-wide type to the full view. 11615 11616 Make_Class_Wide_Type (Inc_T); 11617 Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); 11618 Set_Etype (Class_Wide_Type (Typ), Typ); 11619 end if; 11620 end if; 11621 end Build_Incomplete_Type_Declaration; 11622 11623 ------------------ 11624 -- Designates_T -- 11625 ------------------ 11626 11627 function Designates_T (Subt : Node_Id) return Boolean is 11628 Type_Id : constant Name_Id := Chars (Typ); 11629 11630 function Names_T (Nam : Node_Id) return Boolean; 11631 -- The record type has not been introduced in the current scope 11632 -- yet, so we must examine the name of the type itself, either 11633 -- an identifier T, or an expanded name of the form P.T, where 11634 -- P denotes the current scope. 11635 11636 ------------- 11637 -- Names_T -- 11638 ------------- 11639 11640 function Names_T (Nam : Node_Id) return Boolean is 11641 begin 11642 if Nkind (Nam) = N_Identifier then 11643 return Chars (Nam) = Type_Id; 11644 11645 elsif Nkind (Nam) = N_Selected_Component then 11646 if Chars (Selector_Name (Nam)) = Type_Id then 11647 if Nkind (Prefix (Nam)) = N_Identifier then 11648 return Chars (Prefix (Nam)) = Chars (Current_Scope); 11649 11650 elsif Nkind (Prefix (Nam)) = N_Selected_Component then 11651 return Chars (Selector_Name (Prefix (Nam))) = 11652 Chars (Current_Scope); 11653 else 11654 return False; 11655 end if; 11656 11657 else 11658 return False; 11659 end if; 11660 11661 else 11662 return False; 11663 end if; 11664 end Names_T; 11665 11666 -- Start of processing for Designates_T 11667 11668 begin 11669 if Nkind (Subt) = N_Identifier then 11670 return Chars (Subt) = Type_Id; 11671 11672 -- Reference can be through an expanded name which has not been 11673 -- analyzed yet, and which designates enclosing scopes. 11674 11675 elsif Nkind (Subt) = N_Selected_Component then 11676 if Names_T (Subt) then 11677 return True; 11678 11679 -- Otherwise it must denote an entity that is already visible. 11680 -- The access definition may name a subtype of the enclosing 11681 -- type, if there is a previous incomplete declaration for it. 11682 11683 else 11684 Find_Selected_Component (Subt); 11685 return 11686 Is_Entity_Name (Subt) 11687 and then Scope (Entity (Subt)) = Current_Scope 11688 and then 11689 (Chars (Base_Type (Entity (Subt))) = Type_Id 11690 or else 11691 (Is_Class_Wide_Type (Entity (Subt)) 11692 and then 11693 Chars (Etype (Base_Type (Entity (Subt)))) = 11694 Type_Id)); 11695 end if; 11696 11697 -- A reference to the current type may appear as the prefix of 11698 -- a 'Class attribute. 11699 11700 elsif Nkind (Subt) = N_Attribute_Reference 11701 and then Attribute_Name (Subt) = Name_Class 11702 then 11703 return Names_T (Prefix (Subt)); 11704 11705 else 11706 return False; 11707 end if; 11708 end Designates_T; 11709 11710 ---------------- 11711 -- Mentions_T -- 11712 ---------------- 11713 11714 function Mentions_T (Acc_Def : Node_Id) return Boolean is 11715 Param_Spec : Node_Id; 11716 11717 Acc_Subprg : constant Node_Id := 11718 Access_To_Subprogram_Definition (Acc_Def); 11719 11720 begin 11721 if No (Acc_Subprg) then 11722 return Designates_T (Subtype_Mark (Acc_Def)); 11723 end if; 11724 11725 -- Component is an access_to_subprogram: examine its formals, 11726 -- and result definition in the case of an access_to_function. 11727 11728 Param_Spec := First (Parameter_Specifications (Acc_Subprg)); 11729 while Present (Param_Spec) loop 11730 if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition 11731 and then Mentions_T (Parameter_Type (Param_Spec)) 11732 then 11733 return True; 11734 11735 elsif Designates_T (Parameter_Type (Param_Spec)) then 11736 return True; 11737 end if; 11738 11739 Next (Param_Spec); 11740 end loop; 11741 11742 if Nkind (Acc_Subprg) = N_Access_Function_Definition then 11743 if Nkind (Result_Definition (Acc_Subprg)) = 11744 N_Access_Definition 11745 then 11746 return Mentions_T (Result_Definition (Acc_Subprg)); 11747 else 11748 return Designates_T (Result_Definition (Acc_Subprg)); 11749 end if; 11750 end if; 11751 11752 return False; 11753 end Mentions_T; 11754 11755 -- Start of processing for Check_Anonymous_Access_Component 11756 11757 begin 11758 if Present (Access_Def) and then Mentions_T (Access_Def) then 11759 Acc_Def := Access_To_Subprogram_Definition (Access_Def); 11760 11761 Build_Incomplete_Type_Declaration; 11762 Anon_Access := Make_Temporary (Loc, 'S'); 11763 11764 -- Create a declaration for the anonymous access type: either 11765 -- an access_to_object or an access_to_subprogram. 11766 11767 if Present (Acc_Def) then 11768 if Nkind (Acc_Def) = N_Access_Function_Definition then 11769 Type_Def := 11770 Make_Access_Function_Definition (Loc, 11771 Parameter_Specifications => 11772 Parameter_Specifications (Acc_Def), 11773 Result_Definition => Result_Definition (Acc_Def)); 11774 else 11775 Type_Def := 11776 Make_Access_Procedure_Definition (Loc, 11777 Parameter_Specifications => 11778 Parameter_Specifications (Acc_Def)); 11779 end if; 11780 11781 else 11782 Type_Def := 11783 Make_Access_To_Object_Definition (Loc, 11784 Subtype_Indication => 11785 Relocate_Node (Subtype_Mark (Access_Def))); 11786 11787 Set_Constant_Present (Type_Def, Constant_Present (Access_Def)); 11788 Set_All_Present (Type_Def, All_Present (Access_Def)); 11789 end if; 11790 11791 Set_Null_Exclusion_Present 11792 (Type_Def, Null_Exclusion_Present (Access_Def)); 11793 11794 Decl := 11795 Make_Full_Type_Declaration (Loc, 11796 Defining_Identifier => Anon_Access, 11797 Type_Definition => Type_Def); 11798 11799 Insert_Before (Typ_Decl, Decl); 11800 Analyze (Decl); 11801 11802 -- If an access to subprogram, create the extra formals 11803 11804 if Present (Acc_Def) then 11805 Create_Extra_Formals (Designated_Type (Anon_Access)); 11806 end if; 11807 11808 if Nkind (Comp_Def) = N_Component_Definition then 11809 Rewrite (Comp_Def, 11810 Make_Component_Definition (Loc, 11811 Subtype_Indication => New_Occurrence_Of (Anon_Access, Loc))); 11812 else 11813 pragma Assert (Nkind (Comp_Def) = N_Discriminant_Specification); 11814 Rewrite (Comp_Def, 11815 Make_Discriminant_Specification (Loc, 11816 Defining_Identifier => Defining_Identifier (Comp_Def), 11817 Discriminant_Type => New_Occurrence_Of (Anon_Access, Loc))); 11818 end if; 11819 11820 if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then 11821 Mutate_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); 11822 else 11823 Mutate_Ekind (Anon_Access, E_Anonymous_Access_Type); 11824 end if; 11825 11826 Set_Is_Local_Anonymous_Access (Anon_Access); 11827 end if; 11828 end Check_Anonymous_Access_Component; 11829 11830 --------------------------------------- 11831 -- Check_Anonymous_Access_Components -- 11832 --------------------------------------- 11833 11834 procedure Check_Anonymous_Access_Components 11835 (Typ_Decl : Node_Id; 11836 Typ : Entity_Id; 11837 Prev : Entity_Id; 11838 Comp_List : Node_Id) 11839 is 11840 Comp : Node_Id; 11841 begin 11842 if No (Comp_List) then 11843 return; 11844 end if; 11845 11846 Comp := First (Component_Items (Comp_List)); 11847 while Present (Comp) loop 11848 if Nkind (Comp) = N_Component_Declaration then 11849 Check_Anonymous_Access_Component 11850 (Typ_Decl, Typ, Prev, 11851 Component_Definition (Comp), 11852 Access_Definition (Component_Definition (Comp))); 11853 end if; 11854 11855 Next (Comp); 11856 end loop; 11857 11858 if Present (Variant_Part (Comp_List)) then 11859 declare 11860 V : Node_Id; 11861 begin 11862 V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 11863 while Present (V) loop 11864 Check_Anonymous_Access_Components 11865 (Typ_Decl, Typ, Prev, Component_List (V)); 11866 Next_Non_Pragma (V); 11867 end loop; 11868 end; 11869 end if; 11870 end Check_Anonymous_Access_Components; 11871 11872 ---------------------- 11873 -- Check_Completion -- 11874 ---------------------- 11875 11876 procedure Check_Completion (Body_Id : Node_Id := Empty) is 11877 E : Entity_Id; 11878 11879 procedure Post_Error; 11880 -- Post error message for lack of completion for entity E 11881 11882 ---------------- 11883 -- Post_Error -- 11884 ---------------- 11885 11886 procedure Post_Error is 11887 procedure Missing_Body; 11888 -- Output missing body message 11889 11890 ------------------ 11891 -- Missing_Body -- 11892 ------------------ 11893 11894 procedure Missing_Body is 11895 begin 11896 -- Spec is in same unit, so we can post on spec 11897 11898 if In_Same_Source_Unit (Body_Id, E) then 11899 Error_Msg_N ("missing body for &", E); 11900 11901 -- Spec is in a separate unit, so we have to post on the body 11902 11903 else 11904 Error_Msg_NE ("missing body for & declared#!", Body_Id, E); 11905 end if; 11906 end Missing_Body; 11907 11908 -- Start of processing for Post_Error 11909 11910 begin 11911 if not Comes_From_Source (E) then 11912 if Ekind (E) in E_Task_Type | E_Protected_Type then 11913 11914 -- It may be an anonymous protected type created for a 11915 -- single variable. Post error on variable, if present. 11916 11917 declare 11918 Var : Entity_Id; 11919 11920 begin 11921 Var := First_Entity (Current_Scope); 11922 while Present (Var) loop 11923 exit when Etype (Var) = E 11924 and then Comes_From_Source (Var); 11925 11926 Next_Entity (Var); 11927 end loop; 11928 11929 if Present (Var) then 11930 E := Var; 11931 end if; 11932 end; 11933 end if; 11934 end if; 11935 11936 -- If a generated entity has no completion, then either previous 11937 -- semantic errors have disabled the expansion phase, or else we had 11938 -- missing subunits, or else we are compiling without expansion, 11939 -- or else something is very wrong. 11940 11941 if not Comes_From_Source (E) then 11942 pragma Assert 11943 (Serious_Errors_Detected > 0 11944 or else Configurable_Run_Time_Violations > 0 11945 or else Subunits_Missing 11946 or else not Expander_Active); 11947 return; 11948 11949 -- Here for source entity 11950 11951 else 11952 -- Here if no body to post the error message, so we post the error 11953 -- on the declaration that has no completion. This is not really 11954 -- the right place to post it, think about this later ??? 11955 11956 if No (Body_Id) then 11957 if Is_Type (E) then 11958 Error_Msg_NE 11959 ("missing full declaration for }", Parent (E), E); 11960 else 11961 Error_Msg_NE ("missing body for &", Parent (E), E); 11962 end if; 11963 11964 -- Package body has no completion for a declaration that appears 11965 -- in the corresponding spec. Post error on the body, with a 11966 -- reference to the non-completed declaration. 11967 11968 else 11969 Error_Msg_Sloc := Sloc (E); 11970 11971 if Is_Type (E) then 11972 Error_Msg_NE ("missing full declaration for }!", Body_Id, E); 11973 11974 elsif Is_Overloadable (E) 11975 and then Current_Entity_In_Scope (E) /= E 11976 then 11977 -- It may be that the completion is mistyped and appears as 11978 -- a distinct overloading of the entity. 11979 11980 declare 11981 Candidate : constant Entity_Id := 11982 Current_Entity_In_Scope (E); 11983 Decl : constant Node_Id := 11984 Unit_Declaration_Node (Candidate); 11985 11986 begin 11987 if Is_Overloadable (Candidate) 11988 and then Ekind (Candidate) = Ekind (E) 11989 and then Nkind (Decl) = N_Subprogram_Body 11990 and then Acts_As_Spec (Decl) 11991 then 11992 Check_Type_Conformant (Candidate, E); 11993 11994 else 11995 Missing_Body; 11996 end if; 11997 end; 11998 11999 else 12000 Missing_Body; 12001 end if; 12002 end if; 12003 end if; 12004 end Post_Error; 12005 12006 -- Local variables 12007 12008 Pack_Id : constant Entity_Id := Current_Scope; 12009 12010 -- Start of processing for Check_Completion 12011 12012 begin 12013 E := First_Entity (Pack_Id); 12014 while Present (E) loop 12015 if Is_Intrinsic_Subprogram (E) then 12016 null; 12017 12018 -- The following situation requires special handling: a child unit 12019 -- that appears in the context clause of the body of its parent: 12020 12021 -- procedure Parent.Child (...); 12022 12023 -- with Parent.Child; 12024 -- package body Parent is 12025 12026 -- Here Parent.Child appears as a local entity, but should not be 12027 -- flagged as requiring completion, because it is a compilation 12028 -- unit. 12029 12030 -- Ignore missing completion for a subprogram that does not come from 12031 -- source (including the _Call primitive operation of RAS types, 12032 -- which has to have the flag Comes_From_Source for other purposes): 12033 -- we assume that the expander will provide the missing completion. 12034 -- In case of previous errors, other expansion actions that provide 12035 -- bodies for null procedures with not be invoked, so inhibit message 12036 -- in those cases. 12037 12038 -- Note that E_Operator is not in the list that follows, because 12039 -- this kind is reserved for predefined operators, that are 12040 -- intrinsic and do not need completion. 12041 12042 elsif Ekind (E) in E_Function 12043 | E_Procedure 12044 | E_Generic_Function 12045 | E_Generic_Procedure 12046 then 12047 if Has_Completion (E) then 12048 null; 12049 12050 elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then 12051 null; 12052 12053 elsif Is_Subprogram (E) 12054 and then (not Comes_From_Source (E) 12055 or else Chars (E) = Name_uCall) 12056 then 12057 null; 12058 12059 elsif 12060 Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit 12061 then 12062 null; 12063 12064 elsif Nkind (Parent (E)) = N_Procedure_Specification 12065 and then Null_Present (Parent (E)) 12066 and then Serious_Errors_Detected > 0 12067 then 12068 null; 12069 12070 else 12071 Post_Error; 12072 end if; 12073 12074 elsif Is_Entry (E) then 12075 if not Has_Completion (E) 12076 and then Ekind (Scope (E)) = E_Protected_Type 12077 then 12078 Post_Error; 12079 end if; 12080 12081 elsif Is_Package_Or_Generic_Package (E) then 12082 if Unit_Requires_Body (E) then 12083 if not Has_Completion (E) 12084 and then Nkind (Parent (Unit_Declaration_Node (E))) /= 12085 N_Compilation_Unit 12086 then 12087 Post_Error; 12088 end if; 12089 12090 elsif not Is_Child_Unit (E) then 12091 May_Need_Implicit_Body (E); 12092 end if; 12093 12094 -- A formal incomplete type (Ada 2012) does not require a completion; 12095 -- other incomplete type declarations do. 12096 12097 elsif Ekind (E) = E_Incomplete_Type then 12098 if No (Underlying_Type (E)) 12099 and then not Is_Generic_Type (E) 12100 then 12101 Post_Error; 12102 end if; 12103 12104 elsif Ekind (E) in E_Task_Type | E_Protected_Type then 12105 if not Has_Completion (E) then 12106 Post_Error; 12107 end if; 12108 12109 -- A single task declared in the current scope is a constant, verify 12110 -- that the body of its anonymous type is in the same scope. If the 12111 -- task is defined elsewhere, this may be a renaming declaration for 12112 -- which no completion is needed. 12113 12114 elsif Ekind (E) = E_Constant then 12115 if Ekind (Etype (E)) = E_Task_Type 12116 and then not Has_Completion (Etype (E)) 12117 and then Scope (Etype (E)) = Current_Scope 12118 then 12119 Post_Error; 12120 end if; 12121 12122 elsif Ekind (E) = E_Record_Type then 12123 if Is_Tagged_Type (E) then 12124 Check_Abstract_Overriding (E); 12125 Check_Conventions (E); 12126 end if; 12127 12128 Check_Aliased_Component_Types (E); 12129 12130 elsif Ekind (E) = E_Array_Type then 12131 Check_Aliased_Component_Types (E); 12132 12133 end if; 12134 12135 Next_Entity (E); 12136 end loop; 12137 end Check_Completion; 12138 12139 ------------------------------------- 12140 -- Check_Constraining_Discriminant -- 12141 ------------------------------------- 12142 12143 procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id) 12144 is 12145 New_Type : constant Entity_Id := Etype (New_Disc); 12146 Old_Type : Entity_Id; 12147 12148 begin 12149 -- If the record type contains an array constrained by the discriminant 12150 -- but with some different bound, the compiler tries to create a smaller 12151 -- range for the discriminant type (see exp_ch3.Adjust_Discriminants). 12152 -- In this case, where the discriminant type is a scalar type, the check 12153 -- must use the original discriminant type in the parent declaration. 12154 12155 if Is_Scalar_Type (New_Type) then 12156 Old_Type := Entity (Discriminant_Type (Parent (Old_Disc))); 12157 else 12158 Old_Type := Etype (Old_Disc); 12159 end if; 12160 12161 if not Subtypes_Statically_Compatible (New_Type, Old_Type) then 12162 Error_Msg_N 12163 ("subtype must be statically compatible with parent discriminant", 12164 New_Disc); 12165 12166 if not Predicates_Compatible (New_Type, Old_Type) then 12167 Error_Msg_N 12168 ("\subtype predicate is not compatible with parent discriminant", 12169 New_Disc); 12170 end if; 12171 end if; 12172 end Check_Constraining_Discriminant; 12173 12174 ------------------------------------ 12175 -- Check_CPP_Type_Has_No_Defaults -- 12176 ------------------------------------ 12177 12178 procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is 12179 Tdef : constant Node_Id := Type_Definition (Declaration_Node (T)); 12180 Clist : Node_Id; 12181 Comp : Node_Id; 12182 12183 begin 12184 -- Obtain the component list 12185 12186 if Nkind (Tdef) = N_Record_Definition then 12187 Clist := Component_List (Tdef); 12188 else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); 12189 Clist := Component_List (Record_Extension_Part (Tdef)); 12190 end if; 12191 12192 -- Check all components to ensure no default expressions 12193 12194 if Present (Clist) then 12195 Comp := First (Component_Items (Clist)); 12196 while Present (Comp) loop 12197 if Present (Expression (Comp)) then 12198 Error_Msg_N 12199 ("component of imported 'C'P'P type cannot have " 12200 & "default expression", Expression (Comp)); 12201 end if; 12202 12203 Next (Comp); 12204 end loop; 12205 end if; 12206 end Check_CPP_Type_Has_No_Defaults; 12207 12208 ---------------------------- 12209 -- Check_Delta_Expression -- 12210 ---------------------------- 12211 12212 procedure Check_Delta_Expression (E : Node_Id) is 12213 begin 12214 if not (Is_Real_Type (Etype (E))) then 12215 Wrong_Type (E, Any_Real); 12216 12217 elsif not Is_OK_Static_Expression (E) then 12218 Flag_Non_Static_Expr 12219 ("non-static expression used for delta value!", E); 12220 12221 elsif not UR_Is_Positive (Expr_Value_R (E)) then 12222 Error_Msg_N ("delta expression must be positive", E); 12223 12224 else 12225 return; 12226 end if; 12227 12228 -- If any of above errors occurred, then replace the incorrect 12229 -- expression by the real 0.1, which should prevent further errors. 12230 12231 Rewrite (E, 12232 Make_Real_Literal (Sloc (E), Ureal_Tenth)); 12233 Analyze_And_Resolve (E, Standard_Float); 12234 end Check_Delta_Expression; 12235 12236 ----------------------------- 12237 -- Check_Digits_Expression -- 12238 ----------------------------- 12239 12240 procedure Check_Digits_Expression (E : Node_Id) is 12241 begin 12242 if not (Is_Integer_Type (Etype (E))) then 12243 Wrong_Type (E, Any_Integer); 12244 12245 elsif not Is_OK_Static_Expression (E) then 12246 Flag_Non_Static_Expr 12247 ("non-static expression used for digits value!", E); 12248 12249 elsif Expr_Value (E) <= 0 then 12250 Error_Msg_N ("digits value must be greater than zero", E); 12251 12252 else 12253 return; 12254 end if; 12255 12256 -- If any of above errors occurred, then replace the incorrect 12257 -- expression by the integer 1, which should prevent further errors. 12258 12259 Rewrite (E, Make_Integer_Literal (Sloc (E), 1)); 12260 Analyze_And_Resolve (E, Standard_Integer); 12261 12262 end Check_Digits_Expression; 12263 12264 -------------------------- 12265 -- Check_Initialization -- 12266 -------------------------- 12267 12268 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is 12269 begin 12270 -- Special processing for limited types 12271 12272 if Is_Limited_Type (T) 12273 and then not In_Instance 12274 and then not In_Inlined_Body 12275 then 12276 if not OK_For_Limited_Init (T, Exp) then 12277 12278 -- In GNAT mode, this is just a warning, to allow it to be evilly 12279 -- turned off. Otherwise it is a real error. 12280 12281 if GNAT_Mode then 12282 Error_Msg_N 12283 ("??cannot initialize entities of limited type!", Exp); 12284 12285 elsif Ada_Version < Ada_2005 then 12286 12287 -- The side effect removal machinery may generate illegal Ada 12288 -- code to avoid the usage of access types and 'reference in 12289 -- SPARK mode. Since this is legal code with respect to theorem 12290 -- proving, do not emit the error. 12291 12292 if GNATprove_Mode 12293 and then Nkind (Exp) = N_Function_Call 12294 and then Nkind (Parent (Exp)) = N_Object_Declaration 12295 and then not Comes_From_Source 12296 (Defining_Identifier (Parent (Exp))) 12297 then 12298 null; 12299 12300 else 12301 Error_Msg_N 12302 ("cannot initialize entities of limited type", Exp); 12303 Explain_Limited_Type (T, Exp); 12304 end if; 12305 12306 else 12307 -- Specialize error message according to kind of illegal 12308 -- initial expression. We check the Original_Node to cover 12309 -- cases where the initialization expression of an object 12310 -- declaration generated by the compiler has been rewritten 12311 -- (such as for dispatching calls). 12312 12313 if Nkind (Original_Node (Exp)) = N_Type_Conversion 12314 and then 12315 Nkind (Expression (Original_Node (Exp))) = N_Function_Call 12316 then 12317 -- No error for internally-generated object declarations, 12318 -- which can come from build-in-place assignment statements. 12319 12320 if Nkind (Parent (Exp)) = N_Object_Declaration 12321 and then not Comes_From_Source 12322 (Defining_Identifier (Parent (Exp))) 12323 then 12324 null; 12325 12326 else 12327 Error_Msg_N 12328 ("illegal context for call to function with limited " 12329 & "result", Exp); 12330 end if; 12331 12332 else 12333 Error_Msg_N 12334 ("initialization of limited object requires aggregate or " 12335 & "function call", Exp); 12336 end if; 12337 end if; 12338 end if; 12339 end if; 12340 12341 -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets 12342 -- set unless we can be sure that no range check is required. 12343 12344 if not Expander_Active 12345 and then Is_Scalar_Type (T) 12346 and then not Is_In_Range (Exp, T, Assume_Valid => True) 12347 then 12348 Set_Do_Range_Check (Exp); 12349 end if; 12350 end Check_Initialization; 12351 12352 ---------------------- 12353 -- Check_Interfaces -- 12354 ---------------------- 12355 12356 procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is 12357 Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); 12358 12359 Iface : Node_Id; 12360 Iface_Def : Node_Id; 12361 Iface_Typ : Entity_Id; 12362 Parent_Node : Node_Id; 12363 12364 Is_Task : Boolean := False; 12365 -- Set True if parent type or any progenitor is a task interface 12366 12367 Is_Protected : Boolean := False; 12368 -- Set True if parent type or any progenitor is a protected interface 12369 12370 procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); 12371 -- Check that a progenitor is compatible with declaration. If an error 12372 -- message is output, it is posted on Error_Node. 12373 12374 ------------------ 12375 -- Check_Ifaces -- 12376 ------------------ 12377 12378 procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is 12379 Iface_Id : constant Entity_Id := 12380 Defining_Identifier (Parent (Iface_Def)); 12381 Type_Def : Node_Id; 12382 12383 begin 12384 if Nkind (N) = N_Private_Extension_Declaration then 12385 Type_Def := N; 12386 else 12387 Type_Def := Type_Definition (N); 12388 end if; 12389 12390 if Is_Task_Interface (Iface_Id) then 12391 Is_Task := True; 12392 12393 elsif Is_Protected_Interface (Iface_Id) then 12394 Is_Protected := True; 12395 end if; 12396 12397 if Is_Synchronized_Interface (Iface_Id) then 12398 12399 -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private 12400 -- extension derived from a synchronized interface must explicitly 12401 -- be declared synchronized, because the full view will be a 12402 -- synchronized type. 12403 12404 if Nkind (N) = N_Private_Extension_Declaration then 12405 if not Synchronized_Present (N) then 12406 Error_Msg_NE 12407 ("private extension of& must be explicitly synchronized", 12408 N, Iface_Id); 12409 end if; 12410 12411 -- However, by 3.9.4(16/2), a full type that is a record extension 12412 -- is never allowed to derive from a synchronized interface (note 12413 -- that interfaces must be excluded from this check, because those 12414 -- are represented by derived type definitions in some cases). 12415 12416 elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition 12417 and then not Interface_Present (Type_Definition (N)) 12418 then 12419 Error_Msg_N ("record extension cannot derive from synchronized " 12420 & "interface", Error_Node); 12421 end if; 12422 end if; 12423 12424 -- Check that the characteristics of the progenitor are compatible 12425 -- with the explicit qualifier in the declaration. 12426 -- The check only applies to qualifiers that come from source. 12427 -- Limited_Present also appears in the declaration of corresponding 12428 -- records, and the check does not apply to them. 12429 12430 if Limited_Present (Type_Def) 12431 and then not 12432 Is_Concurrent_Record_Type (Defining_Identifier (N)) 12433 then 12434 if Is_Limited_Interface (Parent_Type) 12435 and then not Is_Limited_Interface (Iface_Id) 12436 then 12437 Error_Msg_NE 12438 ("progenitor & must be limited interface", 12439 Error_Node, Iface_Id); 12440 12441 elsif 12442 (Task_Present (Iface_Def) 12443 or else Protected_Present (Iface_Def) 12444 or else Synchronized_Present (Iface_Def)) 12445 and then Nkind (N) /= N_Private_Extension_Declaration 12446 and then not Error_Posted (N) 12447 then 12448 Error_Msg_NE 12449 ("progenitor & must be limited interface", 12450 Error_Node, Iface_Id); 12451 end if; 12452 12453 -- Protected interfaces can only inherit from limited, synchronized 12454 -- or protected interfaces. 12455 12456 elsif Nkind (N) = N_Full_Type_Declaration 12457 and then Protected_Present (Type_Def) 12458 then 12459 if Limited_Present (Iface_Def) 12460 or else Synchronized_Present (Iface_Def) 12461 or else Protected_Present (Iface_Def) 12462 then 12463 null; 12464 12465 elsif Task_Present (Iface_Def) then 12466 Error_Msg_N ("(Ada 2005) protected interface cannot inherit " 12467 & "from task interface", Error_Node); 12468 12469 else 12470 Error_Msg_N ("(Ada 2005) protected interface cannot inherit " 12471 & "from non-limited interface", Error_Node); 12472 end if; 12473 12474 -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from 12475 -- limited and synchronized. 12476 12477 elsif Synchronized_Present (Type_Def) then 12478 if Limited_Present (Iface_Def) 12479 or else Synchronized_Present (Iface_Def) 12480 then 12481 null; 12482 12483 elsif Protected_Present (Iface_Def) 12484 and then Nkind (N) /= N_Private_Extension_Declaration 12485 then 12486 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " 12487 & "from protected interface", Error_Node); 12488 12489 elsif Task_Present (Iface_Def) 12490 and then Nkind (N) /= N_Private_Extension_Declaration 12491 then 12492 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " 12493 & "from task interface", Error_Node); 12494 12495 elsif not Is_Limited_Interface (Iface_Id) then 12496 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit " 12497 & "from non-limited interface", Error_Node); 12498 end if; 12499 12500 -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, 12501 -- synchronized or task interfaces. 12502 12503 elsif Nkind (N) = N_Full_Type_Declaration 12504 and then Task_Present (Type_Def) 12505 then 12506 if Limited_Present (Iface_Def) 12507 or else Synchronized_Present (Iface_Def) 12508 or else Task_Present (Iface_Def) 12509 then 12510 null; 12511 12512 elsif Protected_Present (Iface_Def) then 12513 Error_Msg_N ("(Ada 2005) task interface cannot inherit from " 12514 & "protected interface", Error_Node); 12515 12516 else 12517 Error_Msg_N ("(Ada 2005) task interface cannot inherit from " 12518 & "non-limited interface", Error_Node); 12519 end if; 12520 end if; 12521 end Check_Ifaces; 12522 12523 -- Start of processing for Check_Interfaces 12524 12525 begin 12526 if Is_Interface (Parent_Type) then 12527 if Is_Task_Interface (Parent_Type) then 12528 Is_Task := True; 12529 12530 elsif Is_Protected_Interface (Parent_Type) then 12531 Is_Protected := True; 12532 end if; 12533 end if; 12534 12535 if Nkind (N) = N_Private_Extension_Declaration then 12536 12537 -- Check that progenitors are compatible with declaration 12538 12539 Iface := First (Interface_List (Def)); 12540 while Present (Iface) loop 12541 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 12542 12543 Parent_Node := Parent (Base_Type (Iface_Typ)); 12544 Iface_Def := Type_Definition (Parent_Node); 12545 12546 if not Is_Interface (Iface_Typ) then 12547 Diagnose_Interface (Iface, Iface_Typ); 12548 else 12549 Check_Ifaces (Iface_Def, Iface); 12550 end if; 12551 12552 Next (Iface); 12553 end loop; 12554 12555 if Is_Task and Is_Protected then 12556 Error_Msg_N 12557 ("type cannot derive from task and protected interface", N); 12558 end if; 12559 12560 return; 12561 end if; 12562 12563 -- Full type declaration of derived type. 12564 -- Check compatibility with parent if it is interface type 12565 12566 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition 12567 and then Is_Interface (Parent_Type) 12568 then 12569 Parent_Node := Parent (Parent_Type); 12570 12571 -- More detailed checks for interface varieties 12572 12573 Check_Ifaces 12574 (Iface_Def => Type_Definition (Parent_Node), 12575 Error_Node => Subtype_Indication (Type_Definition (N))); 12576 end if; 12577 12578 Iface := First (Interface_List (Def)); 12579 while Present (Iface) loop 12580 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 12581 12582 Parent_Node := Parent (Base_Type (Iface_Typ)); 12583 Iface_Def := Type_Definition (Parent_Node); 12584 12585 if not Is_Interface (Iface_Typ) then 12586 Diagnose_Interface (Iface, Iface_Typ); 12587 12588 else 12589 -- "The declaration of a specific descendant of an interface 12590 -- type freezes the interface type" RM 13.14 12591 12592 Freeze_Before (N, Iface_Typ); 12593 Check_Ifaces (Iface_Def, Error_Node => Iface); 12594 end if; 12595 12596 Next (Iface); 12597 end loop; 12598 12599 if Is_Task and Is_Protected then 12600 Error_Msg_N 12601 ("type cannot derive from task and protected interface", N); 12602 end if; 12603 end Check_Interfaces; 12604 12605 ------------------------------------ 12606 -- Check_Or_Process_Discriminants -- 12607 ------------------------------------ 12608 12609 -- If an incomplete or private type declaration was already given for the 12610 -- type, the discriminants may have already been processed if they were 12611 -- present on the incomplete declaration. In this case a full conformance 12612 -- check has been performed in Find_Type_Name, and we then recheck here 12613 -- some properties that can't be checked on the partial view alone. 12614 -- Otherwise we call Process_Discriminants. 12615 12616 procedure Check_Or_Process_Discriminants 12617 (N : Node_Id; 12618 T : Entity_Id; 12619 Prev : Entity_Id := Empty) 12620 is 12621 begin 12622 if Has_Discriminants (T) then 12623 12624 -- Discriminants are already set on T if they were already present 12625 -- on the partial view. Make them visible to component declarations. 12626 12627 declare 12628 D : Entity_Id; 12629 -- Discriminant on T (full view) referencing expr on partial view 12630 12631 Prev_D : Entity_Id; 12632 -- Entity of corresponding discriminant on partial view 12633 12634 New_D : Node_Id; 12635 -- Discriminant specification for full view, expression is 12636 -- the syntactic copy on full view (which has been checked for 12637 -- conformance with partial view), only used here to post error 12638 -- message. 12639 12640 begin 12641 D := First_Discriminant (T); 12642 New_D := First (Discriminant_Specifications (N)); 12643 while Present (D) loop 12644 Prev_D := Current_Entity (D); 12645 Set_Current_Entity (D); 12646 Set_Is_Immediately_Visible (D); 12647 Set_Homonym (D, Prev_D); 12648 12649 -- Handle the case where there is an untagged partial view and 12650 -- the full view is tagged: must disallow discriminants with 12651 -- defaults, unless compiling for Ada 2012, which allows a 12652 -- limited tagged type to have defaulted discriminants (see 12653 -- AI05-0214). However, suppress error here if it was already 12654 -- reported on the default expression of the partial view. 12655 12656 if Is_Tagged_Type (T) 12657 and then Present (Expression (Parent (D))) 12658 and then (not Is_Limited_Type (Current_Scope) 12659 or else Ada_Version < Ada_2012) 12660 and then not Error_Posted (Expression (Parent (D))) 12661 then 12662 if Ada_Version >= Ada_2012 then 12663 Error_Msg_N 12664 ("discriminants of nonlimited tagged type cannot have " 12665 & "defaults", 12666 Expression (New_D)); 12667 else 12668 Error_Msg_N 12669 ("discriminants of tagged type cannot have defaults", 12670 Expression (New_D)); 12671 end if; 12672 end if; 12673 12674 -- Ada 2005 (AI-230): Access discriminant allowed in 12675 -- non-limited record types. 12676 12677 if Ada_Version < Ada_2005 then 12678 12679 -- This restriction gets applied to the full type here. It 12680 -- has already been applied earlier to the partial view. 12681 12682 Check_Access_Discriminant_Requires_Limited (Parent (D), N); 12683 end if; 12684 12685 Next_Discriminant (D); 12686 Next (New_D); 12687 end loop; 12688 end; 12689 12690 elsif Present (Discriminant_Specifications (N)) then 12691 Process_Discriminants (N, Prev); 12692 end if; 12693 end Check_Or_Process_Discriminants; 12694 12695 ---------------------- 12696 -- Check_Real_Bound -- 12697 ---------------------- 12698 12699 procedure Check_Real_Bound (Bound : Node_Id) is 12700 begin 12701 if not Is_Real_Type (Etype (Bound)) then 12702 Error_Msg_N 12703 ("bound in real type definition must be of real type", Bound); 12704 12705 elsif not Is_OK_Static_Expression (Bound) then 12706 Flag_Non_Static_Expr 12707 ("non-static expression used for real type bound!", Bound); 12708 12709 else 12710 return; 12711 end if; 12712 12713 Rewrite 12714 (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0)); 12715 Analyze (Bound); 12716 Resolve (Bound, Standard_Float); 12717 end Check_Real_Bound; 12718 12719 ------------------------------ 12720 -- Complete_Private_Subtype -- 12721 ------------------------------ 12722 12723 procedure Complete_Private_Subtype 12724 (Priv : Entity_Id; 12725 Full : Entity_Id; 12726 Full_Base : Entity_Id; 12727 Related_Nod : Node_Id) 12728 is 12729 Save_Next_Entity : Entity_Id; 12730 Save_Homonym : Entity_Id; 12731 12732 begin 12733 -- Set semantic attributes for (implicit) private subtype completion. 12734 -- If the full type has no discriminants, then it is a copy of the 12735 -- full view of the base. Otherwise, it is a subtype of the base with 12736 -- a possible discriminant constraint. Save and restore the original 12737 -- Next_Entity field of full to ensure that the calls to Copy_Node do 12738 -- not corrupt the entity chain. 12739 12740 Save_Next_Entity := Next_Entity (Full); 12741 Save_Homonym := Homonym (Priv); 12742 12743 if Is_Private_Type (Full_Base) 12744 or else Is_Record_Type (Full_Base) 12745 or else Is_Concurrent_Type (Full_Base) 12746 then 12747 Copy_Node (Priv, Full); 12748 12749 -- Note that the Etype of the full view is the same as the Etype of 12750 -- the partial view. In this fashion, the subtype has access to the 12751 -- correct view of the parent. 12752 12753 Set_Has_Discriminants (Full, Has_Discriminants (Full_Base)); 12754 Set_Has_Unknown_Discriminants 12755 (Full, Has_Unknown_Discriminants (Full_Base)); 12756 Set_First_Entity (Full, First_Entity (Full_Base)); 12757 Set_Last_Entity (Full, Last_Entity (Full_Base)); 12758 12759 -- If the underlying base type is constrained, we know that the 12760 -- full view of the subtype is constrained as well (the converse 12761 -- is not necessarily true). 12762 12763 if Is_Constrained (Full_Base) then 12764 Set_Is_Constrained (Full); 12765 end if; 12766 12767 else 12768 Copy_Node (Full_Base, Full); 12769 12770 -- The following subtlety with the Etype of the full view needs to be 12771 -- taken into account here. One could think that it must naturally be 12772 -- set to the base type of the full base: 12773 12774 -- Set_Etype (Full, Base_Type (Full_Base)); 12775 12776 -- so that the full view becomes a subtype of the full base when the 12777 -- latter is a base type, which must for example happen when the full 12778 -- base is declared as derived type. That's also correct if the full 12779 -- base is declared as an array type, or a floating-point type, or a 12780 -- fixed-point type, or a signed integer type, as these declarations 12781 -- create an implicit base type and a first subtype so the Etype of 12782 -- the full views must be the implicit base type. But that's wrong 12783 -- if the full base is declared as an access type, or an enumeration 12784 -- type, or a modular integer type, as these declarations directly 12785 -- create a base type, i.e. with Etype pointing to itself. Moreover 12786 -- the full base being declared in the private part, i.e. when the 12787 -- views are swapped, the end result is that the Etype of the full 12788 -- base is set to its private view in this case and that we need to 12789 -- propagate this setting to the full view in order for the subtype 12790 -- to be compatible with the base type. 12791 12792 if Is_Base_Type (Full_Base) 12793 and then (Is_Derived_Type (Full_Base) 12794 or else Ekind (Full_Base) in Array_Kind 12795 or else Ekind (Full_Base) in Fixed_Point_Kind 12796 or else Ekind (Full_Base) in Float_Kind 12797 or else Ekind (Full_Base) in Signed_Integer_Kind) 12798 then 12799 Set_Etype (Full, Full_Base); 12800 end if; 12801 12802 Set_Chars (Full, Chars (Priv)); 12803 Set_Sloc (Full, Sloc (Priv)); 12804 Conditional_Delay (Full, Priv); 12805 end if; 12806 12807 Link_Entities (Full, Save_Next_Entity); 12808 Set_Homonym (Full, Save_Homonym); 12809 Set_Associated_Node_For_Itype (Full, Related_Nod); 12810 12811 if Ekind (Full) in Incomplete_Or_Private_Kind then 12812 Reinit_Field_To_Zero (Full, F_Private_Dependents); 12813 end if; 12814 12815 -- Set common attributes for all subtypes: kind, convention, etc. 12816 12817 Mutate_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); 12818 Set_Convention (Full, Convention (Full_Base)); 12819 Set_Is_First_Subtype (Full, False); 12820 Set_Scope (Full, Scope (Priv)); 12821 Set_Size_Info (Full, Full_Base); 12822 Copy_RM_Size (To => Full, From => Full_Base); 12823 Set_Is_Itype (Full); 12824 12825 -- A subtype of a private-type-without-discriminants, whose full-view 12826 -- has discriminants with default expressions, is not constrained. 12827 12828 if not Has_Discriminants (Priv) then 12829 Set_Is_Constrained (Full, Is_Constrained (Full_Base)); 12830 12831 if Has_Discriminants (Full_Base) then 12832 Set_Discriminant_Constraint 12833 (Full, Discriminant_Constraint (Full_Base)); 12834 12835 -- The partial view may have been indefinite, the full view 12836 -- might not be. 12837 12838 Set_Has_Unknown_Discriminants 12839 (Full, Has_Unknown_Discriminants (Full_Base)); 12840 end if; 12841 end if; 12842 12843 Set_First_Rep_Item (Full, First_Rep_Item (Full_Base)); 12844 Set_Depends_On_Private (Full, Has_Private_Component (Full)); 12845 12846 -- Freeze the private subtype entity if its parent is delayed, and not 12847 -- already frozen. We skip this processing if the type is an anonymous 12848 -- subtype of a record component, or is the corresponding record of a 12849 -- protected type, since these are processed when the enclosing type 12850 -- is frozen. If the parent type is declared in a nested package then 12851 -- the freezing of the private and full views also happens later. 12852 12853 if not Is_Type (Scope (Full)) then 12854 if Is_Itype (Priv) 12855 and then In_Same_Source_Unit (Full, Full_Base) 12856 and then Scope (Full_Base) /= Scope (Full) 12857 then 12858 Set_Has_Delayed_Freeze (Full); 12859 Set_Has_Delayed_Freeze (Priv); 12860 12861 else 12862 Set_Has_Delayed_Freeze (Full, 12863 Has_Delayed_Freeze (Full_Base) 12864 and then not Is_Frozen (Full_Base)); 12865 end if; 12866 end if; 12867 12868 Set_Freeze_Node (Full, Empty); 12869 Set_Is_Frozen (Full, False); 12870 12871 if Has_Discriminants (Full) then 12872 Set_Stored_Constraint_From_Discriminant_Constraint (Full); 12873 Set_Stored_Constraint (Priv, Stored_Constraint (Full)); 12874 12875 if Has_Unknown_Discriminants (Full) then 12876 Set_Discriminant_Constraint (Full, No_Elist); 12877 end if; 12878 end if; 12879 12880 if Ekind (Full_Base) = E_Record_Type 12881 and then Has_Discriminants (Full_Base) 12882 and then Has_Discriminants (Priv) -- might not, if errors 12883 and then not Has_Unknown_Discriminants (Priv) 12884 and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv)) 12885 then 12886 Create_Constrained_Components 12887 (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv)); 12888 12889 -- If the full base is itself derived from private, build a congruent 12890 -- subtype of its underlying full view, for use by the back end. 12891 12892 elsif Is_Private_Type (Full_Base) 12893 and then Present (Underlying_Full_View (Full_Base)) 12894 then 12895 declare 12896 Underlying_Full_Base : constant Entity_Id 12897 := Underlying_Full_View (Full_Base); 12898 Underlying_Full : constant Entity_Id 12899 := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); 12900 begin 12901 Set_Is_Itype (Underlying_Full); 12902 Set_Associated_Node_For_Itype (Underlying_Full, Related_Nod); 12903 Complete_Private_Subtype 12904 (Priv, Underlying_Full, Underlying_Full_Base, Related_Nod); 12905 Set_Underlying_Full_View (Full, Underlying_Full); 12906 Set_Is_Underlying_Full_View (Underlying_Full); 12907 end; 12908 12909 elsif Is_Record_Type (Full_Base) then 12910 12911 -- Show Full is simply a renaming of Full_Base 12912 12913 Set_Cloned_Subtype (Full, Full_Base); 12914 Set_Is_Limited_Record (Full, Is_Limited_Record (Full_Base)); 12915 12916 -- Propagate predicates 12917 12918 Propagate_Predicate_Attributes (Full, Full_Base); 12919 end if; 12920 12921 -- It is unsafe to share the bounds of a scalar type, because the Itype 12922 -- is elaborated on demand, and if a bound is nonstatic, then different 12923 -- orders of elaboration in different units will lead to different 12924 -- external symbols. 12925 12926 if Is_Scalar_Type (Full_Base) then 12927 Set_Scalar_Range (Full, 12928 Make_Range (Sloc (Related_Nod), 12929 Low_Bound => 12930 Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)), 12931 High_Bound => 12932 Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base)))); 12933 12934 -- This completion inherits the bounds of the full parent, but if 12935 -- the parent is an unconstrained floating point type, so is the 12936 -- completion. 12937 12938 if Is_Floating_Point_Type (Full_Base) then 12939 Set_Includes_Infinities 12940 (Scalar_Range (Full), Has_Infinities (Full_Base)); 12941 end if; 12942 end if; 12943 12944 -- ??? It seems that a lot of fields are missing that should be copied 12945 -- from Full_Base to Full. Here are some that are introduced in a 12946 -- non-disruptive way but a cleanup is necessary. 12947 12948 if Is_Tagged_Type (Full_Base) then 12949 Set_Is_Tagged_Type (Full); 12950 Set_Is_Limited_Record (Full, Is_Limited_Record (Full_Base)); 12951 12952 Set_Direct_Primitive_Operations 12953 (Full, Direct_Primitive_Operations (Full_Base)); 12954 Set_No_Tagged_Streams_Pragma 12955 (Full, No_Tagged_Streams_Pragma (Full_Base)); 12956 12957 if Is_Interface (Full_Base) then 12958 Set_Is_Interface (Full); 12959 Set_Is_Limited_Interface (Full, Is_Limited_Interface (Full_Base)); 12960 end if; 12961 12962 -- Inherit class_wide type of full_base in case the partial view was 12963 -- not tagged. Otherwise it has already been created when the private 12964 -- subtype was analyzed. 12965 12966 if No (Class_Wide_Type (Full)) then 12967 Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); 12968 end if; 12969 12970 -- If this is a subtype of a protected or task type, constrain its 12971 -- corresponding record, unless this is a subtype without constraints, 12972 -- i.e. a simple renaming as with an actual subtype in an instance. 12973 12974 elsif Is_Concurrent_Type (Full_Base) then 12975 if Has_Discriminants (Full) 12976 and then Present (Corresponding_Record_Type (Full_Base)) 12977 and then 12978 not Is_Empty_Elmt_List (Discriminant_Constraint (Full)) 12979 then 12980 Set_Corresponding_Record_Type (Full, 12981 Constrain_Corresponding_Record 12982 (Full, Corresponding_Record_Type (Full_Base), Related_Nod)); 12983 12984 else 12985 Set_Corresponding_Record_Type (Full, 12986 Corresponding_Record_Type (Full_Base)); 12987 end if; 12988 end if; 12989 12990 -- Link rep item chain, and also setting of Has_Predicates from private 12991 -- subtype to full subtype, since we will need these on the full subtype 12992 -- to create the predicate function. Note that the full subtype may 12993 -- already have rep items, inherited from the full view of the base 12994 -- type, so we must be sure not to overwrite these entries. 12995 12996 declare 12997 Append : Boolean; 12998 Item : Node_Id; 12999 Next_Item : Node_Id; 13000 Priv_Item : Node_Id; 13001 13002 begin 13003 Item := First_Rep_Item (Full); 13004 Priv_Item := First_Rep_Item (Priv); 13005 13006 -- If no existing rep items on full type, we can just link directly 13007 -- to the list of items on the private type, if any exist.. Same if 13008 -- the rep items are only those inherited from the base 13009 13010 if (No (Item) 13011 or else Nkind (Item) /= N_Aspect_Specification 13012 or else Entity (Item) = Full_Base) 13013 and then Present (First_Rep_Item (Priv)) 13014 then 13015 Set_First_Rep_Item (Full, Priv_Item); 13016 13017 -- Otherwise, search to the end of items currently linked to the full 13018 -- subtype and append the private items to the end. However, if Priv 13019 -- and Full already have the same list of rep items, then the append 13020 -- is not done, as that would create a circularity. 13021 -- 13022 -- The partial view may have a predicate and the rep item lists of 13023 -- both views agree when inherited from the same ancestor. In that 13024 -- case, simply propagate the list from one view to the other. 13025 -- A more complex analysis needed here ??? 13026 13027 elsif Present (Priv_Item) 13028 and then Item = Next_Rep_Item (Priv_Item) 13029 then 13030 Set_First_Rep_Item (Full, Priv_Item); 13031 13032 elsif Item /= Priv_Item then 13033 Append := True; 13034 loop 13035 Next_Item := Next_Rep_Item (Item); 13036 exit when No (Next_Item); 13037 Item := Next_Item; 13038 13039 -- If the private view has aspect specifications, the full view 13040 -- inherits them. Since these aspects may already have been 13041 -- attached to the full view during derivation, do not append 13042 -- them if already present. 13043 13044 if Item = First_Rep_Item (Priv) then 13045 Append := False; 13046 exit; 13047 end if; 13048 end loop; 13049 13050 -- And link the private type items at the end of the chain 13051 13052 if Append then 13053 Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); 13054 end if; 13055 end if; 13056 end; 13057 13058 -- Make sure Has_Predicates is set on full type if it is set on the 13059 -- private type. Note that it may already be set on the full type and 13060 -- if so, we don't want to unset it. Similarly, propagate information 13061 -- about delayed aspects, because the corresponding pragmas must be 13062 -- analyzed when one of the views is frozen. This last step is needed 13063 -- in particular when the full type is a scalar type for which an 13064 -- anonymous base type is constructed. 13065 13066 -- The predicate functions are generated either at the freeze point 13067 -- of the type or at the end of the visible part, and we must avoid 13068 -- generating them twice. 13069 13070 Propagate_Predicate_Attributes (Full, Priv); 13071 13072 if Has_Delayed_Aspects (Priv) then 13073 Set_Has_Delayed_Aspects (Full); 13074 end if; 13075 end Complete_Private_Subtype; 13076 13077 ---------------------------- 13078 -- Constant_Redeclaration -- 13079 ---------------------------- 13080 13081 procedure Constant_Redeclaration 13082 (Id : Entity_Id; 13083 N : Node_Id; 13084 T : out Entity_Id) 13085 is 13086 Prev : constant Entity_Id := Current_Entity_In_Scope (Id); 13087 Obj_Def : constant Node_Id := Object_Definition (N); 13088 New_T : Entity_Id; 13089 13090 procedure Check_Possible_Deferred_Completion 13091 (Prev_Id : Entity_Id; 13092 Prev_Obj_Def : Node_Id; 13093 Curr_Obj_Def : Node_Id); 13094 -- Determine whether the two object definitions describe the partial 13095 -- and the full view of a constrained deferred constant. Generate 13096 -- a subtype for the full view and verify that it statically matches 13097 -- the subtype of the partial view. 13098 13099 procedure Check_Recursive_Declaration (Typ : Entity_Id); 13100 -- If deferred constant is an access type initialized with an allocator, 13101 -- check whether there is an illegal recursion in the definition, 13102 -- through a default value of some record subcomponent. This is normally 13103 -- detected when generating init procs, but requires this additional 13104 -- mechanism when expansion is disabled. 13105 13106 ---------------------------------------- 13107 -- Check_Possible_Deferred_Completion -- 13108 ---------------------------------------- 13109 13110 procedure Check_Possible_Deferred_Completion 13111 (Prev_Id : Entity_Id; 13112 Prev_Obj_Def : Node_Id; 13113 Curr_Obj_Def : Node_Id) 13114 is 13115 begin 13116 if Nkind (Prev_Obj_Def) = N_Subtype_Indication 13117 and then Present (Constraint (Prev_Obj_Def)) 13118 and then Nkind (Curr_Obj_Def) = N_Subtype_Indication 13119 and then Present (Constraint (Curr_Obj_Def)) 13120 then 13121 declare 13122 Loc : constant Source_Ptr := Sloc (N); 13123 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); 13124 Decl : constant Node_Id := 13125 Make_Subtype_Declaration (Loc, 13126 Defining_Identifier => Def_Id, 13127 Subtype_Indication => 13128 Relocate_Node (Curr_Obj_Def)); 13129 13130 begin 13131 Insert_Before_And_Analyze (N, Decl); 13132 Set_Etype (Id, Def_Id); 13133 13134 if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then 13135 Error_Msg_Sloc := Sloc (Prev_Id); 13136 Error_Msg_N ("subtype does not statically match deferred " 13137 & "declaration #", N); 13138 end if; 13139 end; 13140 end if; 13141 end Check_Possible_Deferred_Completion; 13142 13143 --------------------------------- 13144 -- Check_Recursive_Declaration -- 13145 --------------------------------- 13146 13147 procedure Check_Recursive_Declaration (Typ : Entity_Id) is 13148 Comp : Entity_Id; 13149 13150 begin 13151 if Is_Record_Type (Typ) then 13152 Comp := First_Component (Typ); 13153 while Present (Comp) loop 13154 if Comes_From_Source (Comp) then 13155 if Present (Expression (Parent (Comp))) 13156 and then Is_Entity_Name (Expression (Parent (Comp))) 13157 and then Entity (Expression (Parent (Comp))) = Prev 13158 then 13159 Error_Msg_Sloc := Sloc (Parent (Comp)); 13160 Error_Msg_NE 13161 ("illegal circularity with declaration for & #", 13162 N, Comp); 13163 return; 13164 13165 elsif Is_Record_Type (Etype (Comp)) then 13166 Check_Recursive_Declaration (Etype (Comp)); 13167 end if; 13168 end if; 13169 13170 Next_Component (Comp); 13171 end loop; 13172 end if; 13173 end Check_Recursive_Declaration; 13174 13175 -- Start of processing for Constant_Redeclaration 13176 13177 begin 13178 if Nkind (Parent (Prev)) = N_Object_Declaration then 13179 if Nkind (Object_Definition 13180 (Parent (Prev))) = N_Subtype_Indication 13181 then 13182 -- Find type of new declaration. The constraints of the two 13183 -- views must match statically, but there is no point in 13184 -- creating an itype for the full view. 13185 13186 if Nkind (Obj_Def) = N_Subtype_Indication then 13187 Find_Type (Subtype_Mark (Obj_Def)); 13188 New_T := Entity (Subtype_Mark (Obj_Def)); 13189 13190 else 13191 Find_Type (Obj_Def); 13192 New_T := Entity (Obj_Def); 13193 end if; 13194 13195 T := Etype (Prev); 13196 13197 else 13198 -- The full view may impose a constraint, even if the partial 13199 -- view does not, so construct the subtype. 13200 13201 New_T := Find_Type_Of_Object (Obj_Def, N); 13202 T := New_T; 13203 end if; 13204 13205 else 13206 -- Current declaration is illegal, diagnosed below in Enter_Name 13207 13208 T := Empty; 13209 New_T := Any_Type; 13210 end if; 13211 13212 -- If previous full declaration or a renaming declaration exists, or if 13213 -- a homograph is present, let Enter_Name handle it, either with an 13214 -- error or with the removal of an overridden implicit subprogram. 13215 -- The previous one is a full declaration if it has an expression 13216 -- (which in the case of an aggregate is indicated by the Init flag). 13217 13218 if Ekind (Prev) /= E_Constant 13219 or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration 13220 or else Present (Expression (Parent (Prev))) 13221 or else Has_Init_Expression (Parent (Prev)) 13222 or else Present (Full_View (Prev)) 13223 then 13224 Enter_Name (Id); 13225 13226 -- Verify that types of both declarations match, or else that both types 13227 -- are anonymous access types whose designated subtypes statically match 13228 -- (as allowed in Ada 2005 by AI-385). 13229 13230 elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) 13231 and then 13232 (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type 13233 or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type 13234 or else Is_Access_Constant (Etype (New_T)) /= 13235 Is_Access_Constant (Etype (Prev)) 13236 or else Can_Never_Be_Null (Etype (New_T)) /= 13237 Can_Never_Be_Null (Etype (Prev)) 13238 or else Null_Exclusion_Present (Parent (Prev)) /= 13239 Null_Exclusion_Present (Parent (Id)) 13240 or else not Subtypes_Statically_Match 13241 (Designated_Type (Etype (Prev)), 13242 Designated_Type (Etype (New_T)))) 13243 then 13244 Error_Msg_Sloc := Sloc (Prev); 13245 Error_Msg_N ("type does not match declaration#", N); 13246 Set_Full_View (Prev, Id); 13247 Set_Etype (Id, Any_Type); 13248 13249 -- A deferred constant whose type is an anonymous array is always 13250 -- illegal (unless imported). A detailed error message might be 13251 -- helpful for Ada beginners. 13252 13253 if Nkind (Object_Definition (Parent (Prev))) 13254 = N_Constrained_Array_Definition 13255 and then Nkind (Object_Definition (N)) 13256 = N_Constrained_Array_Definition 13257 then 13258 Error_Msg_N ("\each anonymous array is a distinct type", N); 13259 Error_Msg_N ("a deferred constant must have a named type", 13260 Object_Definition (Parent (Prev))); 13261 end if; 13262 13263 elsif 13264 Null_Exclusion_Present (Parent (Prev)) 13265 and then not Null_Exclusion_Present (N) 13266 then 13267 Error_Msg_Sloc := Sloc (Prev); 13268 Error_Msg_N ("null-exclusion does not match declaration#", N); 13269 Set_Full_View (Prev, Id); 13270 Set_Etype (Id, Any_Type); 13271 13272 -- If so, process the full constant declaration 13273 13274 else 13275 -- RM 7.4 (6): If the subtype defined by the subtype_indication in 13276 -- the deferred declaration is constrained, then the subtype defined 13277 -- by the subtype_indication in the full declaration shall match it 13278 -- statically. 13279 13280 Check_Possible_Deferred_Completion 13281 (Prev_Id => Prev, 13282 Prev_Obj_Def => Object_Definition (Parent (Prev)), 13283 Curr_Obj_Def => Obj_Def); 13284 13285 Set_Full_View (Prev, Id); 13286 Set_Is_Public (Id, Is_Public (Prev)); 13287 Set_Is_Internal (Id); 13288 Append_Entity (Id, Current_Scope); 13289 13290 -- Check ALIASED present if present before (RM 7.4(7)) 13291 13292 if Is_Aliased (Prev) 13293 and then not Aliased_Present (N) 13294 then 13295 Error_Msg_Sloc := Sloc (Prev); 13296 Error_Msg_N ("ALIASED required (see declaration #)", N); 13297 end if; 13298 13299 -- Check that placement is in private part and that the incomplete 13300 -- declaration appeared in the visible part. 13301 13302 if Ekind (Current_Scope) = E_Package 13303 and then not In_Private_Part (Current_Scope) 13304 then 13305 Error_Msg_Sloc := Sloc (Prev); 13306 Error_Msg_N 13307 ("full constant for declaration # must be in private part", N); 13308 13309 elsif Ekind (Current_Scope) = E_Package 13310 and then 13311 List_Containing (Parent (Prev)) /= 13312 Visible_Declarations (Package_Specification (Current_Scope)) 13313 then 13314 Error_Msg_N 13315 ("deferred constant must be declared in visible part", 13316 Parent (Prev)); 13317 end if; 13318 13319 if Is_Access_Type (T) 13320 and then Nkind (Expression (N)) = N_Allocator 13321 then 13322 Check_Recursive_Declaration (Designated_Type (T)); 13323 end if; 13324 13325 -- A deferred constant is a visible entity. If type has invariants, 13326 -- verify that the initial value satisfies them. This is not done in 13327 -- GNATprove mode, as GNATprove handles invariant checks itself. 13328 13329 if Has_Invariants (T) 13330 and then Present (Invariant_Procedure (T)) 13331 and then not GNATprove_Mode 13332 then 13333 Insert_After (N, 13334 Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N)))); 13335 end if; 13336 end if; 13337 end Constant_Redeclaration; 13338 13339 ---------------------- 13340 -- Constrain_Access -- 13341 ---------------------- 13342 13343 procedure Constrain_Access 13344 (Def_Id : in out Entity_Id; 13345 S : Node_Id; 13346 Related_Nod : Node_Id) 13347 is 13348 T : constant Entity_Id := Entity (Subtype_Mark (S)); 13349 Desig_Type : constant Entity_Id := Designated_Type (T); 13350 Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); 13351 Constraint_OK : Boolean := True; 13352 13353 begin 13354 if Is_Array_Type (Desig_Type) then 13355 Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); 13356 13357 elsif (Is_Record_Type (Desig_Type) 13358 or else Is_Incomplete_Or_Private_Type (Desig_Type)) 13359 and then not Is_Constrained (Desig_Type) 13360 then 13361 -- If this is a constrained access definition for a record 13362 -- component, we leave the type as an unconstrained access, 13363 -- and mark the component so that its actual type is built 13364 -- at a point of use (e.g., an assignment statement). This 13365 -- is handled in Sem_Util.Build_Actual_Subtype_Of_Component. 13366 13367 if Desig_Type = Current_Scope 13368 and then No (Def_Id) 13369 then 13370 Desig_Subtype := 13371 Create_Itype 13372 (E_Void, Related_Nod, Scope_Id => Scope (Desig_Type)); 13373 Mutate_Ekind (Desig_Subtype, E_Record_Subtype); 13374 Def_Id := Entity (Subtype_Mark (S)); 13375 13376 -- We indicate that the component has a per-object constraint 13377 -- for treatment at a point of use, even though the constraint 13378 -- may be independent of discriminants of the enclosing type. 13379 13380 if Nkind (Related_Nod) = N_Component_Declaration then 13381 Set_Has_Per_Object_Constraint 13382 (Defining_Identifier (Related_Nod)); 13383 end if; 13384 13385 -- This call added to ensure that the constraint is analyzed 13386 -- (needed for a B test). Note that we still return early from 13387 -- this procedure to avoid recursive processing. 13388 13389 Constrain_Discriminated_Type 13390 (Desig_Subtype, S, Related_Nod, For_Access => True); 13391 return; 13392 end if; 13393 13394 -- Enforce rule that the constraint is illegal if there is an 13395 -- unconstrained view of the designated type. This means that the 13396 -- partial view (either a private type declaration or a derivation 13397 -- from a private type) has no discriminants. (Defect Report 13398 -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001). 13399 13400 -- Rule updated for Ada 2005: The private type is said to have 13401 -- a constrained partial view, given that objects of the type 13402 -- can be declared. Furthermore, the rule applies to all access 13403 -- types, unlike the rule concerning default discriminants (see 13404 -- RM 3.7.1(7/3)) 13405 13406 if (Ekind (T) = E_General_Access_Type or else Ada_Version >= Ada_2005) 13407 and then Has_Private_Declaration (Desig_Type) 13408 and then In_Open_Scopes (Scope (Desig_Type)) 13409 and then Has_Discriminants (Desig_Type) 13410 then 13411 declare 13412 Pack : constant Node_Id := 13413 Unit_Declaration_Node (Scope (Desig_Type)); 13414 Decls : List_Id; 13415 Decl : Node_Id; 13416 13417 begin 13418 if Nkind (Pack) = N_Package_Declaration then 13419 Decls := Visible_Declarations (Specification (Pack)); 13420 Decl := First (Decls); 13421 while Present (Decl) loop 13422 if (Nkind (Decl) = N_Private_Type_Declaration 13423 and then Chars (Defining_Identifier (Decl)) = 13424 Chars (Desig_Type)) 13425 13426 or else 13427 (Nkind (Decl) = N_Full_Type_Declaration 13428 and then 13429 Chars (Defining_Identifier (Decl)) = 13430 Chars (Desig_Type) 13431 and then Is_Derived_Type (Desig_Type) 13432 and then 13433 Has_Private_Declaration (Etype (Desig_Type))) 13434 then 13435 if No (Discriminant_Specifications (Decl)) then 13436 Error_Msg_N 13437 ("cannot constrain access type if designated " 13438 & "type has constrained partial view", S); 13439 end if; 13440 13441 exit; 13442 end if; 13443 13444 Next (Decl); 13445 end loop; 13446 end if; 13447 end; 13448 end if; 13449 13450 Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, 13451 For_Access => True); 13452 13453 elsif Is_Concurrent_Type (Desig_Type) 13454 and then not Is_Constrained (Desig_Type) 13455 then 13456 Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' '); 13457 13458 else 13459 Error_Msg_N ("invalid constraint on access type", S); 13460 13461 -- We simply ignore an invalid constraint 13462 13463 Desig_Subtype := Desig_Type; 13464 Constraint_OK := False; 13465 end if; 13466 13467 if No (Def_Id) then 13468 Def_Id := Create_Itype (E_Access_Subtype, Related_Nod); 13469 else 13470 Mutate_Ekind (Def_Id, E_Access_Subtype); 13471 end if; 13472 13473 if Constraint_OK then 13474 Set_Etype (Def_Id, Base_Type (T)); 13475 13476 if Is_Private_Type (Desig_Type) then 13477 Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod); 13478 end if; 13479 else 13480 Set_Etype (Def_Id, Any_Type); 13481 end if; 13482 13483 Set_Size_Info (Def_Id, T); 13484 Set_Is_Constrained (Def_Id, Constraint_OK); 13485 Set_Directly_Designated_Type (Def_Id, Desig_Subtype); 13486 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 13487 Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T)); 13488 13489 Conditional_Delay (Def_Id, T); 13490 13491 -- AI-363 : Subtypes of general access types whose designated types have 13492 -- default discriminants are disallowed. In instances, the rule has to 13493 -- be checked against the actual, of which T is the subtype. In a 13494 -- generic body, the rule is checked assuming that the actual type has 13495 -- defaulted discriminants. 13496 13497 if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then 13498 if Ekind (Base_Type (T)) = E_General_Access_Type 13499 and then Has_Defaulted_Discriminants (Desig_Type) 13500 then 13501 if Ada_Version < Ada_2005 then 13502 Error_Msg_N 13503 ("access subtype of general access type would not " & 13504 "be allowed in Ada 2005?y?", S); 13505 else 13506 Error_Msg_N 13507 ("access subtype of general access type not allowed", S); 13508 end if; 13509 13510 Error_Msg_N ("\discriminants have defaults", S); 13511 13512 elsif Is_Access_Type (T) 13513 and then Is_Generic_Type (Desig_Type) 13514 and then Has_Discriminants (Desig_Type) 13515 and then In_Package_Body (Current_Scope) 13516 then 13517 if Ada_Version < Ada_2005 then 13518 Error_Msg_N 13519 ("access subtype would not be allowed in generic body " 13520 & "in Ada 2005?y?", S); 13521 else 13522 Error_Msg_N 13523 ("access subtype not allowed in generic body", S); 13524 end if; 13525 13526 Error_Msg_N 13527 ("\designated type is a discriminated formal", S); 13528 end if; 13529 end if; 13530 end Constrain_Access; 13531 13532 --------------------- 13533 -- Constrain_Array -- 13534 --------------------- 13535 13536 procedure Constrain_Array 13537 (Def_Id : in out Entity_Id; 13538 SI : Node_Id; 13539 Related_Nod : Node_Id; 13540 Related_Id : Entity_Id; 13541 Suffix : Character) 13542 is 13543 C : constant Node_Id := Constraint (SI); 13544 Number_Of_Constraints : Nat := 0; 13545 Index : Node_Id; 13546 S, T : Entity_Id; 13547 Constraint_OK : Boolean := True; 13548 Is_FLB_Array_Subtype : Boolean := False; 13549 13550 begin 13551 T := Entity (Subtype_Mark (SI)); 13552 13553 if Is_Access_Type (T) then 13554 T := Designated_Type (T); 13555 end if; 13556 13557 -- If an index constraint follows a subtype mark in a subtype indication 13558 -- then the type or subtype denoted by the subtype mark must not already 13559 -- impose an index constraint. The subtype mark must denote either an 13560 -- unconstrained array type or an access type whose designated type 13561 -- is such an array type... (RM 3.6.1) 13562 13563 if Is_Constrained (T) then 13564 Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); 13565 Constraint_OK := False; 13566 13567 else 13568 S := First (Constraints (C)); 13569 while Present (S) loop 13570 Number_Of_Constraints := Number_Of_Constraints + 1; 13571 Next (S); 13572 end loop; 13573 13574 -- In either case, the index constraint must provide a discrete 13575 -- range for each index of the array type and the type of each 13576 -- discrete range must be the same as that of the corresponding 13577 -- index. (RM 3.6.1) 13578 13579 if Number_Of_Constraints /= Number_Dimensions (T) then 13580 Error_Msg_NE ("incorrect number of index constraints for }", C, T); 13581 Constraint_OK := False; 13582 13583 else 13584 S := First (Constraints (C)); 13585 Index := First_Index (T); 13586 Analyze (Index); 13587 13588 -- Apply constraints to each index type 13589 13590 for J in 1 .. Number_Of_Constraints loop 13591 Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J); 13592 13593 -- If the subtype of the index has been set to indicate that 13594 -- it has a fixed lower bound, then record that the subtype's 13595 -- entity will need to be marked as being a fixed-lower-bound 13596 -- array subtype. 13597 13598 if S = First (Constraints (C)) then 13599 Is_FLB_Array_Subtype := 13600 Is_Fixed_Lower_Bound_Index_Subtype (Etype (S)); 13601 13602 -- If the parent subtype (or should this be Etype of that?) 13603 -- is an FLB array subtype, we flag an error, because we 13604 -- don't currently allow subtypes of such subtypes to 13605 -- specify a fixed lower bound for any of their indexes, 13606 -- even if the index of the parent subtype is a "range <>" 13607 -- index. 13608 13609 if Is_FLB_Array_Subtype 13610 and then Is_Fixed_Lower_Bound_Array_Subtype (T) 13611 then 13612 Error_Msg_NE 13613 ("index with fixed lower bound not allowed for subtype " 13614 & "of fixed-lower-bound }", S, T); 13615 13616 Is_FLB_Array_Subtype := False; 13617 end if; 13618 13619 elsif Is_FLB_Array_Subtype 13620 and then not Is_Fixed_Lower_Bound_Index_Subtype (Etype (S)) 13621 then 13622 Error_Msg_NE 13623 ("constrained index not allowed for fixed-lower-bound " 13624 & "subtype of}", S, T); 13625 13626 elsif not Is_FLB_Array_Subtype 13627 and then Is_Fixed_Lower_Bound_Index_Subtype (Etype (S)) 13628 then 13629 Error_Msg_NE 13630 ("index with fixed lower bound not allowed for " 13631 & "constrained subtype of}", S, T); 13632 end if; 13633 13634 Next (Index); 13635 Next (S); 13636 end loop; 13637 13638 end if; 13639 end if; 13640 13641 if No (Def_Id) then 13642 Def_Id := 13643 Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix); 13644 Set_Parent (Def_Id, Related_Nod); 13645 13646 else 13647 Mutate_Ekind (Def_Id, E_Array_Subtype); 13648 end if; 13649 13650 Set_Size_Info (Def_Id, (T)); 13651 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 13652 Set_Etype (Def_Id, Base_Type (T)); 13653 13654 if Constraint_OK then 13655 Set_First_Index (Def_Id, First (Constraints (C))); 13656 else 13657 Set_First_Index (Def_Id, First_Index (T)); 13658 end if; 13659 13660 Set_Is_Constrained (Def_Id, not Is_FLB_Array_Subtype); 13661 Set_Is_Fixed_Lower_Bound_Array_Subtype 13662 (Def_Id, Is_FLB_Array_Subtype); 13663 Set_Is_Aliased (Def_Id, Is_Aliased (T)); 13664 Set_Is_Independent (Def_Id, Is_Independent (T)); 13665 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 13666 13667 Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T)); 13668 Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T)); 13669 13670 -- A subtype does not inherit the Packed_Array_Impl_Type of is parent. 13671 -- We need to initialize the attribute because if Def_Id is previously 13672 -- analyzed through a limited_with clause, it will have the attributes 13673 -- of an incomplete type, one of which is an Elist that overlaps the 13674 -- Packed_Array_Impl_Type field. 13675 13676 Set_Packed_Array_Impl_Type (Def_Id, Empty); 13677 13678 -- Build a freeze node if parent still needs one. Also make sure that 13679 -- the Depends_On_Private status is set because the subtype will need 13680 -- reprocessing at the time the base type does, and also we must set a 13681 -- conditional delay. 13682 13683 Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); 13684 Conditional_Delay (Def_Id, T); 13685 end Constrain_Array; 13686 13687 ------------------------------ 13688 -- Constrain_Component_Type -- 13689 ------------------------------ 13690 13691 function Constrain_Component_Type 13692 (Comp : Entity_Id; 13693 Constrained_Typ : Entity_Id; 13694 Related_Node : Node_Id; 13695 Typ : Entity_Id; 13696 Constraints : Elist_Id) return Entity_Id 13697 is 13698 Loc : constant Source_Ptr := Sloc (Constrained_Typ); 13699 Compon_Type : constant Entity_Id := Etype (Comp); 13700 13701 function Build_Constrained_Array_Type 13702 (Old_Type : Entity_Id) return Entity_Id; 13703 -- If Old_Type is an array type, one of whose indexes is constrained 13704 -- by a discriminant, build an Itype whose constraint replaces the 13705 -- discriminant with its value in the constraint. 13706 13707 function Build_Constrained_Discriminated_Type 13708 (Old_Type : Entity_Id) return Entity_Id; 13709 -- Ditto for record components. Handle the case where the constraint 13710 -- is a conversion of the discriminant value, introduced during 13711 -- expansion. 13712 13713 function Build_Constrained_Access_Type 13714 (Old_Type : Entity_Id) return Entity_Id; 13715 -- Ditto for access types. Makes use of previous two functions, to 13716 -- constrain designated type. 13717 13718 function Is_Discriminant (Expr : Node_Id) return Boolean; 13719 -- Returns True if Expr is a discriminant 13720 13721 function Get_Discr_Value (Discr_Expr : Node_Id) return Node_Id; 13722 -- Find the value of a discriminant named by Discr_Expr in Constraints 13723 13724 ----------------------------------- 13725 -- Build_Constrained_Access_Type -- 13726 ----------------------------------- 13727 13728 function Build_Constrained_Access_Type 13729 (Old_Type : Entity_Id) return Entity_Id 13730 is 13731 Desig_Type : constant Entity_Id := Designated_Type (Old_Type); 13732 Itype : Entity_Id; 13733 Desig_Subtype : Entity_Id; 13734 Scop : Entity_Id; 13735 13736 begin 13737 -- If the original access type was not embedded in the enclosing 13738 -- type definition, there is no need to produce a new access 13739 -- subtype. In fact every access type with an explicit constraint 13740 -- generates an itype whose scope is the enclosing record. 13741 13742 if not Is_Type (Scope (Old_Type)) then 13743 return Old_Type; 13744 13745 elsif Is_Array_Type (Desig_Type) then 13746 Desig_Subtype := Build_Constrained_Array_Type (Desig_Type); 13747 13748 elsif Has_Discriminants (Desig_Type) then 13749 13750 -- This may be an access type to an enclosing record type for 13751 -- which we are constructing the constrained components. Return 13752 -- the enclosing record subtype. This is not always correct, 13753 -- but avoids infinite recursion. ??? 13754 13755 Desig_Subtype := Any_Type; 13756 13757 for J in reverse 0 .. Scope_Stack.Last loop 13758 Scop := Scope_Stack.Table (J).Entity; 13759 13760 if Is_Type (Scop) 13761 and then Base_Type (Scop) = Base_Type (Desig_Type) 13762 then 13763 Desig_Subtype := Scop; 13764 end if; 13765 13766 exit when not Is_Type (Scop); 13767 end loop; 13768 13769 if Desig_Subtype = Any_Type then 13770 Desig_Subtype := 13771 Build_Constrained_Discriminated_Type (Desig_Type); 13772 end if; 13773 13774 else 13775 return Old_Type; 13776 end if; 13777 13778 if Desig_Subtype /= Desig_Type then 13779 13780 -- The Related_Node better be here or else we won't be able 13781 -- to attach new itypes to a node in the tree. 13782 13783 pragma Assert (Present (Related_Node)); 13784 13785 Itype := Create_Itype (E_Access_Subtype, Related_Node); 13786 13787 Set_Etype (Itype, Base_Type (Old_Type)); 13788 Set_Size_Info (Itype, (Old_Type)); 13789 Set_Directly_Designated_Type (Itype, Desig_Subtype); 13790 Set_Depends_On_Private (Itype, Has_Private_Component 13791 (Old_Type)); 13792 Set_Is_Access_Constant (Itype, Is_Access_Constant 13793 (Old_Type)); 13794 13795 -- The new itype needs freezing when it depends on a not frozen 13796 -- type and the enclosing subtype needs freezing. 13797 13798 if Has_Delayed_Freeze (Constrained_Typ) 13799 and then not Is_Frozen (Constrained_Typ) 13800 then 13801 Conditional_Delay (Itype, Base_Type (Old_Type)); 13802 end if; 13803 13804 return Itype; 13805 13806 else 13807 return Old_Type; 13808 end if; 13809 end Build_Constrained_Access_Type; 13810 13811 ---------------------------------- 13812 -- Build_Constrained_Array_Type -- 13813 ---------------------------------- 13814 13815 function Build_Constrained_Array_Type 13816 (Old_Type : Entity_Id) return Entity_Id 13817 is 13818 Lo_Expr : Node_Id; 13819 Hi_Expr : Node_Id; 13820 Old_Index : Node_Id; 13821 Range_Node : Node_Id; 13822 Constr_List : List_Id; 13823 13824 Need_To_Create_Itype : Boolean := False; 13825 13826 begin 13827 Old_Index := First_Index (Old_Type); 13828 while Present (Old_Index) loop 13829 Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); 13830 13831 if Is_Discriminant (Lo_Expr) 13832 or else 13833 Is_Discriminant (Hi_Expr) 13834 then 13835 Need_To_Create_Itype := True; 13836 exit; 13837 end if; 13838 13839 Next_Index (Old_Index); 13840 end loop; 13841 13842 if Need_To_Create_Itype then 13843 Constr_List := New_List; 13844 13845 Old_Index := First_Index (Old_Type); 13846 while Present (Old_Index) loop 13847 Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); 13848 13849 if Is_Discriminant (Lo_Expr) then 13850 Lo_Expr := Get_Discr_Value (Lo_Expr); 13851 end if; 13852 13853 if Is_Discriminant (Hi_Expr) then 13854 Hi_Expr := Get_Discr_Value (Hi_Expr); 13855 end if; 13856 13857 Range_Node := 13858 Make_Range 13859 (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr)); 13860 13861 Append (Range_Node, To => Constr_List); 13862 13863 Next_Index (Old_Index); 13864 end loop; 13865 13866 return Build_Subtype (Related_Node, Loc, Old_Type, Constr_List); 13867 13868 else 13869 return Old_Type; 13870 end if; 13871 end Build_Constrained_Array_Type; 13872 13873 ------------------------------------------ 13874 -- Build_Constrained_Discriminated_Type -- 13875 ------------------------------------------ 13876 13877 function Build_Constrained_Discriminated_Type 13878 (Old_Type : Entity_Id) return Entity_Id 13879 is 13880 Expr : Node_Id; 13881 Constr_List : List_Id; 13882 Old_Constraint : Elmt_Id; 13883 13884 Need_To_Create_Itype : Boolean := False; 13885 13886 begin 13887 Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); 13888 while Present (Old_Constraint) loop 13889 Expr := Node (Old_Constraint); 13890 13891 if Is_Discriminant (Expr) then 13892 Need_To_Create_Itype := True; 13893 exit; 13894 13895 -- After expansion of discriminated task types, the value 13896 -- of the discriminant may be converted to a run-time type 13897 -- for restricted run-times. Propagate the value of the 13898 -- discriminant as well, so that e.g. the secondary stack 13899 -- component has a static constraint. Necessary for LLVM. 13900 13901 elsif Nkind (Expr) = N_Type_Conversion 13902 and then Is_Discriminant (Expression (Expr)) 13903 then 13904 Need_To_Create_Itype := True; 13905 exit; 13906 end if; 13907 13908 Next_Elmt (Old_Constraint); 13909 end loop; 13910 13911 if Need_To_Create_Itype then 13912 Constr_List := New_List; 13913 13914 Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); 13915 while Present (Old_Constraint) loop 13916 Expr := Node (Old_Constraint); 13917 13918 if Is_Discriminant (Expr) then 13919 Expr := Get_Discr_Value (Expr); 13920 13921 elsif Nkind (Expr) = N_Type_Conversion 13922 and then Is_Discriminant (Expression (Expr)) 13923 then 13924 Expr := New_Copy_Tree (Expr); 13925 Set_Expression (Expr, Get_Discr_Value (Expression (Expr))); 13926 end if; 13927 13928 Append (New_Copy_Tree (Expr), To => Constr_List); 13929 13930 Next_Elmt (Old_Constraint); 13931 end loop; 13932 13933 return Build_Subtype (Related_Node, Loc, Old_Type, Constr_List); 13934 13935 else 13936 return Old_Type; 13937 end if; 13938 end Build_Constrained_Discriminated_Type; 13939 13940 --------------------- 13941 -- Get_Discr_Value -- 13942 --------------------- 13943 13944 function Get_Discr_Value (Discr_Expr : Node_Id) return Node_Id is 13945 Discr_Id : constant Entity_Id := Entity (Discr_Expr); 13946 -- Entity of a discriminant that appear as a standalone expression in 13947 -- the constraint of a component. 13948 13949 D : Entity_Id; 13950 E : Elmt_Id; 13951 13952 begin 13953 -- The discriminant may be declared for the type, in which case we 13954 -- find it by iterating over the list of discriminants. If the 13955 -- discriminant is inherited from a parent type, it appears as the 13956 -- corresponding discriminant of the current type. This will be the 13957 -- case when constraining an inherited component whose constraint is 13958 -- given by a discriminant of the parent. 13959 13960 D := First_Discriminant (Typ); 13961 E := First_Elmt (Constraints); 13962 13963 while Present (D) loop 13964 if D = Discr_Id 13965 or else D = CR_Discriminant (Discr_Id) 13966 or else Corresponding_Discriminant (D) = Discr_Id 13967 then 13968 return Node (E); 13969 end if; 13970 13971 Next_Discriminant (D); 13972 Next_Elmt (E); 13973 end loop; 13974 13975 -- The Corresponding_Discriminant mechanism is incomplete, because 13976 -- the correspondence between new and old discriminants is not one 13977 -- to one: one new discriminant can constrain several old ones. In 13978 -- that case, scan sequentially the stored_constraint, the list of 13979 -- discriminants of the parents, and the constraints. 13980 13981 -- Previous code checked for the present of the Stored_Constraint 13982 -- list for the derived type, but did not use it at all. Should it 13983 -- be present when the component is a discriminated task type? 13984 13985 if Is_Derived_Type (Typ) 13986 and then Scope (Discr_Id) = Etype (Typ) 13987 then 13988 D := First_Discriminant (Etype (Typ)); 13989 E := First_Elmt (Constraints); 13990 while Present (D) loop 13991 if D = Discr_Id then 13992 return Node (E); 13993 end if; 13994 13995 Next_Discriminant (D); 13996 Next_Elmt (E); 13997 end loop; 13998 end if; 13999 14000 -- Something is wrong if we did not find the value 14001 14002 raise Program_Error; 14003 end Get_Discr_Value; 14004 14005 --------------------- 14006 -- Is_Discriminant -- 14007 --------------------- 14008 14009 function Is_Discriminant (Expr : Node_Id) return Boolean is 14010 Discrim_Scope : Entity_Id; 14011 14012 begin 14013 if Denotes_Discriminant (Expr) then 14014 Discrim_Scope := Scope (Entity (Expr)); 14015 14016 -- Either we have a reference to one of Typ's discriminants, 14017 14018 pragma Assert (Discrim_Scope = Typ 14019 14020 -- or to the discriminants of the parent type, in the case 14021 -- of a derivation of a tagged type with variants. 14022 14023 or else Discrim_Scope = Etype (Typ) 14024 or else Full_View (Discrim_Scope) = Etype (Typ) 14025 14026 -- or same as above for the case where the discriminants 14027 -- were declared in Typ's private view. 14028 14029 or else (Is_Private_Type (Discrim_Scope) 14030 and then Chars (Discrim_Scope) = Chars (Typ)) 14031 14032 -- or else we are deriving from the full view and the 14033 -- discriminant is declared in the private entity. 14034 14035 or else (Is_Private_Type (Typ) 14036 and then Chars (Discrim_Scope) = Chars (Typ)) 14037 14038 -- Or we are constrained the corresponding record of a 14039 -- synchronized type that completes a private declaration. 14040 14041 or else (Is_Concurrent_Record_Type (Typ) 14042 and then 14043 Corresponding_Concurrent_Type (Typ) = Discrim_Scope) 14044 14045 -- or we have a class-wide type, in which case make sure the 14046 -- discriminant found belongs to the root type. 14047 14048 or else (Is_Class_Wide_Type (Typ) 14049 and then Etype (Typ) = Discrim_Scope)); 14050 14051 return True; 14052 end if; 14053 14054 -- In all other cases we have something wrong 14055 14056 return False; 14057 end Is_Discriminant; 14058 14059 -- Start of processing for Constrain_Component_Type 14060 14061 begin 14062 if Nkind (Parent (Comp)) = N_Component_Declaration 14063 and then Comes_From_Source (Parent (Comp)) 14064 and then Comes_From_Source 14065 (Subtype_Indication (Component_Definition (Parent (Comp)))) 14066 and then 14067 Is_Entity_Name 14068 (Subtype_Indication (Component_Definition (Parent (Comp)))) 14069 then 14070 return Compon_Type; 14071 14072 elsif Is_Array_Type (Compon_Type) then 14073 return Build_Constrained_Array_Type (Compon_Type); 14074 14075 elsif Has_Discriminants (Compon_Type) then 14076 return Build_Constrained_Discriminated_Type (Compon_Type); 14077 14078 elsif Is_Access_Type (Compon_Type) then 14079 return Build_Constrained_Access_Type (Compon_Type); 14080 14081 else 14082 return Compon_Type; 14083 end if; 14084 end Constrain_Component_Type; 14085 14086 -------------------------- 14087 -- Constrain_Concurrent -- 14088 -------------------------- 14089 14090 -- For concurrent types, the associated record value type carries the same 14091 -- discriminants, so when we constrain a concurrent type, we must constrain 14092 -- the corresponding record type as well. 14093 14094 procedure Constrain_Concurrent 14095 (Def_Id : in out Entity_Id; 14096 SI : Node_Id; 14097 Related_Nod : Node_Id; 14098 Related_Id : Entity_Id; 14099 Suffix : Character) 14100 is 14101 -- Retrieve Base_Type to ensure getting to the concurrent type in the 14102 -- case of a private subtype (needed when only doing semantic analysis). 14103 14104 T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI))); 14105 T_Val : Entity_Id; 14106 14107 begin 14108 if Is_Access_Type (T_Ent) then 14109 T_Ent := Designated_Type (T_Ent); 14110 end if; 14111 14112 T_Val := Corresponding_Record_Type (T_Ent); 14113 14114 if Present (T_Val) then 14115 14116 if No (Def_Id) then 14117 Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 14118 14119 -- Elaborate itype now, as it may be used in a subsequent 14120 -- synchronized operation in another scope. 14121 14122 if Nkind (Related_Nod) = N_Full_Type_Declaration then 14123 Build_Itype_Reference (Def_Id, Related_Nod); 14124 end if; 14125 end if; 14126 14127 Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); 14128 Set_First_Private_Entity (Def_Id, First_Private_Entity (T_Ent)); 14129 14130 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 14131 Set_Corresponding_Record_Type (Def_Id, 14132 Constrain_Corresponding_Record (Def_Id, T_Val, Related_Nod)); 14133 14134 else 14135 -- If there is no associated record, expansion is disabled and this 14136 -- is a generic context. Create a subtype in any case, so that 14137 -- semantic analysis can proceed. 14138 14139 if No (Def_Id) then 14140 Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 14141 end if; 14142 14143 Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); 14144 end if; 14145 end Constrain_Concurrent; 14146 14147 ------------------------------------ 14148 -- Constrain_Corresponding_Record -- 14149 ------------------------------------ 14150 14151 function Constrain_Corresponding_Record 14152 (Prot_Subt : Entity_Id; 14153 Corr_Rec : Entity_Id; 14154 Related_Nod : Node_Id) return Entity_Id 14155 is 14156 T_Sub : constant Entity_Id := 14157 Create_Itype 14158 (Ekind => E_Record_Subtype, 14159 Related_Nod => Related_Nod, 14160 Related_Id => Corr_Rec, 14161 Suffix => 'C', 14162 Suffix_Index => -1); 14163 14164 begin 14165 Set_Etype (T_Sub, Corr_Rec); 14166 Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt)); 14167 Set_Is_Tagged_Type (T_Sub, Is_Tagged_Type (Corr_Rec)); 14168 Set_Is_Constrained (T_Sub, True); 14169 Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); 14170 Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec)); 14171 14172 if Has_Discriminants (Prot_Subt) then -- False only if errors. 14173 Set_Discriminant_Constraint 14174 (T_Sub, Discriminant_Constraint (Prot_Subt)); 14175 Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub); 14176 Create_Constrained_Components 14177 (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub)); 14178 end if; 14179 14180 Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub)); 14181 14182 if Ekind (Scope (Prot_Subt)) /= E_Record_Type then 14183 Conditional_Delay (T_Sub, Corr_Rec); 14184 14185 else 14186 -- This is a component subtype: it will be frozen in the context of 14187 -- the enclosing record's init_proc, so that discriminant references 14188 -- are resolved to discriminals. (Note: we used to skip freezing 14189 -- altogether in that case, which caused errors downstream for 14190 -- components of a bit packed array type). 14191 14192 Set_Has_Delayed_Freeze (T_Sub); 14193 end if; 14194 14195 return T_Sub; 14196 end Constrain_Corresponding_Record; 14197 14198 ----------------------- 14199 -- Constrain_Decimal -- 14200 ----------------------- 14201 14202 procedure Constrain_Decimal (Def_Id : Entity_Id; S : Node_Id) is 14203 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14204 C : constant Node_Id := Constraint (S); 14205 Loc : constant Source_Ptr := Sloc (C); 14206 Range_Expr : Node_Id; 14207 Digits_Expr : Node_Id; 14208 Digits_Val : Uint; 14209 Bound_Val : Ureal; 14210 14211 begin 14212 Mutate_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype); 14213 14214 if Nkind (C) = N_Range_Constraint then 14215 Range_Expr := Range_Expression (C); 14216 Digits_Val := Digits_Value (T); 14217 14218 else 14219 pragma Assert (Nkind (C) = N_Digits_Constraint); 14220 14221 Digits_Expr := Digits_Expression (C); 14222 Analyze_And_Resolve (Digits_Expr, Any_Integer); 14223 14224 Check_Digits_Expression (Digits_Expr); 14225 Digits_Val := Expr_Value (Digits_Expr); 14226 14227 if Digits_Val > Digits_Value (T) then 14228 Error_Msg_N 14229 ("digits expression is incompatible with subtype", C); 14230 Digits_Val := Digits_Value (T); 14231 end if; 14232 14233 if Present (Range_Constraint (C)) then 14234 Range_Expr := Range_Expression (Range_Constraint (C)); 14235 else 14236 Range_Expr := Empty; 14237 end if; 14238 end if; 14239 14240 Set_Etype (Def_Id, Base_Type (T)); 14241 Set_Size_Info (Def_Id, (T)); 14242 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14243 Set_Delta_Value (Def_Id, Delta_Value (T)); 14244 Set_Scale_Value (Def_Id, Scale_Value (T)); 14245 Set_Small_Value (Def_Id, Small_Value (T)); 14246 Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T)); 14247 Set_Digits_Value (Def_Id, Digits_Val); 14248 14249 -- Manufacture range from given digits value if no range present 14250 14251 if No (Range_Expr) then 14252 Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T); 14253 Range_Expr := 14254 Make_Range (Loc, 14255 Low_Bound => 14256 Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))), 14257 High_Bound => 14258 Convert_To (T, Make_Real_Literal (Loc, Bound_Val))); 14259 end if; 14260 14261 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T); 14262 Set_Discrete_RM_Size (Def_Id); 14263 14264 -- Unconditionally delay the freeze, since we cannot set size 14265 -- information in all cases correctly until the freeze point. 14266 14267 Set_Has_Delayed_Freeze (Def_Id); 14268 end Constrain_Decimal; 14269 14270 ---------------------------------- 14271 -- Constrain_Discriminated_Type -- 14272 ---------------------------------- 14273 14274 procedure Constrain_Discriminated_Type 14275 (Def_Id : Entity_Id; 14276 S : Node_Id; 14277 Related_Nod : Node_Id; 14278 For_Access : Boolean := False) 14279 is 14280 E : Entity_Id := Entity (Subtype_Mark (S)); 14281 T : Entity_Id; 14282 14283 procedure Fixup_Bad_Constraint; 14284 -- Called after finding a bad constraint, and after having posted an 14285 -- appropriate error message. The goal is to leave type Def_Id in as 14286 -- reasonable state as possible. 14287 14288 -------------------------- 14289 -- Fixup_Bad_Constraint -- 14290 -------------------------- 14291 14292 procedure Fixup_Bad_Constraint is 14293 begin 14294 -- Set a reasonable Ekind for the entity, including incomplete types. 14295 14296 Mutate_Ekind (Def_Id, Subtype_Kind (Ekind (T))); 14297 14298 -- Set Etype to the known type, to reduce chances of cascaded errors 14299 14300 Set_Etype (Def_Id, E); 14301 Set_Error_Posted (Def_Id); 14302 end Fixup_Bad_Constraint; 14303 14304 -- Local variables 14305 14306 C : Node_Id; 14307 Constr : Elist_Id := New_Elmt_List; 14308 14309 -- Start of processing for Constrain_Discriminated_Type 14310 14311 begin 14312 C := Constraint (S); 14313 14314 -- A discriminant constraint is only allowed in a subtype indication, 14315 -- after a subtype mark. This subtype mark must denote either a type 14316 -- with discriminants, or an access type whose designated type is a 14317 -- type with discriminants. A discriminant constraint specifies the 14318 -- values of these discriminants (RM 3.7.2(5)). 14319 14320 T := Base_Type (Entity (Subtype_Mark (S))); 14321 14322 if Is_Access_Type (T) then 14323 T := Designated_Type (T); 14324 end if; 14325 14326 -- In an instance it may be necessary to retrieve the full view of a 14327 -- type with unknown discriminants, or a full view with defaulted 14328 -- discriminants. In other contexts the constraint is illegal. 14329 14330 if In_Instance 14331 and then Is_Private_Type (T) 14332 and then Present (Full_View (T)) 14333 and then 14334 (Has_Unknown_Discriminants (T) 14335 or else 14336 (not Has_Discriminants (T) 14337 and then Has_Defaulted_Discriminants (Full_View (T)))) 14338 then 14339 T := Full_View (T); 14340 E := Full_View (E); 14341 end if; 14342 14343 -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. Avoid 14344 -- generating an error for access-to-incomplete subtypes. 14345 14346 if Ada_Version >= Ada_2005 14347 and then Ekind (T) = E_Incomplete_Type 14348 and then Nkind (Parent (S)) = N_Subtype_Declaration 14349 and then not Is_Itype (Def_Id) 14350 then 14351 -- A little sanity check: emit an error message if the type has 14352 -- discriminants to begin with. Type T may be a regular incomplete 14353 -- type or imported via a limited with clause. 14354 14355 if Has_Discriminants (T) 14356 or else (From_Limited_With (T) 14357 and then Present (Non_Limited_View (T)) 14358 and then Nkind (Parent (Non_Limited_View (T))) = 14359 N_Full_Type_Declaration 14360 and then Present (Discriminant_Specifications 14361 (Parent (Non_Limited_View (T))))) 14362 then 14363 Error_Msg_N 14364 ("(Ada 2005) incomplete subtype may not be constrained", C); 14365 else 14366 Error_Msg_N ("invalid constraint: type has no discriminant", C); 14367 end if; 14368 14369 Fixup_Bad_Constraint; 14370 return; 14371 14372 -- Check that the type has visible discriminants. The type may be 14373 -- a private type with unknown discriminants whose full view has 14374 -- discriminants which are invisible. 14375 14376 elsif not Has_Discriminants (T) 14377 or else 14378 (Has_Unknown_Discriminants (T) 14379 and then Is_Private_Type (T)) 14380 then 14381 Error_Msg_N ("invalid constraint: type has no discriminant", C); 14382 Fixup_Bad_Constraint; 14383 return; 14384 14385 elsif Is_Constrained (E) 14386 or else (Ekind (E) = E_Class_Wide_Subtype 14387 and then Present (Discriminant_Constraint (E))) 14388 then 14389 Error_Msg_N ("type is already constrained", Subtype_Mark (S)); 14390 Fixup_Bad_Constraint; 14391 return; 14392 end if; 14393 14394 -- T may be an unconstrained subtype (e.g. a generic actual). Constraint 14395 -- applies to the base type. 14396 14397 T := Base_Type (T); 14398 14399 Constr := Build_Discriminant_Constraints (T, S); 14400 14401 -- If the list returned was empty we had an error in building the 14402 -- discriminant constraint. We have also already signalled an error 14403 -- in the incomplete type case 14404 14405 if Is_Empty_Elmt_List (Constr) then 14406 Fixup_Bad_Constraint; 14407 return; 14408 end if; 14409 14410 Build_Discriminated_Subtype (T, Def_Id, Constr, Related_Nod, For_Access); 14411 end Constrain_Discriminated_Type; 14412 14413 --------------------------- 14414 -- Constrain_Enumeration -- 14415 --------------------------- 14416 14417 procedure Constrain_Enumeration (Def_Id : Entity_Id; S : Node_Id) is 14418 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14419 C : constant Node_Id := Constraint (S); 14420 14421 begin 14422 Mutate_Ekind (Def_Id, E_Enumeration_Subtype); 14423 14424 Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); 14425 14426 Set_Etype (Def_Id, Base_Type (T)); 14427 Set_Size_Info (Def_Id, (T)); 14428 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14429 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 14430 14431 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 14432 14433 Set_Discrete_RM_Size (Def_Id); 14434 end Constrain_Enumeration; 14435 14436 ---------------------- 14437 -- Constrain_Float -- 14438 ---------------------- 14439 14440 procedure Constrain_Float (Def_Id : Entity_Id; S : Node_Id) is 14441 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14442 C : Node_Id; 14443 D : Node_Id; 14444 Rais : Node_Id; 14445 14446 begin 14447 Mutate_Ekind (Def_Id, E_Floating_Point_Subtype); 14448 14449 Set_Etype (Def_Id, Base_Type (T)); 14450 Set_Size_Info (Def_Id, (T)); 14451 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14452 14453 -- Process the constraint 14454 14455 C := Constraint (S); 14456 14457 -- Digits constraint present 14458 14459 if Nkind (C) = N_Digits_Constraint then 14460 Check_Restriction (No_Obsolescent_Features, C); 14461 14462 if Warn_On_Obsolescent_Feature then 14463 Error_Msg_N 14464 ("subtype digits constraint is an " & 14465 "obsolescent feature (RM J.3(8))?j?", C); 14466 end if; 14467 14468 D := Digits_Expression (C); 14469 Analyze_And_Resolve (D, Any_Integer); 14470 Check_Digits_Expression (D); 14471 Set_Digits_Value (Def_Id, Expr_Value (D)); 14472 14473 -- Check that digits value is in range. Obviously we can do this 14474 -- at compile time, but it is strictly a runtime check, and of 14475 -- course there is an ACVC test that checks this. 14476 14477 if Digits_Value (Def_Id) > Digits_Value (T) then 14478 Error_Msg_Uint_1 := Digits_Value (T); 14479 Error_Msg_N ("??digits value is too large, maximum is ^", D); 14480 Rais := 14481 Make_Raise_Constraint_Error (Sloc (D), 14482 Reason => CE_Range_Check_Failed); 14483 Insert_Action (Declaration_Node (Def_Id), Rais); 14484 end if; 14485 14486 C := Range_Constraint (C); 14487 14488 -- No digits constraint present 14489 14490 else 14491 Set_Digits_Value (Def_Id, Digits_Value (T)); 14492 end if; 14493 14494 -- Range constraint present 14495 14496 if Nkind (C) = N_Range_Constraint then 14497 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 14498 14499 -- No range constraint present 14500 14501 else 14502 pragma Assert (No (C)); 14503 Set_Scalar_Range (Def_Id, Scalar_Range (T)); 14504 end if; 14505 14506 Set_Is_Constrained (Def_Id); 14507 end Constrain_Float; 14508 14509 --------------------- 14510 -- Constrain_Index -- 14511 --------------------- 14512 14513 procedure Constrain_Index 14514 (Index : Node_Id; 14515 S : Node_Id; 14516 Related_Nod : Node_Id; 14517 Related_Id : Entity_Id; 14518 Suffix : Character; 14519 Suffix_Index : Pos) 14520 is 14521 Def_Id : Entity_Id; 14522 R : Node_Id := Empty; 14523 T : constant Entity_Id := Etype (Index); 14524 Is_FLB_Index : Boolean := False; 14525 14526 begin 14527 Def_Id := 14528 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index); 14529 Set_Etype (Def_Id, Base_Type (T)); 14530 14531 if Nkind (S) = N_Range 14532 or else 14533 (Nkind (S) = N_Attribute_Reference 14534 and then Attribute_Name (S) = Name_Range) 14535 then 14536 -- A Range attribute will be transformed into N_Range by Resolve 14537 14538 -- If a range has an Empty upper bound, then remember that for later 14539 -- setting of the index subtype's Is_Fixed_Lower_Bound_Index_Subtype 14540 -- flag, and also set the upper bound of the range to the index 14541 -- subtype's upper bound rather than leaving it Empty. In truth, 14542 -- that upper bound corresponds to a box ("<>"), but it's convenient 14543 -- to set it to the upper bound to avoid needing to add special tests 14544 -- in various places for an Empty upper bound, and in any case it 14545 -- accurately characterizes the index's range of values. 14546 14547 if Nkind (S) = N_Range and then not Present (High_Bound (S)) then 14548 Is_FLB_Index := True; 14549 Set_High_Bound (S, Type_High_Bound (T)); 14550 end if; 14551 14552 R := S; 14553 14554 Process_Range_Expr_In_Decl (R, T); 14555 14556 if not Error_Posted (S) 14557 and then 14558 (Nkind (S) /= N_Range 14559 or else not Covers (T, (Etype (Low_Bound (S)))) 14560 or else not Covers (T, (Etype (High_Bound (S))))) 14561 then 14562 if Base_Type (T) /= Any_Type 14563 and then Etype (Low_Bound (S)) /= Any_Type 14564 and then Etype (High_Bound (S)) /= Any_Type 14565 then 14566 Error_Msg_N ("range expected", S); 14567 end if; 14568 end if; 14569 14570 elsif Nkind (S) = N_Subtype_Indication then 14571 14572 -- The parser has verified that this is a discrete indication 14573 14574 Resolve_Discrete_Subtype_Indication (S, T); 14575 Bad_Predicated_Subtype_Use 14576 ("subtype& has predicate, not allowed in index constraint", 14577 S, Entity (Subtype_Mark (S))); 14578 14579 R := Range_Expression (Constraint (S)); 14580 14581 -- Capture values of bounds and generate temporaries for them if 14582 -- needed, since checks may cause duplication of the expressions 14583 -- which must not be reevaluated. 14584 14585 -- The forced evaluation removes side effects from expressions, which 14586 -- should occur also in GNATprove mode. Otherwise, we end up with 14587 -- unexpected insertions of actions at places where this is not 14588 -- supposed to occur, e.g. on default parameters of a call. 14589 14590 if Expander_Active or GNATprove_Mode then 14591 Force_Evaluation 14592 (Low_Bound (R), Related_Id => Def_Id, Is_Low_Bound => True); 14593 Force_Evaluation 14594 (High_Bound (R), Related_Id => Def_Id, Is_High_Bound => True); 14595 end if; 14596 14597 elsif Nkind (S) = N_Discriminant_Association then 14598 14599 -- Syntactically valid in subtype indication 14600 14601 Error_Msg_N ("invalid index constraint", S); 14602 Rewrite (S, New_Occurrence_Of (T, Sloc (S))); 14603 return; 14604 14605 -- Subtype_Mark case, no anonymous subtypes to construct 14606 14607 else 14608 Analyze (S); 14609 14610 if Is_Entity_Name (S) then 14611 if not Is_Type (Entity (S)) then 14612 Error_Msg_N ("expect subtype mark for index constraint", S); 14613 14614 elsif Base_Type (Entity (S)) /= Base_Type (T) then 14615 Wrong_Type (S, Base_Type (T)); 14616 14617 -- Check error of subtype with predicate in index constraint 14618 14619 else 14620 Bad_Predicated_Subtype_Use 14621 ("subtype& has predicate, not allowed in index constraint", 14622 S, Entity (S)); 14623 end if; 14624 14625 return; 14626 14627 else 14628 Error_Msg_N ("invalid index constraint", S); 14629 Rewrite (S, New_Occurrence_Of (T, Sloc (S))); 14630 return; 14631 end if; 14632 end if; 14633 14634 -- Complete construction of the Itype 14635 14636 if Is_Modular_Integer_Type (T) then 14637 Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype); 14638 14639 elsif Is_Integer_Type (T) then 14640 Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype); 14641 14642 else 14643 Mutate_Ekind (Def_Id, E_Enumeration_Subtype); 14644 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 14645 Set_First_Literal (Def_Id, First_Literal (T)); 14646 end if; 14647 14648 Set_Size_Info (Def_Id, (T)); 14649 Copy_RM_Size (To => Def_Id, From => T); 14650 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14651 14652 -- If this is a range for a fixed-lower-bound subtype, then set the 14653 -- index itype's low bound to the FLB and the index itype's upper bound 14654 -- to the high bound of the parent array type's index subtype. Also, 14655 -- mark the itype as an FLB index subtype. 14656 14657 if Nkind (S) = N_Range and then Is_FLB_Index then 14658 Set_Scalar_Range 14659 (Def_Id, 14660 Make_Range (Sloc (S), 14661 Low_Bound => Low_Bound (S), 14662 High_Bound => Type_High_Bound (T))); 14663 Set_Is_Fixed_Lower_Bound_Index_Subtype (Def_Id); 14664 14665 else 14666 Set_Scalar_Range (Def_Id, R); 14667 end if; 14668 14669 Set_Etype (S, Def_Id); 14670 Set_Discrete_RM_Size (Def_Id); 14671 end Constrain_Index; 14672 14673 ----------------------- 14674 -- Constrain_Integer -- 14675 ----------------------- 14676 14677 procedure Constrain_Integer (Def_Id : Entity_Id; S : Node_Id) is 14678 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14679 C : constant Node_Id := Constraint (S); 14680 14681 begin 14682 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 14683 14684 if Is_Modular_Integer_Type (T) then 14685 Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype); 14686 else 14687 Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype); 14688 end if; 14689 14690 Set_Etype (Def_Id, Base_Type (T)); 14691 Set_Size_Info (Def_Id, (T)); 14692 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14693 Set_Discrete_RM_Size (Def_Id); 14694 end Constrain_Integer; 14695 14696 ------------------------------ 14697 -- Constrain_Ordinary_Fixed -- 14698 ------------------------------ 14699 14700 procedure Constrain_Ordinary_Fixed (Def_Id : Entity_Id; S : Node_Id) is 14701 T : constant Entity_Id := Entity (Subtype_Mark (S)); 14702 C : Node_Id; 14703 D : Node_Id; 14704 Rais : Node_Id; 14705 14706 begin 14707 Mutate_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); 14708 Set_Etype (Def_Id, Base_Type (T)); 14709 Set_Size_Info (Def_Id, (T)); 14710 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 14711 Set_Small_Value (Def_Id, Small_Value (T)); 14712 14713 -- Process the constraint 14714 14715 C := Constraint (S); 14716 14717 -- Delta constraint present 14718 14719 if Nkind (C) = N_Delta_Constraint then 14720 Check_Restriction (No_Obsolescent_Features, C); 14721 14722 if Warn_On_Obsolescent_Feature then 14723 Error_Msg_S 14724 ("subtype delta constraint is an " & 14725 "obsolescent feature (RM J.3(7))?j?"); 14726 end if; 14727 14728 D := Delta_Expression (C); 14729 Analyze_And_Resolve (D, Any_Real); 14730 Check_Delta_Expression (D); 14731 Set_Delta_Value (Def_Id, Expr_Value_R (D)); 14732 14733 -- Check that delta value is in range. Obviously we can do this 14734 -- at compile time, but it is strictly a runtime check, and of 14735 -- course there is an ACVC test that checks this. 14736 14737 if Delta_Value (Def_Id) < Delta_Value (T) then 14738 Error_Msg_N ("??delta value is too small", D); 14739 Rais := 14740 Make_Raise_Constraint_Error (Sloc (D), 14741 Reason => CE_Range_Check_Failed); 14742 Insert_Action (Declaration_Node (Def_Id), Rais); 14743 end if; 14744 14745 C := Range_Constraint (C); 14746 14747 -- No delta constraint present 14748 14749 else 14750 Set_Delta_Value (Def_Id, Delta_Value (T)); 14751 end if; 14752 14753 -- Range constraint present 14754 14755 if Nkind (C) = N_Range_Constraint then 14756 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 14757 14758 -- No range constraint present 14759 14760 else 14761 pragma Assert (No (C)); 14762 Set_Scalar_Range (Def_Id, Scalar_Range (T)); 14763 end if; 14764 14765 Set_Discrete_RM_Size (Def_Id); 14766 14767 -- Unconditionally delay the freeze, since we cannot set size 14768 -- information in all cases correctly until the freeze point. 14769 14770 Set_Has_Delayed_Freeze (Def_Id); 14771 end Constrain_Ordinary_Fixed; 14772 14773 ----------------------- 14774 -- Contain_Interface -- 14775 ----------------------- 14776 14777 function Contain_Interface 14778 (Iface : Entity_Id; 14779 Ifaces : Elist_Id) return Boolean 14780 is 14781 Iface_Elmt : Elmt_Id; 14782 14783 begin 14784 if Present (Ifaces) then 14785 Iface_Elmt := First_Elmt (Ifaces); 14786 while Present (Iface_Elmt) loop 14787 if Node (Iface_Elmt) = Iface then 14788 return True; 14789 end if; 14790 14791 Next_Elmt (Iface_Elmt); 14792 end loop; 14793 end if; 14794 14795 return False; 14796 end Contain_Interface; 14797 14798 --------------------------- 14799 -- Convert_Scalar_Bounds -- 14800 --------------------------- 14801 14802 procedure Convert_Scalar_Bounds 14803 (N : Node_Id; 14804 Parent_Type : Entity_Id; 14805 Derived_Type : Entity_Id; 14806 Loc : Source_Ptr) 14807 is 14808 Implicit_Base : constant Entity_Id := Base_Type (Derived_Type); 14809 14810 Lo : Node_Id; 14811 Hi : Node_Id; 14812 Rng : Node_Id; 14813 14814 begin 14815 -- Defend against previous errors 14816 14817 if No (Scalar_Range (Derived_Type)) then 14818 Check_Error_Detected; 14819 return; 14820 end if; 14821 14822 Lo := Build_Scalar_Bound 14823 (Type_Low_Bound (Derived_Type), 14824 Parent_Type, Implicit_Base); 14825 14826 Hi := Build_Scalar_Bound 14827 (Type_High_Bound (Derived_Type), 14828 Parent_Type, Implicit_Base); 14829 14830 Rng := 14831 Make_Range (Loc, 14832 Low_Bound => Lo, 14833 High_Bound => Hi); 14834 14835 Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type)); 14836 14837 Set_Parent (Rng, N); 14838 Set_Scalar_Range (Derived_Type, Rng); 14839 14840 -- Analyze the bounds 14841 14842 Analyze_And_Resolve (Lo, Implicit_Base); 14843 Analyze_And_Resolve (Hi, Implicit_Base); 14844 14845 -- Analyze the range itself, except that we do not analyze it if 14846 -- the bounds are real literals, and we have a fixed-point type. 14847 -- The reason for this is that we delay setting the bounds in this 14848 -- case till we know the final Small and Size values (see circuit 14849 -- in Freeze.Freeze_Fixed_Point_Type for further details). 14850 14851 if Is_Fixed_Point_Type (Parent_Type) 14852 and then Nkind (Lo) = N_Real_Literal 14853 and then Nkind (Hi) = N_Real_Literal 14854 then 14855 return; 14856 14857 -- Here we do the analysis of the range 14858 14859 -- Note: we do this manually, since if we do a normal Analyze and 14860 -- Resolve call, there are problems with the conversions used for 14861 -- the derived type range. 14862 14863 else 14864 Set_Etype (Rng, Implicit_Base); 14865 Set_Analyzed (Rng, True); 14866 end if; 14867 end Convert_Scalar_Bounds; 14868 14869 ------------------- 14870 -- Copy_And_Swap -- 14871 ------------------- 14872 14873 procedure Copy_And_Swap (Priv, Full : Entity_Id) is 14874 begin 14875 -- Initialize new full declaration entity by copying the pertinent 14876 -- fields of the corresponding private declaration entity. 14877 14878 -- We temporarily set Ekind to a value appropriate for a type to 14879 -- avoid assert failures in Einfo from checking for setting type 14880 -- attributes on something that is not a type. Ekind (Priv) is an 14881 -- appropriate choice, since it allowed the attributes to be set 14882 -- in the first place. This Ekind value will be modified later. 14883 14884 Mutate_Ekind (Full, Ekind (Priv)); 14885 14886 -- Also set Etype temporarily to Any_Type, again, in the absence 14887 -- of errors, it will be properly reset, and if there are errors, 14888 -- then we want a value of Any_Type to remain. 14889 14890 Set_Etype (Full, Any_Type); 14891 14892 -- Now start copying attributes 14893 14894 Set_Has_Discriminants (Full, Has_Discriminants (Priv)); 14895 14896 if Has_Discriminants (Full) then 14897 Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv)); 14898 Set_Stored_Constraint (Full, Stored_Constraint (Priv)); 14899 end if; 14900 14901 Set_First_Rep_Item (Full, First_Rep_Item (Priv)); 14902 Set_Homonym (Full, Homonym (Priv)); 14903 Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv)); 14904 Set_Is_Public (Full, Is_Public (Priv)); 14905 Set_Is_Pure (Full, Is_Pure (Priv)); 14906 Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); 14907 Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv)); 14908 Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); 14909 Set_Has_Pragma_Unreferenced_Objects 14910 (Full, Has_Pragma_Unreferenced_Objects 14911 (Priv)); 14912 14913 Conditional_Delay (Full, Priv); 14914 14915 if Is_Tagged_Type (Full) then 14916 Set_Direct_Primitive_Operations 14917 (Full, Direct_Primitive_Operations (Priv)); 14918 Set_No_Tagged_Streams_Pragma 14919 (Full, No_Tagged_Streams_Pragma (Priv)); 14920 14921 if Is_Base_Type (Priv) then 14922 Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); 14923 end if; 14924 end if; 14925 14926 Set_Is_Volatile (Full, Is_Volatile (Priv)); 14927 Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv)); 14928 Set_Scope (Full, Scope (Priv)); 14929 Set_Prev_Entity (Full, Prev_Entity (Priv)); 14930 Set_Next_Entity (Full, Next_Entity (Priv)); 14931 Set_First_Entity (Full, First_Entity (Priv)); 14932 Set_Last_Entity (Full, Last_Entity (Priv)); 14933 14934 -- If access types have been recorded for later handling, keep them in 14935 -- the full view so that they get handled when the full view freeze 14936 -- node is expanded. 14937 14938 if Present (Freeze_Node (Priv)) 14939 and then Present (Access_Types_To_Process (Freeze_Node (Priv))) 14940 then 14941 Ensure_Freeze_Node (Full); 14942 Set_Access_Types_To_Process 14943 (Freeze_Node (Full), 14944 Access_Types_To_Process (Freeze_Node (Priv))); 14945 end if; 14946 14947 -- Swap the two entities. Now Private is the full type entity and Full 14948 -- is the private one. They will be swapped back at the end of the 14949 -- private part. This swapping ensures that the entity that is visible 14950 -- in the private part is the full declaration. 14951 14952 Exchange_Entities (Priv, Full); 14953 Append_Entity (Full, Scope (Full)); 14954 end Copy_And_Swap; 14955 14956 ------------------------------------- 14957 -- Copy_Array_Base_Type_Attributes -- 14958 ------------------------------------- 14959 14960 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is 14961 begin 14962 Set_Component_Alignment (T1, Component_Alignment (T2)); 14963 Set_Component_Type (T1, Component_Type (T2)); 14964 Set_Component_Size (T1, Component_Size (T2)); 14965 Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); 14966 Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); 14967 Propagate_Concurrent_Flags (T1, T2); 14968 Set_Is_Packed (T1, Is_Packed (T2)); 14969 Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); 14970 Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2)); 14971 Set_Has_Independent_Components (T1, Has_Independent_Components (T2)); 14972 Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2)); 14973 end Copy_Array_Base_Type_Attributes; 14974 14975 ----------------------------------- 14976 -- Copy_Array_Subtype_Attributes -- 14977 ----------------------------------- 14978 14979 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is 14980 begin 14981 Set_Size_Info (T1, T2); 14982 14983 Set_First_Index (T1, First_Index (T2)); 14984 Set_Is_Aliased (T1, Is_Aliased (T2)); 14985 Set_Is_Atomic (T1, Is_Atomic (T2)); 14986 Set_Is_Independent (T1, Is_Independent (T2)); 14987 Set_Is_Volatile (T1, Is_Volatile (T2)); 14988 Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2)); 14989 Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); 14990 Set_Is_Constrained (T1, Is_Constrained (T2)); 14991 Set_Depends_On_Private (T1, Has_Private_Component (T2)); 14992 Inherit_Rep_Item_Chain (T1, T2); 14993 Set_Convention (T1, Convention (T2)); 14994 Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2)); 14995 Set_Is_Private_Composite (T1, Is_Private_Composite (T2)); 14996 Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2)); 14997 end Copy_Array_Subtype_Attributes; 14998 14999 ----------------------------------- 15000 -- Create_Constrained_Components -- 15001 ----------------------------------- 15002 15003 procedure Create_Constrained_Components 15004 (Subt : Entity_Id; 15005 Decl_Node : Node_Id; 15006 Typ : Entity_Id; 15007 Constraints : Elist_Id) 15008 is 15009 Loc : constant Source_Ptr := Sloc (Subt); 15010 Comp_List : constant Elist_Id := New_Elmt_List; 15011 Parent_Type : constant Entity_Id := Etype (Typ); 15012 Assoc_List : constant List_Id := New_List; 15013 15014 Discr_Val : Elmt_Id; 15015 Errors : Boolean; 15016 New_C : Entity_Id; 15017 Old_C : Entity_Id; 15018 Is_Static : Boolean := True; 15019 Is_Compile_Time_Known : Boolean := True; 15020 15021 procedure Collect_Fixed_Components (Typ : Entity_Id); 15022 -- Collect parent type components that do not appear in a variant part 15023 15024 procedure Create_All_Components; 15025 -- Iterate over Comp_List to create the components of the subtype 15026 15027 function Create_Component (Old_Compon : Entity_Id) return Entity_Id; 15028 -- Creates a new component from Old_Compon, copying all the fields from 15029 -- it, including its Etype, inserts the new component in the Subt entity 15030 -- chain and returns the new component. 15031 15032 function Is_Variant_Record (T : Entity_Id) return Boolean; 15033 -- If true, and discriminants are static, collect only components from 15034 -- variants selected by discriminant values. 15035 15036 ------------------------------ 15037 -- Collect_Fixed_Components -- 15038 ------------------------------ 15039 15040 procedure Collect_Fixed_Components (Typ : Entity_Id) is 15041 begin 15042 -- Build association list for discriminants, and find components of the 15043 -- variant part selected by the values of the discriminants. 15044 15045 Old_C := First_Discriminant (Typ); 15046 Discr_Val := First_Elmt (Constraints); 15047 while Present (Old_C) loop 15048 Append_To (Assoc_List, 15049 Make_Component_Association (Loc, 15050 Choices => New_List (New_Occurrence_Of (Old_C, Loc)), 15051 Expression => New_Copy (Node (Discr_Val)))); 15052 15053 Next_Elmt (Discr_Val); 15054 Next_Discriminant (Old_C); 15055 end loop; 15056 15057 -- The tag and the possible parent component are unconditionally in 15058 -- the subtype. 15059 15060 if Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then 15061 Old_C := First_Component (Typ); 15062 while Present (Old_C) loop 15063 if Chars (Old_C) in Name_uTag | Name_uParent then 15064 Append_Elmt (Old_C, Comp_List); 15065 end if; 15066 15067 Next_Component (Old_C); 15068 end loop; 15069 end if; 15070 end Collect_Fixed_Components; 15071 15072 --------------------------- 15073 -- Create_All_Components -- 15074 --------------------------- 15075 15076 procedure Create_All_Components is 15077 Comp : Elmt_Id; 15078 15079 begin 15080 Comp := First_Elmt (Comp_List); 15081 while Present (Comp) loop 15082 Old_C := Node (Comp); 15083 New_C := Create_Component (Old_C); 15084 15085 Set_Etype 15086 (New_C, 15087 Constrain_Component_Type 15088 (Old_C, Subt, Decl_Node, Typ, Constraints)); 15089 Set_Is_Public (New_C, Is_Public (Subt)); 15090 15091 Next_Elmt (Comp); 15092 end loop; 15093 end Create_All_Components; 15094 15095 ---------------------- 15096 -- Create_Component -- 15097 ---------------------- 15098 15099 function Create_Component (Old_Compon : Entity_Id) return Entity_Id is 15100 New_Compon : constant Entity_Id := New_Copy (Old_Compon); 15101 15102 begin 15103 if Ekind (Old_Compon) = E_Discriminant 15104 and then Is_Completely_Hidden (Old_Compon) 15105 then 15106 -- This is a shadow discriminant created for a discriminant of 15107 -- the parent type, which needs to be present in the subtype. 15108 -- Give the shadow discriminant an internal name that cannot 15109 -- conflict with that of visible components. 15110 15111 Set_Chars (New_Compon, New_Internal_Name ('C')); 15112 end if; 15113 15114 -- Set the parent so we have a proper link for freezing etc. This is 15115 -- not a real parent pointer, since of course our parent does not own 15116 -- up to us and reference us, we are an illegitimate child of the 15117 -- original parent. 15118 15119 Set_Parent (New_Compon, Parent (Old_Compon)); 15120 15121 -- We do not want this node marked as Comes_From_Source, since 15122 -- otherwise it would get first class status and a separate cross- 15123 -- reference line would be generated. Illegitimate children do not 15124 -- rate such recognition. 15125 15126 Set_Comes_From_Source (New_Compon, False); 15127 15128 -- But it is a real entity, and a birth certificate must be properly 15129 -- registered by entering it into the entity list, and setting its 15130 -- scope to the given subtype. This turns out to be useful for the 15131 -- LLVM code generator, but that scope is not used otherwise. 15132 15133 Enter_Name (New_Compon); 15134 Set_Scope (New_Compon, Subt); 15135 15136 return New_Compon; 15137 end Create_Component; 15138 15139 ----------------------- 15140 -- Is_Variant_Record -- 15141 ----------------------- 15142 15143 function Is_Variant_Record (T : Entity_Id) return Boolean is 15144 begin 15145 return Nkind (Parent (T)) = N_Full_Type_Declaration 15146 and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition 15147 and then Present (Component_List (Type_Definition (Parent (T)))) 15148 and then 15149 Present 15150 (Variant_Part (Component_List (Type_Definition (Parent (T))))); 15151 end Is_Variant_Record; 15152 15153 -- Start of processing for Create_Constrained_Components 15154 15155 begin 15156 pragma Assert (Subt /= Base_Type (Subt)); 15157 pragma Assert (Typ = Base_Type (Typ)); 15158 15159 Set_First_Entity (Subt, Empty); 15160 Set_Last_Entity (Subt, Empty); 15161 15162 -- Check whether constraint is fully static, in which case we can 15163 -- optimize the list of components. 15164 15165 Discr_Val := First_Elmt (Constraints); 15166 while Present (Discr_Val) loop 15167 if not Is_OK_Static_Expression (Node (Discr_Val)) then 15168 Is_Static := False; 15169 15170 if not Compile_Time_Known_Value (Node (Discr_Val)) then 15171 Is_Compile_Time_Known := False; 15172 exit; 15173 end if; 15174 end if; 15175 15176 Next_Elmt (Discr_Val); 15177 end loop; 15178 15179 Set_Has_Static_Discriminants (Subt, Is_Static); 15180 15181 Push_Scope (Subt); 15182 15183 -- Inherit the discriminants of the parent type 15184 15185 Add_Discriminants : declare 15186 Num_Disc : Nat; 15187 Num_Stor : Nat; 15188 15189 begin 15190 Num_Disc := 0; 15191 Old_C := First_Discriminant (Typ); 15192 15193 while Present (Old_C) loop 15194 Num_Disc := Num_Disc + 1; 15195 New_C := Create_Component (Old_C); 15196 Set_Is_Public (New_C, Is_Public (Subt)); 15197 Next_Discriminant (Old_C); 15198 end loop; 15199 15200 -- For an untagged derived subtype, the number of discriminants may 15201 -- be smaller than the number of inherited discriminants, because 15202 -- several of them may be renamed by a single new discriminant or 15203 -- constrained. In this case, add the hidden discriminants back into 15204 -- the subtype, because they need to be present if the optimizer of 15205 -- the GCC 4.x back-end decides to break apart assignments between 15206 -- objects using the parent view into member-wise assignments. 15207 15208 Num_Stor := 0; 15209 15210 if Is_Derived_Type (Typ) 15211 and then not Is_Tagged_Type (Typ) 15212 then 15213 Old_C := First_Stored_Discriminant (Typ); 15214 15215 while Present (Old_C) loop 15216 Num_Stor := Num_Stor + 1; 15217 Next_Stored_Discriminant (Old_C); 15218 end loop; 15219 end if; 15220 15221 if Num_Stor > Num_Disc then 15222 15223 -- Find out multiple uses of new discriminants, and add hidden 15224 -- components for the extra renamed discriminants. We recognize 15225 -- multiple uses through the Corresponding_Discriminant of a 15226 -- new discriminant: if it constrains several old discriminants, 15227 -- this field points to the last one in the parent type. The 15228 -- stored discriminants of the derived type have the same name 15229 -- as those of the parent. 15230 15231 declare 15232 Constr : Elmt_Id; 15233 New_Discr : Entity_Id; 15234 Old_Discr : Entity_Id; 15235 15236 begin 15237 Constr := First_Elmt (Stored_Constraint (Typ)); 15238 Old_Discr := First_Stored_Discriminant (Typ); 15239 while Present (Constr) loop 15240 if Is_Entity_Name (Node (Constr)) 15241 and then Ekind (Entity (Node (Constr))) = E_Discriminant 15242 then 15243 New_Discr := Entity (Node (Constr)); 15244 15245 if Chars (Corresponding_Discriminant (New_Discr)) /= 15246 Chars (Old_Discr) 15247 then 15248 -- The new discriminant has been used to rename a 15249 -- subsequent old discriminant. Introduce a shadow 15250 -- component for the current old discriminant. 15251 15252 New_C := Create_Component (Old_Discr); 15253 Set_Original_Record_Component (New_C, Old_Discr); 15254 end if; 15255 15256 else 15257 -- The constraint has eliminated the old discriminant. 15258 -- Introduce a shadow component. 15259 15260 New_C := Create_Component (Old_Discr); 15261 Set_Original_Record_Component (New_C, Old_Discr); 15262 end if; 15263 15264 Next_Elmt (Constr); 15265 Next_Stored_Discriminant (Old_Discr); 15266 end loop; 15267 end; 15268 end if; 15269 end Add_Discriminants; 15270 15271 if Is_Compile_Time_Known 15272 and then Is_Variant_Record (Typ) 15273 then 15274 Collect_Fixed_Components (Typ); 15275 Gather_Components 15276 (Typ, 15277 Component_List (Type_Definition (Parent (Typ))), 15278 Governed_By => Assoc_List, 15279 Into => Comp_List, 15280 Report_Errors => Errors, 15281 Allow_Compile_Time => True); 15282 pragma Assert (not Errors or else Serious_Errors_Detected > 0); 15283 15284 Create_All_Components; 15285 15286 -- If the subtype declaration is created for a tagged type derivation 15287 -- with constraints, we retrieve the record definition of the parent 15288 -- type to select the components of the proper variant. 15289 15290 elsif Is_Compile_Time_Known 15291 and then Is_Tagged_Type (Typ) 15292 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 15293 and then 15294 Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition 15295 and then Is_Variant_Record (Parent_Type) 15296 then 15297 Collect_Fixed_Components (Typ); 15298 Gather_Components 15299 (Typ, 15300 Component_List (Type_Definition (Parent (Parent_Type))), 15301 Governed_By => Assoc_List, 15302 Into => Comp_List, 15303 Report_Errors => Errors, 15304 Allow_Compile_Time => True); 15305 15306 -- Note: previously there was a check at this point that no errors 15307 -- were detected. As a consequence of AI05-220 there may be an error 15308 -- if an inherited discriminant that controls a variant has a non- 15309 -- static constraint. 15310 15311 -- If the tagged derivation has a type extension, collect all the 15312 -- new relevant components therein via Gather_Components. 15313 15314 if Present (Record_Extension_Part (Type_Definition (Parent (Typ)))) 15315 then 15316 Gather_Components 15317 (Typ, 15318 Component_List 15319 (Record_Extension_Part (Type_Definition (Parent (Typ)))), 15320 Governed_By => Assoc_List, 15321 Into => Comp_List, 15322 Report_Errors => Errors, 15323 Allow_Compile_Time => True, 15324 Include_Interface_Tag => True); 15325 end if; 15326 15327 Create_All_Components; 15328 15329 else 15330 -- If discriminants are not static, or if this is a multi-level type 15331 -- extension, we have to include all components of the parent type. 15332 15333 Old_C := First_Component (Typ); 15334 while Present (Old_C) loop 15335 New_C := Create_Component (Old_C); 15336 15337 Set_Etype 15338 (New_C, 15339 Constrain_Component_Type 15340 (Old_C, Subt, Decl_Node, Typ, Constraints)); 15341 Set_Is_Public (New_C, Is_Public (Subt)); 15342 15343 Next_Component (Old_C); 15344 end loop; 15345 end if; 15346 15347 End_Scope; 15348 end Create_Constrained_Components; 15349 15350 ------------------------------------------ 15351 -- Decimal_Fixed_Point_Type_Declaration -- 15352 ------------------------------------------ 15353 15354 procedure Decimal_Fixed_Point_Type_Declaration 15355 (T : Entity_Id; 15356 Def : Node_Id) 15357 is 15358 Loc : constant Source_Ptr := Sloc (Def); 15359 Digs_Expr : constant Node_Id := Digits_Expression (Def); 15360 Delta_Expr : constant Node_Id := Delta_Expression (Def); 15361 Max_Digits : constant Nat := 15362 (if System_Max_Integer_Size = 128 then 38 else 18); 15363 -- Maximum number of digits that can be represented in an integer 15364 15365 Implicit_Base : Entity_Id; 15366 Digs_Val : Uint; 15367 Delta_Val : Ureal; 15368 Scale_Val : Uint; 15369 Bound_Val : Ureal; 15370 15371 begin 15372 Check_Restriction (No_Fixed_Point, Def); 15373 15374 -- Create implicit base type 15375 15376 Implicit_Base := 15377 Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B'); 15378 Set_Etype (Implicit_Base, Implicit_Base); 15379 15380 -- Analyze and process delta expression 15381 15382 Analyze_And_Resolve (Delta_Expr, Universal_Real); 15383 15384 Check_Delta_Expression (Delta_Expr); 15385 Delta_Val := Expr_Value_R (Delta_Expr); 15386 15387 -- Check delta is power of 10, and determine scale value from it 15388 15389 declare 15390 Val : Ureal; 15391 15392 begin 15393 Scale_Val := Uint_0; 15394 Val := Delta_Val; 15395 15396 if Val < Ureal_1 then 15397 while Val < Ureal_1 loop 15398 Val := Val * Ureal_10; 15399 Scale_Val := Scale_Val + 1; 15400 end loop; 15401 15402 if Scale_Val > Max_Digits then 15403 Error_Msg_Uint_1 := UI_From_Int (Max_Digits); 15404 Error_Msg_N ("scale exceeds maximum value of ^", Def); 15405 Scale_Val := UI_From_Int (Max_Digits); 15406 end if; 15407 15408 else 15409 while Val > Ureal_1 loop 15410 Val := Val / Ureal_10; 15411 Scale_Val := Scale_Val - 1; 15412 end loop; 15413 15414 if Scale_Val < -Max_Digits then 15415 Error_Msg_Uint_1 := UI_From_Int (-Max_Digits); 15416 Error_Msg_N ("scale is less than minimum value of ^", Def); 15417 Scale_Val := UI_From_Int (-Max_Digits); 15418 end if; 15419 end if; 15420 15421 if Val /= Ureal_1 then 15422 Error_Msg_N ("delta expression must be a power of 10", Def); 15423 Delta_Val := Ureal_10 ** (-Scale_Val); 15424 end if; 15425 end; 15426 15427 -- Set delta, scale and small (small = delta for decimal type) 15428 15429 Set_Delta_Value (Implicit_Base, Delta_Val); 15430 Set_Scale_Value (Implicit_Base, Scale_Val); 15431 Set_Small_Value (Implicit_Base, Delta_Val); 15432 15433 -- Analyze and process digits expression 15434 15435 Analyze_And_Resolve (Digs_Expr, Any_Integer); 15436 Check_Digits_Expression (Digs_Expr); 15437 Digs_Val := Expr_Value (Digs_Expr); 15438 15439 if Digs_Val > Max_Digits then 15440 Error_Msg_Uint_1 := UI_From_Int (Max_Digits); 15441 Error_Msg_N ("digits value out of range, maximum is ^", Digs_Expr); 15442 Digs_Val := UI_From_Int (Max_Digits); 15443 end if; 15444 15445 Set_Digits_Value (Implicit_Base, Digs_Val); 15446 Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val; 15447 15448 -- Set range of base type from digits value for now. This will be 15449 -- expanded to represent the true underlying base range by Freeze. 15450 15451 Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); 15452 15453 -- Note: We leave Esize unset for now, size will be set at freeze 15454 -- time. We have to do this for ordinary fixed-point, because the size 15455 -- depends on the specified small, and we might as well do the same for 15456 -- decimal fixed-point. 15457 15458 pragma Assert (not Known_Esize (Implicit_Base)); 15459 15460 -- If there are bounds given in the declaration use them as the 15461 -- bounds of the first named subtype. 15462 15463 if Present (Real_Range_Specification (Def)) then 15464 declare 15465 RRS : constant Node_Id := Real_Range_Specification (Def); 15466 Low : constant Node_Id := Low_Bound (RRS); 15467 High : constant Node_Id := High_Bound (RRS); 15468 Low_Val : Ureal; 15469 High_Val : Ureal; 15470 15471 begin 15472 Analyze_And_Resolve (Low, Any_Real); 15473 Analyze_And_Resolve (High, Any_Real); 15474 Check_Real_Bound (Low); 15475 Check_Real_Bound (High); 15476 Low_Val := Expr_Value_R (Low); 15477 High_Val := Expr_Value_R (High); 15478 15479 if Low_Val < (-Bound_Val) then 15480 Error_Msg_N 15481 ("range low bound too small for digits value", Low); 15482 Low_Val := -Bound_Val; 15483 end if; 15484 15485 if High_Val > Bound_Val then 15486 Error_Msg_N 15487 ("range high bound too large for digits value", High); 15488 High_Val := Bound_Val; 15489 end if; 15490 15491 Set_Fixed_Range (T, Loc, Low_Val, High_Val); 15492 end; 15493 15494 -- If no explicit range, use range that corresponds to given 15495 -- digits value. This will end up as the final range for the 15496 -- first subtype. 15497 15498 else 15499 Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val); 15500 end if; 15501 15502 -- Complete entity for first subtype. The inheritance of the rep item 15503 -- chain ensures that SPARK-related pragmas are not clobbered when the 15504 -- decimal fixed point type acts as a full view of a private type. 15505 15506 Mutate_Ekind (T, E_Decimal_Fixed_Point_Subtype); 15507 Set_Etype (T, Implicit_Base); 15508 Set_Size_Info (T, Implicit_Base); 15509 Inherit_Rep_Item_Chain (T, Implicit_Base); 15510 Set_Digits_Value (T, Digs_Val); 15511 Set_Delta_Value (T, Delta_Val); 15512 Set_Small_Value (T, Delta_Val); 15513 Set_Scale_Value (T, Scale_Val); 15514 Set_Is_Constrained (T); 15515 end Decimal_Fixed_Point_Type_Declaration; 15516 15517 ----------------------------------- 15518 -- Derive_Progenitor_Subprograms -- 15519 ----------------------------------- 15520 15521 procedure Derive_Progenitor_Subprograms 15522 (Parent_Type : Entity_Id; 15523 Tagged_Type : Entity_Id) 15524 is 15525 E : Entity_Id; 15526 Elmt : Elmt_Id; 15527 Iface : Entity_Id; 15528 Iface_Alias : Entity_Id; 15529 Iface_Elmt : Elmt_Id; 15530 Iface_Subp : Entity_Id; 15531 New_Subp : Entity_Id := Empty; 15532 Prim_Elmt : Elmt_Id; 15533 Subp : Entity_Id; 15534 Typ : Entity_Id; 15535 15536 begin 15537 pragma Assert (Ada_Version >= Ada_2005 15538 and then Is_Record_Type (Tagged_Type) 15539 and then Is_Tagged_Type (Tagged_Type) 15540 and then Has_Interfaces (Tagged_Type)); 15541 15542 -- Step 1: Transfer to the full-view primitives associated with the 15543 -- partial-view that cover interface primitives. Conceptually this 15544 -- work should be done later by Process_Full_View; done here to 15545 -- simplify its implementation at later stages. It can be safely 15546 -- done here because interfaces must be visible in the partial and 15547 -- private view (RM 7.3(7.3/2)). 15548 15549 -- Small optimization: This work is only required if the parent may 15550 -- have entities whose Alias attribute reference an interface primitive. 15551 -- Such a situation may occur if the parent is an abstract type and the 15552 -- primitive has not been yet overridden or if the parent is a generic 15553 -- formal type covering interfaces. 15554 15555 -- If the tagged type is not abstract, it cannot have abstract 15556 -- primitives (the only entities in the list of primitives of 15557 -- non-abstract tagged types that can reference abstract primitives 15558 -- through its Alias attribute are the internal entities that have 15559 -- attribute Interface_Alias, and these entities are generated later 15560 -- by Add_Internal_Interface_Entities). 15561 15562 if In_Private_Part (Current_Scope) 15563 and then (Is_Abstract_Type (Parent_Type) 15564 or else 15565 Is_Generic_Type (Parent_Type)) 15566 then 15567 Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); 15568 while Present (Elmt) loop 15569 Subp := Node (Elmt); 15570 15571 -- At this stage it is not possible to have entities in the list 15572 -- of primitives that have attribute Interface_Alias. 15573 15574 pragma Assert (No (Interface_Alias (Subp))); 15575 15576 Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); 15577 15578 if Is_Interface (Typ) then 15579 E := Find_Primitive_Covering_Interface 15580 (Tagged_Type => Tagged_Type, 15581 Iface_Prim => Subp); 15582 15583 if Present (E) 15584 and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ 15585 then 15586 Replace_Elmt (Elmt, E); 15587 Remove_Homonym (Subp); 15588 end if; 15589 end if; 15590 15591 Next_Elmt (Elmt); 15592 end loop; 15593 end if; 15594 15595 -- Step 2: Add primitives of progenitors that are not implemented by 15596 -- parents of Tagged_Type. 15597 15598 if Present (Interfaces (Base_Type (Tagged_Type))) then 15599 Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type))); 15600 while Present (Iface_Elmt) loop 15601 Iface := Node (Iface_Elmt); 15602 15603 Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); 15604 while Present (Prim_Elmt) loop 15605 Iface_Subp := Node (Prim_Elmt); 15606 Iface_Alias := Ultimate_Alias (Iface_Subp); 15607 15608 -- Exclude derivation of predefined primitives except those 15609 -- that come from source, or are inherited from one that comes 15610 -- from source. Required to catch declarations of equality 15611 -- operators of interfaces. For example: 15612 15613 -- type Iface is interface; 15614 -- function "=" (Left, Right : Iface) return Boolean; 15615 15616 if not Is_Predefined_Dispatching_Operation (Iface_Subp) 15617 or else Comes_From_Source (Iface_Alias) 15618 then 15619 E := 15620 Find_Primitive_Covering_Interface 15621 (Tagged_Type => Tagged_Type, 15622 Iface_Prim => Iface_Subp); 15623 15624 -- If not found we derive a new primitive leaving its alias 15625 -- attribute referencing the interface primitive. 15626 15627 if No (E) then 15628 Derive_Subprogram 15629 (New_Subp, Iface_Subp, Tagged_Type, Iface); 15630 15631 -- Ada 2012 (AI05-0197): If the covering primitive's name 15632 -- differs from the name of the interface primitive then it 15633 -- is a private primitive inherited from a parent type. In 15634 -- such case, given that Tagged_Type covers the interface, 15635 -- the inherited private primitive becomes visible. For such 15636 -- purpose we add a new entity that renames the inherited 15637 -- private primitive. 15638 15639 elsif Chars (E) /= Chars (Iface_Subp) then 15640 pragma Assert (Has_Suffix (E, 'P')); 15641 Derive_Subprogram 15642 (New_Subp, Iface_Subp, Tagged_Type, Iface); 15643 Set_Alias (New_Subp, E); 15644 Set_Is_Abstract_Subprogram (New_Subp, 15645 Is_Abstract_Subprogram (E)); 15646 15647 -- Propagate to the full view interface entities associated 15648 -- with the partial view. 15649 15650 elsif In_Private_Part (Current_Scope) 15651 and then Present (Alias (E)) 15652 and then Alias (E) = Iface_Subp 15653 and then 15654 List_Containing (Parent (E)) /= 15655 Private_Declarations 15656 (Specification 15657 (Unit_Declaration_Node (Current_Scope))) 15658 then 15659 Append_Elmt (E, Primitive_Operations (Tagged_Type)); 15660 end if; 15661 end if; 15662 15663 Next_Elmt (Prim_Elmt); 15664 end loop; 15665 15666 Next_Elmt (Iface_Elmt); 15667 end loop; 15668 end if; 15669 end Derive_Progenitor_Subprograms; 15670 15671 ----------------------- 15672 -- Derive_Subprogram -- 15673 ----------------------- 15674 15675 procedure Derive_Subprogram 15676 (New_Subp : out Entity_Id; 15677 Parent_Subp : Entity_Id; 15678 Derived_Type : Entity_Id; 15679 Parent_Type : Entity_Id; 15680 Actual_Subp : Entity_Id := Empty) 15681 is 15682 Formal : Entity_Id; 15683 -- Formal parameter of parent primitive operation 15684 15685 Formal_Of_Actual : Entity_Id; 15686 -- Formal parameter of actual operation, when the derivation is to 15687 -- create a renaming for a primitive operation of an actual in an 15688 -- instantiation. 15689 15690 New_Formal : Entity_Id; 15691 -- Formal of inherited operation 15692 15693 Visible_Subp : Entity_Id := Parent_Subp; 15694 15695 function Is_Private_Overriding return Boolean; 15696 -- If Subp is a private overriding of a visible operation, the inherited 15697 -- operation derives from the overridden op (even though its body is the 15698 -- overriding one) and the inherited operation is visible now. See 15699 -- sem_disp to see the full details of the handling of the overridden 15700 -- subprogram, which is removed from the list of primitive operations of 15701 -- the type. The overridden subprogram is saved locally in Visible_Subp, 15702 -- and used to diagnose abstract operations that need overriding in the 15703 -- derived type. 15704 15705 procedure Replace_Type (Id, New_Id : Entity_Id); 15706 -- When the type is an anonymous access type, create a new access type 15707 -- designating the derived type. 15708 15709 procedure Set_Derived_Name; 15710 -- This procedure sets the appropriate Chars name for New_Subp. This 15711 -- is normally just a copy of the parent name. An exception arises for 15712 -- type support subprograms, where the name is changed to reflect the 15713 -- name of the derived type, e.g. if type foo is derived from type bar, 15714 -- then a procedure barDA is derived with a name fooDA. 15715 15716 --------------------------- 15717 -- Is_Private_Overriding -- 15718 --------------------------- 15719 15720 function Is_Private_Overriding return Boolean is 15721 Prev : Entity_Id; 15722 15723 begin 15724 -- If the parent is not a dispatching operation there is no 15725 -- need to investigate overridings 15726 15727 if not Is_Dispatching_Operation (Parent_Subp) then 15728 return False; 15729 end if; 15730 15731 -- The visible operation that is overridden is a homonym of the 15732 -- parent subprogram. We scan the homonym chain to find the one 15733 -- whose alias is the subprogram we are deriving. 15734 15735 Prev := Current_Entity (Parent_Subp); 15736 while Present (Prev) loop 15737 if Ekind (Prev) = Ekind (Parent_Subp) 15738 and then Alias (Prev) = Parent_Subp 15739 and then Scope (Parent_Subp) = Scope (Prev) 15740 and then not Is_Hidden (Prev) 15741 then 15742 Visible_Subp := Prev; 15743 return True; 15744 end if; 15745 15746 Prev := Homonym (Prev); 15747 end loop; 15748 15749 return False; 15750 end Is_Private_Overriding; 15751 15752 ------------------ 15753 -- Replace_Type -- 15754 ------------------ 15755 15756 procedure Replace_Type (Id, New_Id : Entity_Id) is 15757 Id_Type : constant Entity_Id := Etype (Id); 15758 Acc_Type : Entity_Id; 15759 Par : constant Node_Id := Parent (Derived_Type); 15760 15761 begin 15762 -- When the type is an anonymous access type, create a new access 15763 -- type designating the derived type. This itype must be elaborated 15764 -- at the point of the derivation, not on subsequent calls that may 15765 -- be out of the proper scope for Gigi, so we insert a reference to 15766 -- it after the derivation. 15767 15768 if Ekind (Id_Type) = E_Anonymous_Access_Type then 15769 declare 15770 Desig_Typ : Entity_Id := Designated_Type (Id_Type); 15771 15772 begin 15773 if Ekind (Desig_Typ) = E_Record_Type_With_Private 15774 and then Present (Full_View (Desig_Typ)) 15775 and then not Is_Private_Type (Parent_Type) 15776 then 15777 Desig_Typ := Full_View (Desig_Typ); 15778 end if; 15779 15780 if Base_Type (Desig_Typ) = Base_Type (Parent_Type) 15781 15782 -- Ada 2005 (AI-251): Handle also derivations of abstract 15783 -- interface primitives. 15784 15785 or else (Is_Interface (Desig_Typ) 15786 and then not Is_Class_Wide_Type (Desig_Typ)) 15787 then 15788 Acc_Type := New_Copy (Id_Type); 15789 Set_Etype (Acc_Type, Acc_Type); 15790 Set_Scope (Acc_Type, New_Subp); 15791 15792 -- Set size of anonymous access type. If we have an access 15793 -- to an unconstrained array, this is a fat pointer, so it 15794 -- is sizes at twice addtress size. 15795 15796 if Is_Array_Type (Desig_Typ) 15797 and then not Is_Constrained (Desig_Typ) 15798 then 15799 Init_Size (Acc_Type, 2 * System_Address_Size); 15800 15801 -- Other cases use a thin pointer 15802 15803 else 15804 Init_Size (Acc_Type, System_Address_Size); 15805 end if; 15806 15807 -- Set remaining characterstics of anonymous access type 15808 15809 Reinit_Alignment (Acc_Type); 15810 Set_Directly_Designated_Type (Acc_Type, Derived_Type); 15811 15812 Set_Etype (New_Id, Acc_Type); 15813 Set_Scope (New_Id, New_Subp); 15814 15815 -- Create a reference to it 15816 15817 Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); 15818 15819 else 15820 Set_Etype (New_Id, Id_Type); 15821 end if; 15822 end; 15823 15824 -- In Ada2012, a formal may have an incomplete type but the type 15825 -- derivation that inherits the primitive follows the full view. 15826 15827 elsif Base_Type (Id_Type) = Base_Type (Parent_Type) 15828 or else 15829 (Ekind (Id_Type) = E_Record_Type_With_Private 15830 and then Present (Full_View (Id_Type)) 15831 and then 15832 Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type)) 15833 or else 15834 (Ada_Version >= Ada_2012 15835 and then Ekind (Id_Type) = E_Incomplete_Type 15836 and then Full_View (Id_Type) = Parent_Type) 15837 then 15838 -- Constraint checks on formals are generated during expansion, 15839 -- based on the signature of the original subprogram. The bounds 15840 -- of the derived type are not relevant, and thus we can use 15841 -- the base type for the formals. However, the return type may be 15842 -- used in a context that requires that the proper static bounds 15843 -- be used (a case statement, for example) and for those cases 15844 -- we must use the derived type (first subtype), not its base. 15845 15846 -- If the derived_type_definition has no constraints, we know that 15847 -- the derived type has the same constraints as the first subtype 15848 -- of the parent, and we can also use it rather than its base, 15849 -- which can lead to more efficient code. 15850 15851 if Etype (Id) = Parent_Type then 15852 if Is_Scalar_Type (Parent_Type) 15853 and then 15854 Subtypes_Statically_Compatible (Parent_Type, Derived_Type) 15855 then 15856 Set_Etype (New_Id, Derived_Type); 15857 15858 elsif Nkind (Par) = N_Full_Type_Declaration 15859 and then 15860 Nkind (Type_Definition (Par)) = N_Derived_Type_Definition 15861 and then 15862 Is_Entity_Name 15863 (Subtype_Indication (Type_Definition (Par))) 15864 then 15865 Set_Etype (New_Id, Derived_Type); 15866 15867 else 15868 Set_Etype (New_Id, Base_Type (Derived_Type)); 15869 end if; 15870 15871 else 15872 Set_Etype (New_Id, Base_Type (Derived_Type)); 15873 end if; 15874 15875 else 15876 Set_Etype (New_Id, Etype (Id)); 15877 end if; 15878 end Replace_Type; 15879 15880 ---------------------- 15881 -- Set_Derived_Name -- 15882 ---------------------- 15883 15884 procedure Set_Derived_Name is 15885 Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp); 15886 begin 15887 if Nm = TSS_Null then 15888 Set_Chars (New_Subp, Chars (Parent_Subp)); 15889 else 15890 Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm)); 15891 end if; 15892 end Set_Derived_Name; 15893 15894 -- Start of processing for Derive_Subprogram 15895 15896 begin 15897 New_Subp := New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); 15898 Mutate_Ekind (New_Subp, Ekind (Parent_Subp)); 15899 15900 -- Check whether the inherited subprogram is a private operation that 15901 -- should be inherited but not yet made visible. Such subprograms can 15902 -- become visible at a later point (e.g., the private part of a public 15903 -- child unit) via Declare_Inherited_Private_Subprograms. If the 15904 -- following predicate is true, then this is not such a private 15905 -- operation and the subprogram simply inherits the name of the parent 15906 -- subprogram. Note the special check for the names of controlled 15907 -- operations, which are currently exempted from being inherited with 15908 -- a hidden name because they must be findable for generation of 15909 -- implicit run-time calls. 15910 15911 if not Is_Hidden (Parent_Subp) 15912 or else Is_Internal (Parent_Subp) 15913 or else Is_Private_Overriding 15914 or else Is_Internal_Name (Chars (Parent_Subp)) 15915 or else (Is_Controlled (Parent_Type) 15916 and then Chars (Parent_Subp) in Name_Adjust 15917 | Name_Finalize 15918 | Name_Initialize) 15919 then 15920 Set_Derived_Name; 15921 15922 -- An inherited dispatching equality will be overridden by an internally 15923 -- generated one, or by an explicit one, so preserve its name and thus 15924 -- its entry in the dispatch table. Otherwise, if Parent_Subp is a 15925 -- private operation it may become invisible if the full view has 15926 -- progenitors, and the dispatch table will be malformed. 15927 -- We check that the type is limited to handle the anomalous declaration 15928 -- of Limited_Controlled, which is derived from a non-limited type, and 15929 -- which is handled specially elsewhere as well. 15930 15931 elsif Chars (Parent_Subp) = Name_Op_Eq 15932 and then Is_Dispatching_Operation (Parent_Subp) 15933 and then Etype (Parent_Subp) = Standard_Boolean 15934 and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp))) 15935 and then 15936 Etype (First_Formal (Parent_Subp)) = 15937 Etype (Next_Formal (First_Formal (Parent_Subp))) 15938 then 15939 Set_Derived_Name; 15940 15941 -- If parent is hidden, this can be a regular derivation if the 15942 -- parent is immediately visible in a non-instantiating context, 15943 -- or if we are in the private part of an instance. This test 15944 -- should still be refined ??? 15945 15946 -- The test for In_Instance_Not_Visible avoids inheriting the derived 15947 -- operation as a non-visible operation in cases where the parent 15948 -- subprogram might not be visible now, but was visible within the 15949 -- original generic, so it would be wrong to make the inherited 15950 -- subprogram non-visible now. (Not clear if this test is fully 15951 -- correct; are there any cases where we should declare the inherited 15952 -- operation as not visible to avoid it being overridden, e.g., when 15953 -- the parent type is a generic actual with private primitives ???) 15954 15955 -- (they should be treated the same as other private inherited 15956 -- subprograms, but it's not clear how to do this cleanly). ??? 15957 15958 elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type))) 15959 and then Is_Immediately_Visible (Parent_Subp) 15960 and then not In_Instance) 15961 or else In_Instance_Not_Visible 15962 then 15963 Set_Derived_Name; 15964 15965 -- Ada 2005 (AI-251): Regular derivation if the parent subprogram 15966 -- overrides an interface primitive because interface primitives 15967 -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) 15968 15969 elsif Ada_Version >= Ada_2005 15970 and then Is_Dispatching_Operation (Parent_Subp) 15971 and then Present (Covered_Interface_Op (Parent_Subp)) 15972 then 15973 Set_Derived_Name; 15974 15975 -- Otherwise, the type is inheriting a private operation, so enter it 15976 -- with a special name so it can't be overridden. See also below, where 15977 -- we check for this case, and if so avoid setting Requires_Overriding. 15978 15979 else 15980 Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P')); 15981 end if; 15982 15983 Set_Parent (New_Subp, Parent (Derived_Type)); 15984 15985 if Present (Actual_Subp) then 15986 Replace_Type (Actual_Subp, New_Subp); 15987 else 15988 Replace_Type (Parent_Subp, New_Subp); 15989 end if; 15990 15991 Conditional_Delay (New_Subp, Parent_Subp); 15992 15993 -- If we are creating a renaming for a primitive operation of an 15994 -- actual of a generic derived type, we must examine the signature 15995 -- of the actual primitive, not that of the generic formal, which for 15996 -- example may be an interface. However the name and initial value 15997 -- of the inherited operation are those of the formal primitive. 15998 15999 Formal := First_Formal (Parent_Subp); 16000 16001 if Present (Actual_Subp) then 16002 Formal_Of_Actual := First_Formal (Actual_Subp); 16003 else 16004 Formal_Of_Actual := Empty; 16005 end if; 16006 16007 while Present (Formal) loop 16008 New_Formal := New_Copy (Formal); 16009 16010 -- Extra formals are not inherited from a limited interface parent 16011 -- since limitedness is not inherited in such case (AI-419) and this 16012 -- affects the extra formals. 16013 16014 if Is_Limited_Interface (Parent_Type) then 16015 Set_Extra_Formal (New_Formal, Empty); 16016 Set_Extra_Accessibility (New_Formal, Empty); 16017 end if; 16018 16019 -- Normally we do not go copying parents, but in the case of 16020 -- formals, we need to link up to the declaration (which is the 16021 -- parameter specification), and it is fine to link up to the 16022 -- original formal's parameter specification in this case. 16023 16024 Set_Parent (New_Formal, Parent (Formal)); 16025 Append_Entity (New_Formal, New_Subp); 16026 16027 if Present (Formal_Of_Actual) then 16028 Replace_Type (Formal_Of_Actual, New_Formal); 16029 Next_Formal (Formal_Of_Actual); 16030 else 16031 Replace_Type (Formal, New_Formal); 16032 end if; 16033 16034 Next_Formal (Formal); 16035 end loop; 16036 16037 -- Extra formals are shared between the parent subprogram and the 16038 -- derived subprogram (implicit in the above copy of formals), unless 16039 -- the parent type is a limited interface type; hence we must inherit 16040 -- also the reference to the first extra formal. When the parent type is 16041 -- an interface the extra formals will be added when the subprogram is 16042 -- frozen (see Freeze.Freeze_Subprogram). 16043 16044 if not Is_Limited_Interface (Parent_Type) then 16045 Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp)); 16046 16047 if Ekind (New_Subp) = E_Function then 16048 Set_Extra_Accessibility_Of_Result (New_Subp, 16049 Extra_Accessibility_Of_Result (Parent_Subp)); 16050 end if; 16051 end if; 16052 16053 -- If this derivation corresponds to a tagged generic actual, then 16054 -- primitive operations rename those of the actual. Otherwise the 16055 -- primitive operations rename those of the parent type, If the parent 16056 -- renames an intrinsic operator, so does the new subprogram. We except 16057 -- concatenation, which is always properly typed, and does not get 16058 -- expanded as other intrinsic operations. 16059 16060 if No (Actual_Subp) then 16061 if Is_Intrinsic_Subprogram (Parent_Subp) then 16062 Set_Is_Intrinsic_Subprogram (New_Subp); 16063 16064 if Present (Alias (Parent_Subp)) 16065 and then Chars (Parent_Subp) /= Name_Op_Concat 16066 then 16067 Set_Alias (New_Subp, Alias (Parent_Subp)); 16068 else 16069 Set_Alias (New_Subp, Parent_Subp); 16070 end if; 16071 16072 else 16073 Set_Alias (New_Subp, Parent_Subp); 16074 end if; 16075 16076 else 16077 Set_Alias (New_Subp, Actual_Subp); 16078 end if; 16079 16080 Copy_Strub_Mode (New_Subp, Alias (New_Subp)); 16081 16082 -- Derived subprograms of a tagged type must inherit the convention 16083 -- of the parent subprogram (a requirement of AI-117). Derived 16084 -- subprograms of untagged types simply get convention Ada by default. 16085 16086 -- If the derived type is a tagged generic formal type with unknown 16087 -- discriminants, its convention is intrinsic (RM 6.3.1 (8)). 16088 16089 -- However, if the type is derived from a generic formal, the further 16090 -- inherited subprogram has the convention of the non-generic ancestor. 16091 -- Otherwise there would be no way to override the operation. 16092 -- (This is subject to forthcoming ARG discussions). 16093 16094 if Is_Tagged_Type (Derived_Type) then 16095 if Is_Generic_Type (Derived_Type) 16096 and then Has_Unknown_Discriminants (Derived_Type) 16097 then 16098 Set_Convention (New_Subp, Convention_Intrinsic); 16099 16100 else 16101 if Is_Generic_Type (Parent_Type) 16102 and then Has_Unknown_Discriminants (Parent_Type) 16103 then 16104 Set_Convention (New_Subp, Convention (Alias (Parent_Subp))); 16105 else 16106 Set_Convention (New_Subp, Convention (Parent_Subp)); 16107 end if; 16108 end if; 16109 end if; 16110 16111 -- Predefined controlled operations retain their name even if the parent 16112 -- is hidden (see above), but they are not primitive operations if the 16113 -- ancestor is not visible, for example if the parent is a private 16114 -- extension completed with a controlled extension. Note that a full 16115 -- type that is controlled can break privacy: the flag Is_Controlled is 16116 -- set on both views of the type. 16117 16118 if Is_Controlled (Parent_Type) 16119 and then Chars (Parent_Subp) in Name_Initialize 16120 | Name_Adjust 16121 | Name_Finalize 16122 and then Is_Hidden (Parent_Subp) 16123 and then not Is_Visibly_Controlled (Parent_Type) 16124 then 16125 Set_Is_Hidden (New_Subp); 16126 end if; 16127 16128 Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp)); 16129 Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp)); 16130 16131 if Ekind (Parent_Subp) = E_Procedure then 16132 Set_Is_Valued_Procedure 16133 (New_Subp, Is_Valued_Procedure (Parent_Subp)); 16134 else 16135 Set_Has_Controlling_Result 16136 (New_Subp, Has_Controlling_Result (Parent_Subp)); 16137 end if; 16138 16139 -- No_Return must be inherited properly. If this is overridden in the 16140 -- case of a dispatching operation, then the check is made later in 16141 -- Check_Abstract_Overriding that the overriding operation is also 16142 -- No_Return (no such check is required for the nondispatching case). 16143 16144 Set_No_Return (New_Subp, No_Return (Parent_Subp)); 16145 16146 -- If the parent subprogram is marked as Ghost, then so is the derived 16147 -- subprogram. The ghost policy for the derived subprogram is set from 16148 -- the effective ghost policy at the point of derived type declaration. 16149 16150 if Is_Ghost_Entity (Parent_Subp) then 16151 Set_Is_Ghost_Entity (New_Subp); 16152 end if; 16153 16154 -- A derived function with a controlling result is abstract. If the 16155 -- Derived_Type is a nonabstract formal generic derived type, then 16156 -- inherited operations are not abstract: the required check is done at 16157 -- instantiation time. If the derivation is for a generic actual, the 16158 -- function is not abstract unless the actual is. 16159 16160 if Is_Generic_Type (Derived_Type) 16161 and then not Is_Abstract_Type (Derived_Type) 16162 then 16163 null; 16164 16165 -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" 16166 -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). Note 16167 -- that functions with controlling access results of record extensions 16168 -- with a null extension part require overriding (AI95-00391/06). 16169 16170 -- Ada 2022 (AI12-0042): Similarly, set those properties for 16171 -- implementing the rule of RM 7.3.2(6.1/4). 16172 16173 -- A subprogram subject to pragma Extensions_Visible with value False 16174 -- requires overriding if the subprogram has at least one controlling 16175 -- OUT parameter (SPARK RM 6.1.7(6)). 16176 16177 elsif Ada_Version >= Ada_2005 16178 and then (Is_Abstract_Subprogram (Alias (New_Subp)) 16179 or else (Is_Tagged_Type (Derived_Type) 16180 and then Etype (New_Subp) = Derived_Type 16181 and then not Is_Null_Extension (Derived_Type)) 16182 or else (Is_Tagged_Type (Derived_Type) 16183 and then Ekind (Etype (New_Subp)) = 16184 E_Anonymous_Access_Type 16185 and then Designated_Type (Etype (New_Subp)) = 16186 Derived_Type) 16187 or else (Comes_From_Source (Alias (New_Subp)) 16188 and then Is_EVF_Procedure (Alias (New_Subp))) 16189 16190 -- AI12-0042: Set Requires_Overriding when a type extension 16191 -- inherits a private operation that is visible at the 16192 -- point of extension (Has_Private_Ancestor is False) from 16193 -- an ancestor that has Type_Invariant'Class, and when the 16194 -- type extension is in a visible part (the latter as 16195 -- clarified by AI12-0382). 16196 16197 or else 16198 (not Has_Private_Ancestor (Derived_Type) 16199 and then Has_Invariants (Parent_Type) 16200 and then 16201 Present (Get_Pragma (Parent_Type, Pragma_Invariant)) 16202 and then 16203 Class_Present 16204 (Get_Pragma (Parent_Type, Pragma_Invariant)) 16205 and then Is_Private_Primitive (Parent_Subp) 16206 and then In_Visible_Part (Scope (Derived_Type)))) 16207 16208 and then No (Actual_Subp) 16209 then 16210 if not Is_Tagged_Type (Derived_Type) 16211 or else Is_Abstract_Type (Derived_Type) 16212 or else Is_Abstract_Subprogram (Alias (New_Subp)) 16213 then 16214 Set_Is_Abstract_Subprogram (New_Subp); 16215 16216 -- If the Chars of the new subprogram is different from that of the 16217 -- parent's one, it means that we entered it with a special name so 16218 -- it can't be overridden (see above). In that case we had better not 16219 -- *require* it to be overridden. This is the case where the parent 16220 -- type inherited the operation privately, so there's no danger of 16221 -- dangling dispatching. 16222 16223 elsif Chars (New_Subp) = Chars (Alias (New_Subp)) then 16224 Set_Requires_Overriding (New_Subp); 16225 end if; 16226 16227 elsif Ada_Version < Ada_2005 16228 and then (Is_Abstract_Subprogram (Alias (New_Subp)) 16229 or else (Is_Tagged_Type (Derived_Type) 16230 and then Etype (New_Subp) = Derived_Type 16231 and then No (Actual_Subp))) 16232 then 16233 Set_Is_Abstract_Subprogram (New_Subp); 16234 16235 -- AI05-0097 : an inherited operation that dispatches on result is 16236 -- abstract if the derived type is abstract, even if the parent type 16237 -- is concrete and the derived type is a null extension. 16238 16239 elsif Has_Controlling_Result (Alias (New_Subp)) 16240 and then Is_Abstract_Type (Etype (New_Subp)) 16241 then 16242 Set_Is_Abstract_Subprogram (New_Subp); 16243 16244 -- Finally, if the parent type is abstract we must verify that all 16245 -- inherited operations are either non-abstract or overridden, or that 16246 -- the derived type itself is abstract (this check is performed at the 16247 -- end of a package declaration, in Check_Abstract_Overriding). A 16248 -- private overriding in the parent type will not be visible in the 16249 -- derivation if we are not in an inner package or in a child unit of 16250 -- the parent type, in which case the abstractness of the inherited 16251 -- operation is carried to the new subprogram. 16252 16253 elsif Is_Abstract_Type (Parent_Type) 16254 and then not In_Open_Scopes (Scope (Parent_Type)) 16255 and then Is_Private_Overriding 16256 and then Is_Abstract_Subprogram (Visible_Subp) 16257 then 16258 if No (Actual_Subp) then 16259 Set_Alias (New_Subp, Visible_Subp); 16260 Set_Is_Abstract_Subprogram (New_Subp, True); 16261 16262 else 16263 -- If this is a derivation for an instance of a formal derived 16264 -- type, abstractness comes from the primitive operation of the 16265 -- actual, not from the operation inherited from the ancestor. 16266 16267 Set_Is_Abstract_Subprogram 16268 (New_Subp, Is_Abstract_Subprogram (Actual_Subp)); 16269 end if; 16270 end if; 16271 16272 New_Overloaded_Entity (New_Subp, Derived_Type); 16273 16274 -- Ada RM 6.1.1 (15): If a subprogram inherits nonconforming class-wide 16275 -- preconditions and the derived type is abstract, the derived operation 16276 -- is abstract as well if parent subprogram is not abstract or null. 16277 16278 if Is_Abstract_Type (Derived_Type) 16279 and then Has_Non_Trivial_Precondition (Parent_Subp) 16280 and then Present (Interfaces (Derived_Type)) 16281 then 16282 16283 -- Add useful attributes of subprogram before the freeze point, 16284 -- in case freezing is delayed or there are previous errors. 16285 16286 Set_Is_Dispatching_Operation (New_Subp); 16287 16288 declare 16289 Iface_Prim : constant Entity_Id := Covered_Interface_Op (New_Subp); 16290 16291 begin 16292 if Present (Iface_Prim) 16293 and then Has_Non_Trivial_Precondition (Iface_Prim) 16294 then 16295 Set_Is_Abstract_Subprogram (New_Subp); 16296 end if; 16297 end; 16298 end if; 16299 16300 -- Check for case of a derived subprogram for the instantiation of a 16301 -- formal derived tagged type, if so mark the subprogram as dispatching 16302 -- and inherit the dispatching attributes of the actual subprogram. The 16303 -- derived subprogram is effectively renaming of the actual subprogram, 16304 -- so it needs to have the same attributes as the actual. 16305 16306 if Present (Actual_Subp) 16307 and then Is_Dispatching_Operation (Actual_Subp) 16308 then 16309 Set_Is_Dispatching_Operation (New_Subp); 16310 16311 if Present (DTC_Entity (Actual_Subp)) then 16312 Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp)); 16313 Set_DT_Position_Value (New_Subp, DT_Position (Actual_Subp)); 16314 end if; 16315 end if; 16316 16317 -- Indicate that a derived subprogram does not require a body and that 16318 -- it does not require processing of default expressions. 16319 16320 Set_Has_Completion (New_Subp); 16321 Set_Default_Expressions_Processed (New_Subp); 16322 16323 if Ekind (New_Subp) = E_Function then 16324 Set_Mechanism (New_Subp, Mechanism (Parent_Subp)); 16325 end if; 16326 16327 -- Ada 2022 (AI12-0279): If a Yield aspect is specified True for a 16328 -- primitive subprogram S of a type T, then the aspect is inherited 16329 -- by the corresponding primitive subprogram of each descendant of T. 16330 16331 if Is_Tagged_Type (Derived_Type) 16332 and then Is_Dispatching_Operation (New_Subp) 16333 and then Has_Yield_Aspect (Alias (New_Subp)) 16334 then 16335 Set_Has_Yield_Aspect (New_Subp, Has_Yield_Aspect (Alias (New_Subp))); 16336 end if; 16337 16338 Set_Is_Ada_2022_Only (New_Subp, Is_Ada_2022_Only (Parent_Subp)); 16339 end Derive_Subprogram; 16340 16341 ------------------------ 16342 -- Derive_Subprograms -- 16343 ------------------------ 16344 16345 procedure Derive_Subprograms 16346 (Parent_Type : Entity_Id; 16347 Derived_Type : Entity_Id; 16348 Generic_Actual : Entity_Id := Empty) 16349 is 16350 Op_List : constant Elist_Id := 16351 Collect_Primitive_Operations (Parent_Type); 16352 16353 function Check_Derived_Type return Boolean; 16354 -- Check that all the entities derived from Parent_Type are found in 16355 -- the list of primitives of Derived_Type exactly in the same order. 16356 16357 procedure Derive_Interface_Subprogram 16358 (New_Subp : out Entity_Id; 16359 Subp : Entity_Id; 16360 Actual_Subp : Entity_Id); 16361 -- Derive New_Subp from the ultimate alias of the parent subprogram Subp 16362 -- (which is an interface primitive). If Generic_Actual is present then 16363 -- Actual_Subp is the actual subprogram corresponding with the generic 16364 -- subprogram Subp. 16365 16366 ------------------------ 16367 -- Check_Derived_Type -- 16368 ------------------------ 16369 16370 function Check_Derived_Type return Boolean is 16371 E : Entity_Id; 16372 Derived_Elmt : Elmt_Id; 16373 Derived_Op : Entity_Id; 16374 Derived_Ops : Elist_Id; 16375 Parent_Elmt : Elmt_Id; 16376 Parent_Op : Entity_Id; 16377 16378 begin 16379 -- Traverse list of entities in the current scope searching for 16380 -- an incomplete type whose full-view is derived type. 16381 16382 E := First_Entity (Scope (Derived_Type)); 16383 while Present (E) and then E /= Derived_Type loop 16384 if Ekind (E) = E_Incomplete_Type 16385 and then Present (Full_View (E)) 16386 and then Full_View (E) = Derived_Type 16387 then 16388 -- Disable this test if Derived_Type completes an incomplete 16389 -- type because in such case more primitives can be added 16390 -- later to the list of primitives of Derived_Type by routine 16391 -- Process_Incomplete_Dependents. 16392 16393 return True; 16394 end if; 16395 16396 Next_Entity (E); 16397 end loop; 16398 16399 Derived_Ops := Collect_Primitive_Operations (Derived_Type); 16400 16401 Derived_Elmt := First_Elmt (Derived_Ops); 16402 Parent_Elmt := First_Elmt (Op_List); 16403 while Present (Parent_Elmt) loop 16404 Parent_Op := Node (Parent_Elmt); 16405 Derived_Op := Node (Derived_Elmt); 16406 16407 -- At this early stage Derived_Type has no entities with attribute 16408 -- Interface_Alias. In addition, such primitives are always 16409 -- located at the end of the list of primitives of Parent_Type. 16410 -- Therefore, if found we can safely stop processing pending 16411 -- entities. 16412 16413 exit when Present (Interface_Alias (Parent_Op)); 16414 16415 -- Handle hidden entities 16416 16417 if not Is_Predefined_Dispatching_Operation (Parent_Op) 16418 and then Is_Hidden (Parent_Op) 16419 then 16420 if Present (Derived_Op) 16421 and then Primitive_Names_Match (Parent_Op, Derived_Op) 16422 then 16423 Next_Elmt (Derived_Elmt); 16424 end if; 16425 16426 else 16427 if No (Derived_Op) 16428 or else Ekind (Parent_Op) /= Ekind (Derived_Op) 16429 or else not Primitive_Names_Match (Parent_Op, Derived_Op) 16430 then 16431 return False; 16432 end if; 16433 16434 Next_Elmt (Derived_Elmt); 16435 end if; 16436 16437 Next_Elmt (Parent_Elmt); 16438 end loop; 16439 16440 return True; 16441 end Check_Derived_Type; 16442 16443 --------------------------------- 16444 -- Derive_Interface_Subprogram -- 16445 --------------------------------- 16446 16447 procedure Derive_Interface_Subprogram 16448 (New_Subp : out Entity_Id; 16449 Subp : Entity_Id; 16450 Actual_Subp : Entity_Id) 16451 is 16452 Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp); 16453 Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp); 16454 16455 begin 16456 pragma Assert (Is_Interface (Iface_Type)); 16457 16458 Derive_Subprogram 16459 (New_Subp => New_Subp, 16460 Parent_Subp => Iface_Subp, 16461 Derived_Type => Derived_Type, 16462 Parent_Type => Iface_Type, 16463 Actual_Subp => Actual_Subp); 16464 16465 -- Given that this new interface entity corresponds with a primitive 16466 -- of the parent that was not overridden we must leave it associated 16467 -- with its parent primitive to ensure that it will share the same 16468 -- dispatch table slot when overridden. We must set the Alias to Subp 16469 -- (instead of Iface_Subp), and we must fix Is_Abstract_Subprogram 16470 -- (in case we inherited Subp from Iface_Type via a nonabstract 16471 -- generic formal type). 16472 16473 if No (Actual_Subp) then 16474 Set_Alias (New_Subp, Subp); 16475 16476 declare 16477 T : Entity_Id := Find_Dispatching_Type (Subp); 16478 begin 16479 while Etype (T) /= T loop 16480 if Is_Generic_Type (T) and then not Is_Abstract_Type (T) then 16481 Set_Is_Abstract_Subprogram (New_Subp, False); 16482 exit; 16483 end if; 16484 16485 T := Etype (T); 16486 end loop; 16487 end; 16488 16489 -- For instantiations this is not needed since the previous call to 16490 -- Derive_Subprogram leaves the entity well decorated. 16491 16492 else 16493 pragma Assert (Alias (New_Subp) = Actual_Subp); 16494 null; 16495 end if; 16496 end Derive_Interface_Subprogram; 16497 16498 -- Local variables 16499 16500 Alias_Subp : Entity_Id; 16501 Act_List : Elist_Id; 16502 Act_Elmt : Elmt_Id; 16503 Act_Subp : Entity_Id := Empty; 16504 Elmt : Elmt_Id; 16505 Need_Search : Boolean := False; 16506 New_Subp : Entity_Id := Empty; 16507 Parent_Base : Entity_Id; 16508 Subp : Entity_Id; 16509 16510 -- Start of processing for Derive_Subprograms 16511 16512 begin 16513 if Ekind (Parent_Type) = E_Record_Type_With_Private 16514 and then Has_Discriminants (Parent_Type) 16515 and then Present (Full_View (Parent_Type)) 16516 then 16517 Parent_Base := Full_View (Parent_Type); 16518 else 16519 Parent_Base := Parent_Type; 16520 end if; 16521 16522 if Present (Generic_Actual) then 16523 Act_List := Collect_Primitive_Operations (Generic_Actual); 16524 Act_Elmt := First_Elmt (Act_List); 16525 else 16526 Act_List := No_Elist; 16527 Act_Elmt := No_Elmt; 16528 end if; 16529 16530 -- Derive primitives inherited from the parent. Note that if the generic 16531 -- actual is present, this is not really a type derivation, it is a 16532 -- completion within an instance. 16533 16534 -- Case 1: Derived_Type does not implement interfaces 16535 16536 if not Is_Tagged_Type (Derived_Type) 16537 or else (not Has_Interfaces (Derived_Type) 16538 and then not (Present (Generic_Actual) 16539 and then Has_Interfaces (Generic_Actual))) 16540 then 16541 Elmt := First_Elmt (Op_List); 16542 while Present (Elmt) loop 16543 Subp := Node (Elmt); 16544 16545 -- Literals are derived earlier in the process of building the 16546 -- derived type, and are skipped here. 16547 16548 if Ekind (Subp) = E_Enumeration_Literal then 16549 null; 16550 16551 -- The actual is a direct descendant and the common primitive 16552 -- operations appear in the same order. 16553 16554 -- If the generic parent type is present, the derived type is an 16555 -- instance of a formal derived type, and within the instance its 16556 -- operations are those of the actual. We derive from the formal 16557 -- type but make the inherited operations aliases of the 16558 -- corresponding operations of the actual. 16559 16560 else 16561 pragma Assert (No (Node (Act_Elmt)) 16562 or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) 16563 and then 16564 Type_Conformant 16565 (Subp, Node (Act_Elmt), 16566 Skip_Controlling_Formals => True))); 16567 16568 Derive_Subprogram 16569 (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); 16570 16571 if Present (Act_Elmt) then 16572 Next_Elmt (Act_Elmt); 16573 end if; 16574 end if; 16575 16576 Next_Elmt (Elmt); 16577 end loop; 16578 16579 -- Case 2: Derived_Type implements interfaces 16580 16581 else 16582 -- If the parent type has no predefined primitives we remove 16583 -- predefined primitives from the list of primitives of generic 16584 -- actual to simplify the complexity of this algorithm. 16585 16586 if Present (Generic_Actual) then 16587 declare 16588 Has_Predefined_Primitives : Boolean := False; 16589 16590 begin 16591 -- Check if the parent type has predefined primitives 16592 16593 Elmt := First_Elmt (Op_List); 16594 while Present (Elmt) loop 16595 Subp := Node (Elmt); 16596 16597 if Is_Predefined_Dispatching_Operation (Subp) 16598 and then not Comes_From_Source (Ultimate_Alias (Subp)) 16599 then 16600 Has_Predefined_Primitives := True; 16601 exit; 16602 end if; 16603 16604 Next_Elmt (Elmt); 16605 end loop; 16606 16607 -- Remove predefined primitives of Generic_Actual. We must use 16608 -- an auxiliary list because in case of tagged types the value 16609 -- returned by Collect_Primitive_Operations is the value stored 16610 -- in its Primitive_Operations attribute (and we don't want to 16611 -- modify its current contents). 16612 16613 if not Has_Predefined_Primitives then 16614 declare 16615 Aux_List : constant Elist_Id := New_Elmt_List; 16616 16617 begin 16618 Elmt := First_Elmt (Act_List); 16619 while Present (Elmt) loop 16620 Subp := Node (Elmt); 16621 16622 if not Is_Predefined_Dispatching_Operation (Subp) 16623 or else Comes_From_Source (Subp) 16624 then 16625 Append_Elmt (Subp, Aux_List); 16626 end if; 16627 16628 Next_Elmt (Elmt); 16629 end loop; 16630 16631 Act_List := Aux_List; 16632 end; 16633 end if; 16634 16635 Act_Elmt := First_Elmt (Act_List); 16636 Act_Subp := Node (Act_Elmt); 16637 end; 16638 end if; 16639 16640 -- Stage 1: If the generic actual is not present we derive the 16641 -- primitives inherited from the parent type. If the generic parent 16642 -- type is present, the derived type is an instance of a formal 16643 -- derived type, and within the instance its operations are those of 16644 -- the actual. We derive from the formal type but make the inherited 16645 -- operations aliases of the corresponding operations of the actual. 16646 16647 Elmt := First_Elmt (Op_List); 16648 while Present (Elmt) loop 16649 Subp := Node (Elmt); 16650 Alias_Subp := Ultimate_Alias (Subp); 16651 16652 -- Do not derive internal entities of the parent that link 16653 -- interface primitives with their covering primitive. These 16654 -- entities will be added to this type when frozen. 16655 16656 if Present (Interface_Alias (Subp)) then 16657 goto Continue; 16658 end if; 16659 16660 -- If the generic actual is present find the corresponding 16661 -- operation in the generic actual. If the parent type is a 16662 -- direct ancestor of the derived type then, even if it is an 16663 -- interface, the operations are inherited from the primary 16664 -- dispatch table and are in the proper order. If we detect here 16665 -- that primitives are not in the same order we traverse the list 16666 -- of primitive operations of the actual to find the one that 16667 -- implements the interface primitive. 16668 16669 if Need_Search 16670 or else 16671 (Present (Generic_Actual) 16672 and then Present (Act_Subp) 16673 and then not 16674 (Primitive_Names_Match (Subp, Act_Subp) 16675 and then 16676 Type_Conformant (Subp, Act_Subp, 16677 Skip_Controlling_Formals => True))) 16678 then 16679 pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual, 16680 Use_Full_View => True)); 16681 16682 -- Remember that we need searching for all pending primitives 16683 16684 Need_Search := True; 16685 16686 -- Handle entities associated with interface primitives 16687 16688 if Present (Alias_Subp) 16689 and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) 16690 and then not Is_Predefined_Dispatching_Operation (Subp) 16691 then 16692 -- Search for the primitive in the homonym chain 16693 16694 Act_Subp := 16695 Find_Primitive_Covering_Interface 16696 (Tagged_Type => Generic_Actual, 16697 Iface_Prim => Alias_Subp); 16698 16699 -- Previous search may not locate primitives covering 16700 -- interfaces defined in generics units or instantiations. 16701 -- (it fails if the covering primitive has formals whose 16702 -- type is also defined in generics or instantiations). 16703 -- In such case we search in the list of primitives of the 16704 -- generic actual for the internal entity that links the 16705 -- interface primitive and the covering primitive. 16706 16707 if No (Act_Subp) 16708 and then Is_Generic_Type (Parent_Type) 16709 then 16710 -- This code has been designed to handle only generic 16711 -- formals that implement interfaces that are defined 16712 -- in a generic unit or instantiation. If this code is 16713 -- needed for other cases we must review it because 16714 -- (given that it relies on Original_Location to locate 16715 -- the primitive of Generic_Actual that covers the 16716 -- interface) it could leave linked through attribute 16717 -- Alias entities of unrelated instantiations). 16718 16719 pragma Assert 16720 (Is_Generic_Unit 16721 (Scope (Find_Dispatching_Type (Alias_Subp))) 16722 or else 16723 Instantiation_Depth 16724 (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); 16725 16726 declare 16727 Iface_Prim_Loc : constant Source_Ptr := 16728 Original_Location (Sloc (Alias_Subp)); 16729 16730 Elmt : Elmt_Id; 16731 Prim : Entity_Id; 16732 16733 begin 16734 Elmt := 16735 First_Elmt (Primitive_Operations (Generic_Actual)); 16736 16737 Search : while Present (Elmt) loop 16738 Prim := Node (Elmt); 16739 16740 if Present (Interface_Alias (Prim)) 16741 and then Original_Location 16742 (Sloc (Interface_Alias (Prim))) = 16743 Iface_Prim_Loc 16744 then 16745 Act_Subp := Alias (Prim); 16746 exit Search; 16747 end if; 16748 16749 Next_Elmt (Elmt); 16750 end loop Search; 16751 end; 16752 end if; 16753 16754 pragma Assert (Present (Act_Subp) 16755 or else Is_Abstract_Type (Generic_Actual) 16756 or else Serious_Errors_Detected > 0); 16757 16758 -- Handle predefined primitives plus the rest of user-defined 16759 -- primitives 16760 16761 else 16762 Act_Elmt := First_Elmt (Act_List); 16763 while Present (Act_Elmt) loop 16764 Act_Subp := Node (Act_Elmt); 16765 16766 exit when Primitive_Names_Match (Subp, Act_Subp) 16767 and then Type_Conformant 16768 (Subp, Act_Subp, 16769 Skip_Controlling_Formals => True) 16770 and then No (Interface_Alias (Act_Subp)); 16771 16772 Next_Elmt (Act_Elmt); 16773 end loop; 16774 16775 if No (Act_Elmt) then 16776 Act_Subp := Empty; 16777 end if; 16778 end if; 16779 end if; 16780 16781 -- Case 1: If the parent is a limited interface then it has the 16782 -- predefined primitives of synchronized interfaces. However, the 16783 -- actual type may be a non-limited type and hence it does not 16784 -- have such primitives. 16785 16786 if Present (Generic_Actual) 16787 and then not Present (Act_Subp) 16788 and then Is_Limited_Interface (Parent_Base) 16789 and then Is_Predefined_Interface_Primitive (Subp) 16790 then 16791 null; 16792 16793 -- Case 2: Inherit entities associated with interfaces that were 16794 -- not covered by the parent type. We exclude here null interface 16795 -- primitives because they do not need special management. 16796 16797 -- We also exclude interface operations that are renamings. If the 16798 -- subprogram is an explicit renaming of an interface primitive, 16799 -- it is a regular primitive operation, and the presence of its 16800 -- alias is not relevant: it has to be derived like any other 16801 -- primitive. 16802 16803 elsif Present (Alias (Subp)) 16804 and then Nkind (Unit_Declaration_Node (Subp)) /= 16805 N_Subprogram_Renaming_Declaration 16806 and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) 16807 and then not 16808 (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification 16809 and then Null_Present (Parent (Alias_Subp))) 16810 then 16811 -- If this is an abstract private type then we transfer the 16812 -- derivation of the interface primitive from the partial view 16813 -- to the full view. This is safe because all the interfaces 16814 -- must be visible in the partial view. Done to avoid adding 16815 -- a new interface derivation to the private part of the 16816 -- enclosing package; otherwise this new derivation would be 16817 -- decorated as hidden when the analysis of the enclosing 16818 -- package completes. 16819 16820 if Is_Abstract_Type (Derived_Type) 16821 and then In_Private_Part (Current_Scope) 16822 and then Has_Private_Declaration (Derived_Type) 16823 then 16824 declare 16825 Partial_View : Entity_Id; 16826 Elmt : Elmt_Id; 16827 Ent : Entity_Id; 16828 16829 begin 16830 Partial_View := First_Entity (Current_Scope); 16831 loop 16832 exit when No (Partial_View) 16833 or else (Has_Private_Declaration (Partial_View) 16834 and then 16835 Full_View (Partial_View) = Derived_Type); 16836 16837 Next_Entity (Partial_View); 16838 end loop; 16839 16840 -- If the partial view was not found then the source code 16841 -- has errors and the derivation is not needed. 16842 16843 if Present (Partial_View) then 16844 Elmt := 16845 First_Elmt (Primitive_Operations (Partial_View)); 16846 while Present (Elmt) loop 16847 Ent := Node (Elmt); 16848 16849 if Present (Alias (Ent)) 16850 and then Ultimate_Alias (Ent) = Alias (Subp) 16851 then 16852 Append_Elmt 16853 (Ent, Primitive_Operations (Derived_Type)); 16854 exit; 16855 end if; 16856 16857 Next_Elmt (Elmt); 16858 end loop; 16859 16860 -- If the interface primitive was not found in the 16861 -- partial view then this interface primitive was 16862 -- overridden. We add a derivation to activate in 16863 -- Derive_Progenitor_Subprograms the machinery to 16864 -- search for it. 16865 16866 if No (Elmt) then 16867 Derive_Interface_Subprogram 16868 (New_Subp => New_Subp, 16869 Subp => Subp, 16870 Actual_Subp => Act_Subp); 16871 end if; 16872 end if; 16873 end; 16874 else 16875 Derive_Interface_Subprogram 16876 (New_Subp => New_Subp, 16877 Subp => Subp, 16878 Actual_Subp => Act_Subp); 16879 end if; 16880 16881 -- Case 3: Common derivation 16882 16883 else 16884 Derive_Subprogram 16885 (New_Subp => New_Subp, 16886 Parent_Subp => Subp, 16887 Derived_Type => Derived_Type, 16888 Parent_Type => Parent_Base, 16889 Actual_Subp => Act_Subp); 16890 end if; 16891 16892 -- No need to update Act_Elm if we must search for the 16893 -- corresponding operation in the generic actual 16894 16895 if not Need_Search 16896 and then Present (Act_Elmt) 16897 then 16898 Next_Elmt (Act_Elmt); 16899 Act_Subp := Node (Act_Elmt); 16900 end if; 16901 16902 <<Continue>> 16903 Next_Elmt (Elmt); 16904 end loop; 16905 16906 -- Inherit additional operations from progenitors. If the derived 16907 -- type is a generic actual, there are not new primitive operations 16908 -- for the type because it has those of the actual, and therefore 16909 -- nothing needs to be done. The renamings generated above are not 16910 -- primitive operations, and their purpose is simply to make the 16911 -- proper operations visible within an instantiation. 16912 16913 if No (Generic_Actual) then 16914 Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); 16915 end if; 16916 end if; 16917 16918 -- Final check: Direct descendants must have their primitives in the 16919 -- same order. We exclude from this test untagged types and instances 16920 -- of formal derived types. We skip this test if we have already 16921 -- reported serious errors in the sources. 16922 16923 pragma Assert (not Is_Tagged_Type (Derived_Type) 16924 or else Present (Generic_Actual) 16925 or else Serious_Errors_Detected > 0 16926 or else Check_Derived_Type); 16927 end Derive_Subprograms; 16928 16929 -------------------------------- 16930 -- Derived_Standard_Character -- 16931 -------------------------------- 16932 16933 procedure Derived_Standard_Character 16934 (N : Node_Id; 16935 Parent_Type : Entity_Id; 16936 Derived_Type : Entity_Id) 16937 is 16938 Loc : constant Source_Ptr := Sloc (N); 16939 Def : constant Node_Id := Type_Definition (N); 16940 Indic : constant Node_Id := Subtype_Indication (Def); 16941 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 16942 Implicit_Base : constant Entity_Id := 16943 Create_Itype 16944 (E_Enumeration_Type, N, Derived_Type, 'B'); 16945 16946 Lo : Node_Id; 16947 Hi : Node_Id; 16948 16949 begin 16950 Discard_Node (Process_Subtype (Indic, N)); 16951 16952 Set_Etype (Implicit_Base, Parent_Base); 16953 Set_Size_Info (Implicit_Base, Root_Type (Parent_Type)); 16954 Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type))); 16955 16956 Set_Is_Character_Type (Implicit_Base, True); 16957 Set_Has_Delayed_Freeze (Implicit_Base); 16958 16959 -- The bounds of the implicit base are the bounds of the parent base. 16960 -- Note that their type is the parent base. 16961 16962 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); 16963 Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); 16964 16965 Set_Scalar_Range (Implicit_Base, 16966 Make_Range (Loc, 16967 Low_Bound => Lo, 16968 High_Bound => Hi)); 16969 16970 Conditional_Delay (Derived_Type, Parent_Type); 16971 16972 Mutate_Ekind (Derived_Type, E_Enumeration_Subtype); 16973 Set_Etype (Derived_Type, Implicit_Base); 16974 Set_Size_Info (Derived_Type, Parent_Type); 16975 16976 if not Known_RM_Size (Derived_Type) then 16977 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 16978 end if; 16979 16980 Set_Is_Character_Type (Derived_Type, True); 16981 16982 if Nkind (Indic) /= N_Subtype_Indication then 16983 16984 -- If no explicit constraint, the bounds are those 16985 -- of the parent type. 16986 16987 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type)); 16988 Hi := New_Copy_Tree (Type_High_Bound (Parent_Type)); 16989 Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi)); 16990 end if; 16991 16992 Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); 16993 16994 -- Because the implicit base is used in the conversion of the bounds, we 16995 -- have to freeze it now. This is similar to what is done for numeric 16996 -- types, and it equally suspicious, but otherwise a nonstatic bound 16997 -- will have a reference to an unfrozen type, which is rejected by Gigi 16998 -- (???). This requires specific care for definition of stream 16999 -- attributes. For details, see comments at the end of 17000 -- Build_Derived_Numeric_Type. 17001 17002 Freeze_Before (N, Implicit_Base); 17003 end Derived_Standard_Character; 17004 17005 ------------------------------ 17006 -- Derived_Type_Declaration -- 17007 ------------------------------ 17008 17009 procedure Derived_Type_Declaration 17010 (T : Entity_Id; 17011 N : Node_Id; 17012 Is_Completion : Boolean) 17013 is 17014 Parent_Type : Entity_Id; 17015 17016 function Comes_From_Generic (Typ : Entity_Id) return Boolean; 17017 -- Check whether the parent type is a generic formal, or derives 17018 -- directly or indirectly from one. 17019 17020 ------------------------ 17021 -- Comes_From_Generic -- 17022 ------------------------ 17023 17024 function Comes_From_Generic (Typ : Entity_Id) return Boolean is 17025 begin 17026 if Is_Generic_Type (Typ) then 17027 return True; 17028 17029 elsif Is_Generic_Type (Root_Type (Parent_Type)) then 17030 return True; 17031 17032 elsif Is_Private_Type (Typ) 17033 and then Present (Full_View (Typ)) 17034 and then Is_Generic_Type (Root_Type (Full_View (Typ))) 17035 then 17036 return True; 17037 17038 elsif Is_Generic_Actual_Type (Typ) then 17039 return True; 17040 17041 else 17042 return False; 17043 end if; 17044 end Comes_From_Generic; 17045 17046 -- Local variables 17047 17048 Def : constant Node_Id := Type_Definition (N); 17049 Iface_Def : Node_Id; 17050 Indic : constant Node_Id := Subtype_Indication (Def); 17051 Extension : constant Node_Id := Record_Extension_Part (Def); 17052 Parent_Node : Node_Id; 17053 Taggd : Boolean; 17054 17055 -- Start of processing for Derived_Type_Declaration 17056 17057 begin 17058 Parent_Type := Find_Type_Of_Subtype_Indic (Indic); 17059 17060 if SPARK_Mode = On 17061 and then Is_Tagged_Type (Parent_Type) 17062 then 17063 declare 17064 Partial_View : constant Entity_Id := 17065 Incomplete_Or_Partial_View (Parent_Type); 17066 17067 begin 17068 -- If the partial view was not found then the parent type is not 17069 -- a private type. Otherwise check if the partial view is a tagged 17070 -- private type. 17071 17072 if Present (Partial_View) 17073 and then Is_Private_Type (Partial_View) 17074 and then not Is_Tagged_Type (Partial_View) 17075 then 17076 Error_Msg_NE 17077 ("cannot derive from & declared as untagged private " 17078 & "(SPARK RM 3.4(1))", N, Partial_View); 17079 end if; 17080 end; 17081 end if; 17082 17083 -- Ada 2005 (AI-251): In case of interface derivation check that the 17084 -- parent is also an interface. 17085 17086 if Interface_Present (Def) then 17087 if not Is_Interface (Parent_Type) then 17088 Diagnose_Interface (Indic, Parent_Type); 17089 17090 else 17091 Parent_Node := Parent (Base_Type (Parent_Type)); 17092 Iface_Def := Type_Definition (Parent_Node); 17093 17094 -- Ada 2005 (AI-251): Limited interfaces can only inherit from 17095 -- other limited interfaces. 17096 17097 if Limited_Present (Def) then 17098 if Limited_Present (Iface_Def) then 17099 null; 17100 17101 elsif Protected_Present (Iface_Def) then 17102 Error_Msg_NE 17103 ("descendant of & must be declared as a protected " 17104 & "interface", N, Parent_Type); 17105 17106 elsif Synchronized_Present (Iface_Def) then 17107 Error_Msg_NE 17108 ("descendant of & must be declared as a synchronized " 17109 & "interface", N, Parent_Type); 17110 17111 elsif Task_Present (Iface_Def) then 17112 Error_Msg_NE 17113 ("descendant of & must be declared as a task interface", 17114 N, Parent_Type); 17115 17116 else 17117 Error_Msg_N 17118 ("(Ada 2005) limited interface cannot inherit from " 17119 & "non-limited interface", Indic); 17120 end if; 17121 17122 -- Ada 2005 (AI-345): Non-limited interfaces can only inherit 17123 -- from non-limited or limited interfaces. 17124 17125 elsif not Protected_Present (Def) 17126 and then not Synchronized_Present (Def) 17127 and then not Task_Present (Def) 17128 then 17129 if Limited_Present (Iface_Def) then 17130 null; 17131 17132 elsif Protected_Present (Iface_Def) then 17133 Error_Msg_NE 17134 ("descendant of & must be declared as a protected " 17135 & "interface", N, Parent_Type); 17136 17137 elsif Synchronized_Present (Iface_Def) then 17138 Error_Msg_NE 17139 ("descendant of & must be declared as a synchronized " 17140 & "interface", N, Parent_Type); 17141 17142 elsif Task_Present (Iface_Def) then 17143 Error_Msg_NE 17144 ("descendant of & must be declared as a task interface", 17145 N, Parent_Type); 17146 else 17147 null; 17148 end if; 17149 end if; 17150 end if; 17151 end if; 17152 17153 if Is_Tagged_Type (Parent_Type) 17154 and then Is_Concurrent_Type (Parent_Type) 17155 and then not Is_Interface (Parent_Type) 17156 then 17157 Error_Msg_N 17158 ("parent type of a record extension cannot be a synchronized " 17159 & "tagged type (RM 3.9.1 (3/1))", N); 17160 Set_Etype (T, Any_Type); 17161 return; 17162 end if; 17163 17164 -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor 17165 -- interfaces 17166 17167 if Is_Tagged_Type (Parent_Type) 17168 and then Is_Non_Empty_List (Interface_List (Def)) 17169 then 17170 declare 17171 Intf : Node_Id; 17172 T : Entity_Id; 17173 17174 begin 17175 Intf := First (Interface_List (Def)); 17176 while Present (Intf) loop 17177 T := Find_Type_Of_Subtype_Indic (Intf); 17178 17179 if not Is_Interface (T) then 17180 Diagnose_Interface (Intf, T); 17181 17182 -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow 17183 -- a limited type from having a nonlimited progenitor. 17184 17185 elsif (Limited_Present (Def) 17186 or else (not Is_Interface (Parent_Type) 17187 and then Is_Limited_Type (Parent_Type))) 17188 and then not Is_Limited_Interface (T) 17189 then 17190 Error_Msg_NE 17191 ("progenitor interface& of limited type must be limited", 17192 N, T); 17193 end if; 17194 17195 Next (Intf); 17196 end loop; 17197 end; 17198 17199 -- Check consistency of any nonoverridable aspects that are 17200 -- inherited from multiple sources. 17201 17202 Check_Inherited_Nonoverridable_Aspects 17203 (Inheritor => T, 17204 Interface_List => Interface_List (Def), 17205 Parent_Type => Parent_Type); 17206 end if; 17207 17208 if Parent_Type = Any_Type 17209 or else Etype (Parent_Type) = Any_Type 17210 or else (Is_Class_Wide_Type (Parent_Type) 17211 and then Etype (Parent_Type) = T) 17212 then 17213 -- If Parent_Type is undefined or illegal, make new type into a 17214 -- subtype of Any_Type, and set a few attributes to prevent cascaded 17215 -- errors. If this is a self-definition, emit error now. 17216 17217 if T = Parent_Type or else T = Etype (Parent_Type) then 17218 Error_Msg_N ("type cannot be used in its own definition", Indic); 17219 end if; 17220 17221 Mutate_Ekind (T, Ekind (Parent_Type)); 17222 Set_Etype (T, Any_Type); 17223 Set_Scalar_Range (T, Scalar_Range (Any_Type)); 17224 17225 -- Initialize the list of primitive operations to an empty list, 17226 -- to cover tagged types as well as untagged types. For untagged 17227 -- types this is used either to analyze the call as legal when 17228 -- Extensions_Allowed is True, or to issue a better error message 17229 -- otherwise. 17230 17231 Set_Direct_Primitive_Operations (T, New_Elmt_List); 17232 17233 return; 17234 end if; 17235 17236 -- Ada 2005 (AI-251): The case in which the parent of the full-view is 17237 -- an interface is special because the list of interfaces in the full 17238 -- view can be given in any order. For example: 17239 17240 -- type A is interface; 17241 -- type B is interface and A; 17242 -- type D is new B with private; 17243 -- private 17244 -- type D is new A and B with null record; -- 1 -- 17245 17246 -- In this case we perform the following transformation of -1-: 17247 17248 -- type D is new B and A with null record; 17249 17250 -- If the parent of the full-view covers the parent of the partial-view 17251 -- we have two possible cases: 17252 17253 -- 1) They have the same parent 17254 -- 2) The parent of the full-view implements some further interfaces 17255 17256 -- In both cases we do not need to perform the transformation. In the 17257 -- first case the source program is correct and the transformation is 17258 -- not needed; in the second case the source program does not fulfill 17259 -- the no-hidden interfaces rule (AI-396) and the error will be reported 17260 -- later. 17261 17262 -- This transformation not only simplifies the rest of the analysis of 17263 -- this type declaration but also simplifies the correct generation of 17264 -- the object layout to the expander. 17265 17266 if In_Private_Part (Current_Scope) 17267 and then Is_Interface (Parent_Type) 17268 then 17269 declare 17270 Partial_View : Entity_Id; 17271 Partial_View_Parent : Entity_Id; 17272 17273 function Reorder_Interfaces return Boolean; 17274 -- Look for an interface in the full view's interface list that 17275 -- matches the parent type of the partial view, and when found, 17276 -- rewrite the full view's parent with the partial view's parent, 17277 -- append the full view's original parent to the interface list, 17278 -- recursively call Derived_Type_Definition on the full type, and 17279 -- return True. If a match is not found, return False. 17280 -- ??? This seems broken in the case of generic packages. 17281 17282 ------------------------ 17283 -- Reorder_Interfaces -- 17284 ------------------------ 17285 17286 function Reorder_Interfaces return Boolean is 17287 Iface : Node_Id; 17288 New_Iface : Node_Id; 17289 begin 17290 Iface := First (Interface_List (Def)); 17291 while Present (Iface) loop 17292 if Etype (Iface) = Etype (Partial_View) then 17293 Rewrite (Subtype_Indication (Def), 17294 New_Copy (Subtype_Indication (Parent (Partial_View)))); 17295 17296 New_Iface := 17297 Make_Identifier (Sloc (N), Chars (Parent_Type)); 17298 Append (New_Iface, Interface_List (Def)); 17299 17300 -- Analyze the transformed code 17301 17302 Derived_Type_Declaration (T, N, Is_Completion); 17303 return True; 17304 end if; 17305 17306 Next (Iface); 17307 end loop; 17308 return False; 17309 end Reorder_Interfaces; 17310 17311 begin 17312 -- Look for the associated private type declaration 17313 17314 Partial_View := Incomplete_Or_Partial_View (T); 17315 17316 -- If the partial view was not found then the source code has 17317 -- errors and the transformation is not needed. 17318 17319 if Present (Partial_View) then 17320 Partial_View_Parent := Etype (Partial_View); 17321 17322 -- If the parent of the full-view covers the parent of the 17323 -- partial-view we have nothing else to do. 17324 17325 if Interface_Present_In_Ancestor 17326 (Parent_Type, Partial_View_Parent) 17327 then 17328 null; 17329 17330 -- Traverse the list of interfaces of the full view to look 17331 -- for the parent of the partial view and reorder the 17332 -- interfaces to match the order in the partial view, 17333 -- if needed. 17334 17335 else 17336 17337 if Reorder_Interfaces then 17338 -- Having the interfaces listed in any order is legal. 17339 -- However, the compiler does not properly handle 17340 -- different orders between partial and full views in 17341 -- generic units. We give a warning about the order 17342 -- mismatch, so the user can work around this problem. 17343 17344 Error_Msg_N ("??full declaration does not respect " & 17345 "partial declaration order", T); 17346 Error_Msg_N ("\??consider reordering", T); 17347 17348 return; 17349 end if; 17350 end if; 17351 end if; 17352 end; 17353 end if; 17354 17355 -- Only composite types other than array types are allowed to have 17356 -- discriminants. 17357 17358 if Present (Discriminant_Specifications (N)) then 17359 if (Is_Elementary_Type (Parent_Type) 17360 or else 17361 Is_Array_Type (Parent_Type)) 17362 and then not Error_Posted (N) 17363 then 17364 Error_Msg_N 17365 ("elementary or array type cannot have discriminants", 17366 Defining_Identifier (First (Discriminant_Specifications (N)))); 17367 17368 -- Unset Has_Discriminants flag to prevent cascaded errors, but 17369 -- only if we are not already processing a malformed syntax tree. 17370 17371 if Is_Type (T) then 17372 Set_Has_Discriminants (T, False); 17373 end if; 17374 end if; 17375 end if; 17376 17377 -- In Ada 83, a derived type defined in a package specification cannot 17378 -- be used for further derivation until the end of its visible part. 17379 -- Note that derivation in the private part of the package is allowed. 17380 17381 if Ada_Version = Ada_83 17382 and then Is_Derived_Type (Parent_Type) 17383 and then In_Visible_Part (Scope (Parent_Type)) 17384 then 17385 if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then 17386 Error_Msg_N 17387 ("(Ada 83) premature use of type for derivation", Indic); 17388 end if; 17389 end if; 17390 17391 -- Check for early use of incomplete or private type 17392 17393 if Ekind (Parent_Type) in E_Void | E_Incomplete_Type then 17394 Error_Msg_N ("premature derivation of incomplete type", Indic); 17395 return; 17396 17397 elsif (Is_Incomplete_Or_Private_Type (Parent_Type) 17398 and then not Comes_From_Generic (Parent_Type)) 17399 or else Has_Private_Component (Parent_Type) 17400 then 17401 -- The ancestor type of a formal type can be incomplete, in which 17402 -- case only the operations of the partial view are available in the 17403 -- generic. Subsequent checks may be required when the full view is 17404 -- analyzed to verify that a derivation from a tagged type has an 17405 -- extension. 17406 17407 if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then 17408 null; 17409 17410 elsif No (Underlying_Type (Parent_Type)) 17411 or else Has_Private_Component (Parent_Type) 17412 then 17413 Error_Msg_N 17414 ("premature derivation of derived or private type", Indic); 17415 17416 -- Flag the type itself as being in error, this prevents some 17417 -- nasty problems with subsequent uses of the malformed type. 17418 17419 Set_Error_Posted (T); 17420 17421 -- Check that within the immediate scope of an untagged partial 17422 -- view it's illegal to derive from the partial view if the 17423 -- full view is tagged. (7.3(7)) 17424 17425 -- We verify that the Parent_Type is a partial view by checking 17426 -- that it is not a Full_Type_Declaration (i.e. a private type or 17427 -- private extension declaration), to distinguish a partial view 17428 -- from a derivation from a private type which also appears as 17429 -- E_Private_Type. If the parent base type is not declared in an 17430 -- enclosing scope there is no need to check. 17431 17432 elsif Present (Full_View (Parent_Type)) 17433 and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration 17434 and then not Is_Tagged_Type (Parent_Type) 17435 and then Is_Tagged_Type (Full_View (Parent_Type)) 17436 and then In_Open_Scopes (Scope (Base_Type (Parent_Type))) 17437 then 17438 Error_Msg_N 17439 ("premature derivation from type with tagged full view", 17440 Indic); 17441 end if; 17442 end if; 17443 17444 -- Check that form of derivation is appropriate 17445 17446 Taggd := Is_Tagged_Type (Parent_Type); 17447 17448 -- Set the parent type to the class-wide type's specific type in this 17449 -- case to prevent cascading errors 17450 17451 if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then 17452 Error_Msg_N ("parent type must not be a class-wide type", Indic); 17453 Set_Etype (T, Etype (Parent_Type)); 17454 return; 17455 end if; 17456 17457 if Present (Extension) and then not Taggd then 17458 Error_Msg_N 17459 ("type derived from untagged type cannot have extension", Indic); 17460 17461 elsif No (Extension) and then Taggd then 17462 17463 -- If this declaration is within a private part (or body) of a 17464 -- generic instantiation then the derivation is allowed (the parent 17465 -- type can only appear tagged in this case if it's a generic actual 17466 -- type, since it would otherwise have been rejected in the analysis 17467 -- of the generic template). 17468 17469 if not Is_Generic_Actual_Type (Parent_Type) 17470 or else In_Visible_Part (Scope (Parent_Type)) 17471 then 17472 if Is_Class_Wide_Type (Parent_Type) then 17473 Error_Msg_N 17474 ("parent type must not be a class-wide type", Indic); 17475 17476 -- Use specific type to prevent cascaded errors. 17477 17478 Parent_Type := Etype (Parent_Type); 17479 17480 else 17481 Error_Msg_N 17482 ("type derived from tagged type must have extension", Indic); 17483 end if; 17484 end if; 17485 end if; 17486 17487 -- AI-443: Synchronized formal derived types require a private 17488 -- extension. There is no point in checking the ancestor type or 17489 -- the progenitors since the construct is wrong to begin with. 17490 17491 if Ada_Version >= Ada_2005 17492 and then Is_Generic_Type (T) 17493 and then Present (Original_Node (N)) 17494 then 17495 declare 17496 Decl : constant Node_Id := Original_Node (N); 17497 17498 begin 17499 if Nkind (Decl) = N_Formal_Type_Declaration 17500 and then Nkind (Formal_Type_Definition (Decl)) = 17501 N_Formal_Derived_Type_Definition 17502 and then Synchronized_Present (Formal_Type_Definition (Decl)) 17503 and then No (Extension) 17504 17505 -- Avoid emitting a duplicate error message 17506 17507 and then not Error_Posted (Indic) 17508 then 17509 Error_Msg_N 17510 ("synchronized derived type must have extension", N); 17511 end if; 17512 end; 17513 end if; 17514 17515 if Null_Exclusion_Present (Def) 17516 and then not Is_Access_Type (Parent_Type) 17517 then 17518 Error_Msg_N ("null exclusion can only apply to an access type", N); 17519 end if; 17520 17521 Check_Wide_Character_Restriction (Parent_Type, Indic); 17522 17523 -- Avoid deriving parent primitives of underlying record views 17524 17525 Build_Derived_Type (N, Parent_Type, T, Is_Completion, 17526 Derive_Subps => not Is_Underlying_Record_View (T)); 17527 17528 -- AI-419: The parent type of an explicitly limited derived type must 17529 -- be a limited type or a limited interface. 17530 17531 if Limited_Present (Def) then 17532 Set_Is_Limited_Record (T); 17533 17534 if Is_Interface (T) then 17535 Set_Is_Limited_Interface (T); 17536 end if; 17537 17538 if not Is_Limited_Type (Parent_Type) 17539 and then 17540 (not Is_Interface (Parent_Type) 17541 or else not Is_Limited_Interface (Parent_Type)) 17542 then 17543 -- AI05-0096: a derivation in the private part of an instance is 17544 -- legal if the generic formal is untagged limited, and the actual 17545 -- is non-limited. 17546 17547 if Is_Generic_Actual_Type (Parent_Type) 17548 and then In_Private_Part (Current_Scope) 17549 and then 17550 not Is_Tagged_Type 17551 (Generic_Parent_Type (Parent (Parent_Type))) 17552 then 17553 null; 17554 17555 else 17556 Error_Msg_NE 17557 ("parent type& of limited type must be limited", 17558 N, Parent_Type); 17559 end if; 17560 end if; 17561 end if; 17562 end Derived_Type_Declaration; 17563 17564 ------------------------ 17565 -- Diagnose_Interface -- 17566 ------------------------ 17567 17568 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is 17569 begin 17570 if not Is_Interface (E) and then E /= Any_Type then 17571 Error_Msg_NE ("(Ada 2005) & must be an interface", N, E); 17572 end if; 17573 end Diagnose_Interface; 17574 17575 ---------------------------------- 17576 -- Enumeration_Type_Declaration -- 17577 ---------------------------------- 17578 17579 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is 17580 Ev : Uint; 17581 L : Node_Id; 17582 R_Node : Node_Id; 17583 B_Node : Node_Id; 17584 17585 begin 17586 -- Create identifier node representing lower bound 17587 17588 B_Node := New_Node (N_Identifier, Sloc (Def)); 17589 L := First (Literals (Def)); 17590 Set_Chars (B_Node, Chars (L)); 17591 Set_Entity (B_Node, L); 17592 Set_Etype (B_Node, T); 17593 Set_Is_Static_Expression (B_Node, True); 17594 17595 R_Node := New_Node (N_Range, Sloc (Def)); 17596 Set_Low_Bound (R_Node, B_Node); 17597 17598 Mutate_Ekind (T, E_Enumeration_Type); 17599 Set_First_Literal (T, L); 17600 Set_Etype (T, T); 17601 Set_Is_Constrained (T); 17602 17603 Ev := Uint_0; 17604 17605 -- Loop through literals of enumeration type setting pos and rep values 17606 -- except that if the Ekind is already set, then it means the literal 17607 -- was already constructed (case of a derived type declaration and we 17608 -- should not disturb the Pos and Rep values. 17609 17610 while Present (L) loop 17611 if Ekind (L) /= E_Enumeration_Literal then 17612 Mutate_Ekind (L, E_Enumeration_Literal); 17613 Set_Enumeration_Pos (L, Ev); 17614 Set_Enumeration_Rep (L, Ev); 17615 Set_Is_Known_Valid (L, True); 17616 end if; 17617 17618 Set_Etype (L, T); 17619 New_Overloaded_Entity (L); 17620 Generate_Definition (L); 17621 Set_Convention (L, Convention_Intrinsic); 17622 17623 -- Case of character literal 17624 17625 if Nkind (L) = N_Defining_Character_Literal then 17626 Set_Is_Character_Type (T, True); 17627 17628 -- Check violation of No_Wide_Characters 17629 17630 if Restriction_Check_Required (No_Wide_Characters) then 17631 Get_Name_String (Chars (L)); 17632 17633 if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then 17634 Check_Restriction (No_Wide_Characters, L); 17635 end if; 17636 end if; 17637 end if; 17638 17639 Ev := Ev + 1; 17640 Next (L); 17641 end loop; 17642 17643 -- Now create a node representing upper bound 17644 17645 B_Node := New_Node (N_Identifier, Sloc (Def)); 17646 Set_Chars (B_Node, Chars (Last (Literals (Def)))); 17647 Set_Entity (B_Node, Last (Literals (Def))); 17648 Set_Etype (B_Node, T); 17649 Set_Is_Static_Expression (B_Node, True); 17650 17651 Set_High_Bound (R_Node, B_Node); 17652 17653 -- Initialize various fields of the type. Some of this information 17654 -- may be overwritten later through rep. clauses. 17655 17656 Set_Scalar_Range (T, R_Node); 17657 Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); 17658 Set_Enum_Esize (T); 17659 Set_Enum_Pos_To_Rep (T, Empty); 17660 17661 -- Set Discard_Names if configuration pragma set, or if there is 17662 -- a parameterless pragma in the current declarative region 17663 17664 if Global_Discard_Names or else Discard_Names (Scope (T)) then 17665 Set_Discard_Names (T); 17666 end if; 17667 17668 -- Process end label if there is one 17669 17670 if Present (Def) then 17671 Process_End_Label (Def, 'e', T); 17672 end if; 17673 end Enumeration_Type_Declaration; 17674 17675 --------------------------------- 17676 -- Expand_To_Stored_Constraint -- 17677 --------------------------------- 17678 17679 function Expand_To_Stored_Constraint 17680 (Typ : Entity_Id; 17681 Constraint : Elist_Id) return Elist_Id 17682 is 17683 Explicitly_Discriminated_Type : Entity_Id; 17684 Expansion : Elist_Id; 17685 Discriminant : Entity_Id; 17686 17687 function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id; 17688 -- Find the nearest type that actually specifies discriminants 17689 17690 --------------------------------- 17691 -- Type_With_Explicit_Discrims -- 17692 --------------------------------- 17693 17694 function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is 17695 Typ : constant E := Base_Type (Id); 17696 17697 begin 17698 if Ekind (Typ) in Incomplete_Or_Private_Kind then 17699 if Present (Full_View (Typ)) then 17700 return Type_With_Explicit_Discrims (Full_View (Typ)); 17701 end if; 17702 17703 else 17704 if Has_Discriminants (Typ) then 17705 return Typ; 17706 end if; 17707 end if; 17708 17709 if Etype (Typ) = Typ then 17710 return Empty; 17711 elsif Has_Discriminants (Typ) then 17712 return Typ; 17713 else 17714 return Type_With_Explicit_Discrims (Etype (Typ)); 17715 end if; 17716 17717 end Type_With_Explicit_Discrims; 17718 17719 -- Start of processing for Expand_To_Stored_Constraint 17720 17721 begin 17722 if No (Constraint) or else Is_Empty_Elmt_List (Constraint) then 17723 return No_Elist; 17724 end if; 17725 17726 Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ); 17727 17728 if No (Explicitly_Discriminated_Type) then 17729 return No_Elist; 17730 end if; 17731 17732 Expansion := New_Elmt_List; 17733 17734 Discriminant := 17735 First_Stored_Discriminant (Explicitly_Discriminated_Type); 17736 while Present (Discriminant) loop 17737 Append_Elmt 17738 (Get_Discriminant_Value 17739 (Discriminant, Explicitly_Discriminated_Type, Constraint), 17740 To => Expansion); 17741 Next_Stored_Discriminant (Discriminant); 17742 end loop; 17743 17744 return Expansion; 17745 end Expand_To_Stored_Constraint; 17746 17747 --------------------------- 17748 -- Find_Hidden_Interface -- 17749 --------------------------- 17750 17751 function Find_Hidden_Interface 17752 (Src : Elist_Id; 17753 Dest : Elist_Id) return Entity_Id 17754 is 17755 Iface : Entity_Id; 17756 Iface_Elmt : Elmt_Id; 17757 17758 begin 17759 if Present (Src) and then Present (Dest) then 17760 Iface_Elmt := First_Elmt (Src); 17761 while Present (Iface_Elmt) loop 17762 Iface := Node (Iface_Elmt); 17763 17764 if Is_Interface (Iface) 17765 and then not Contain_Interface (Iface, Dest) 17766 then 17767 return Iface; 17768 end if; 17769 17770 Next_Elmt (Iface_Elmt); 17771 end loop; 17772 end if; 17773 17774 return Empty; 17775 end Find_Hidden_Interface; 17776 17777 -------------------- 17778 -- Find_Type_Name -- 17779 -------------------- 17780 17781 function Find_Type_Name (N : Node_Id) return Entity_Id is 17782 Id : constant Entity_Id := Defining_Identifier (N); 17783 New_Id : Entity_Id; 17784 Prev : Entity_Id; 17785 Prev_Par : Node_Id; 17786 17787 procedure Check_Duplicate_Aspects; 17788 -- Check that aspects specified in a completion have not been specified 17789 -- already in the partial view. 17790 17791 procedure Tag_Mismatch; 17792 -- Diagnose a tagged partial view whose full view is untagged. We post 17793 -- the message on the full view, with a reference to the previous 17794 -- partial view. The partial view can be private or incomplete, and 17795 -- these are handled in a different manner, so we determine the position 17796 -- of the error message from the respective slocs of both. 17797 17798 ----------------------------- 17799 -- Check_Duplicate_Aspects -- 17800 ----------------------------- 17801 17802 procedure Check_Duplicate_Aspects is 17803 function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id; 17804 -- Return the corresponding aspect of the partial view which matches 17805 -- the aspect id of Asp. Return Empty is no such aspect exists. 17806 17807 ----------------------------- 17808 -- Get_Partial_View_Aspect -- 17809 ----------------------------- 17810 17811 function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id is 17812 Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp); 17813 Prev_Asps : constant List_Id := Aspect_Specifications (Prev_Par); 17814 Prev_Asp : Node_Id; 17815 17816 begin 17817 if Present (Prev_Asps) then 17818 Prev_Asp := First (Prev_Asps); 17819 while Present (Prev_Asp) loop 17820 if Get_Aspect_Id (Prev_Asp) = Asp_Id then 17821 return Prev_Asp; 17822 end if; 17823 17824 Next (Prev_Asp); 17825 end loop; 17826 end if; 17827 17828 return Empty; 17829 end Get_Partial_View_Aspect; 17830 17831 -- Local variables 17832 17833 Full_Asps : constant List_Id := Aspect_Specifications (N); 17834 Full_Asp : Node_Id; 17835 Part_Asp : Node_Id; 17836 17837 -- Start of processing for Check_Duplicate_Aspects 17838 17839 begin 17840 if Present (Full_Asps) then 17841 Full_Asp := First (Full_Asps); 17842 while Present (Full_Asp) loop 17843 Part_Asp := Get_Partial_View_Aspect (Full_Asp); 17844 17845 -- An aspect and its class-wide counterpart are two distinct 17846 -- aspects and may apply to both views of an entity. 17847 17848 if Present (Part_Asp) 17849 and then Class_Present (Part_Asp) = Class_Present (Full_Asp) 17850 then 17851 Error_Msg_N 17852 ("aspect already specified in private declaration", 17853 Full_Asp); 17854 17855 Remove (Full_Asp); 17856 return; 17857 end if; 17858 17859 if Has_Discriminants (Prev) 17860 and then not Has_Unknown_Discriminants (Prev) 17861 and then Get_Aspect_Id (Full_Asp) = 17862 Aspect_Implicit_Dereference 17863 then 17864 Error_Msg_N 17865 ("cannot specify aspect if partial view has known " 17866 & "discriminants", Full_Asp); 17867 end if; 17868 17869 Next (Full_Asp); 17870 end loop; 17871 end if; 17872 end Check_Duplicate_Aspects; 17873 17874 ------------------ 17875 -- Tag_Mismatch -- 17876 ------------------ 17877 17878 procedure Tag_Mismatch is 17879 begin 17880 if Sloc (Prev) < Sloc (Id) then 17881 if Ada_Version >= Ada_2012 17882 and then Nkind (N) = N_Private_Type_Declaration 17883 then 17884 Error_Msg_NE 17885 ("declaration of private } must be a tagged type", Id, Prev); 17886 else 17887 Error_Msg_NE 17888 ("full declaration of } must be a tagged type", Id, Prev); 17889 end if; 17890 17891 else 17892 if Ada_Version >= Ada_2012 17893 and then Nkind (N) = N_Private_Type_Declaration 17894 then 17895 Error_Msg_NE 17896 ("declaration of private } must be a tagged type", Prev, Id); 17897 else 17898 Error_Msg_NE 17899 ("full declaration of } must be a tagged type", Prev, Id); 17900 end if; 17901 end if; 17902 end Tag_Mismatch; 17903 17904 -- Start of processing for Find_Type_Name 17905 17906 begin 17907 -- Find incomplete declaration, if one was given 17908 17909 Prev := Current_Entity_In_Scope (Id); 17910 17911 -- New type declaration 17912 17913 if No (Prev) then 17914 Enter_Name (Id); 17915 return Id; 17916 17917 -- Previous declaration exists 17918 17919 else 17920 Prev_Par := Parent (Prev); 17921 17922 -- Error if not incomplete/private case except if previous 17923 -- declaration is implicit, etc. Enter_Name will emit error if 17924 -- appropriate. 17925 17926 if not Is_Incomplete_Or_Private_Type (Prev) then 17927 Enter_Name (Id); 17928 New_Id := Id; 17929 17930 -- Check invalid completion of private or incomplete type 17931 17932 elsif Nkind (N) not in N_Full_Type_Declaration 17933 | N_Task_Type_Declaration 17934 | N_Protected_Type_Declaration 17935 and then 17936 (Ada_Version < Ada_2012 17937 or else not Is_Incomplete_Type (Prev) 17938 or else Nkind (N) not in N_Private_Type_Declaration 17939 | N_Private_Extension_Declaration) 17940 then 17941 -- Completion must be a full type declarations (RM 7.3(4)) 17942 17943 Error_Msg_Sloc := Sloc (Prev); 17944 Error_Msg_NE ("invalid completion of }", Id, Prev); 17945 17946 -- Set scope of Id to avoid cascaded errors. Entity is never 17947 -- examined again, except when saving globals in generics. 17948 17949 Set_Scope (Id, Current_Scope); 17950 New_Id := Id; 17951 17952 -- If this is a repeated incomplete declaration, no further 17953 -- checks are possible. 17954 17955 if Nkind (N) = N_Incomplete_Type_Declaration then 17956 return Prev; 17957 end if; 17958 17959 -- Case of full declaration of incomplete type 17960 17961 elsif Ekind (Prev) = E_Incomplete_Type 17962 and then (Ada_Version < Ada_2012 17963 or else No (Full_View (Prev)) 17964 or else not Is_Private_Type (Full_View (Prev))) 17965 then 17966 -- Indicate that the incomplete declaration has a matching full 17967 -- declaration. The defining occurrence of the incomplete 17968 -- declaration remains the visible one, and the procedure 17969 -- Get_Full_View dereferences it whenever the type is used. 17970 17971 if Present (Full_View (Prev)) then 17972 Error_Msg_NE ("invalid redeclaration of }", Id, Prev); 17973 end if; 17974 17975 Set_Full_View (Prev, Id); 17976 Append_Entity (Id, Current_Scope); 17977 Set_Is_Public (Id, Is_Public (Prev)); 17978 Set_Is_Internal (Id); 17979 New_Id := Prev; 17980 17981 -- If the incomplete view is tagged, a class_wide type has been 17982 -- created already. Use it for the private type as well, in order 17983 -- to prevent multiple incompatible class-wide types that may be 17984 -- created for self-referential anonymous access components. 17985 17986 if Is_Tagged_Type (Prev) 17987 and then Present (Class_Wide_Type (Prev)) 17988 then 17989 Mutate_Ekind (Id, Ekind (Prev)); -- will be reset later 17990 Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); 17991 17992 -- Type of the class-wide type is the current Id. Previously 17993 -- this was not done for private declarations because of order- 17994 -- of-elaboration issues in the back end, but gigi now handles 17995 -- this properly. 17996 17997 Set_Etype (Class_Wide_Type (Id), Id); 17998 end if; 17999 18000 -- Case of full declaration of private type 18001 18002 else 18003 -- If the private type was a completion of an incomplete type then 18004 -- update Prev to reference the private type 18005 18006 if Ada_Version >= Ada_2012 18007 and then Ekind (Prev) = E_Incomplete_Type 18008 and then Present (Full_View (Prev)) 18009 and then Is_Private_Type (Full_View (Prev)) 18010 then 18011 Prev := Full_View (Prev); 18012 Prev_Par := Parent (Prev); 18013 end if; 18014 18015 if Nkind (N) = N_Full_Type_Declaration 18016 and then Nkind (Type_Definition (N)) in 18017 N_Record_Definition | N_Derived_Type_Definition 18018 and then Interface_Present (Type_Definition (N)) 18019 then 18020 Error_Msg_N 18021 ("completion of private type cannot be an interface", N); 18022 end if; 18023 18024 if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then 18025 if Etype (Prev) /= Prev then 18026 18027 -- Prev is a private subtype or a derived type, and needs 18028 -- no completion. 18029 18030 Error_Msg_NE ("invalid redeclaration of }", Id, Prev); 18031 New_Id := Id; 18032 18033 elsif Ekind (Prev) = E_Private_Type 18034 and then Nkind (N) in N_Task_Type_Declaration 18035 | N_Protected_Type_Declaration 18036 then 18037 Error_Msg_N 18038 ("completion of nonlimited type cannot be limited", N); 18039 18040 elsif Ekind (Prev) = E_Record_Type_With_Private 18041 and then Nkind (N) in N_Task_Type_Declaration 18042 | N_Protected_Type_Declaration 18043 then 18044 if not Is_Limited_Record (Prev) then 18045 Error_Msg_N 18046 ("completion of nonlimited type cannot be limited", N); 18047 18048 elsif No (Interface_List (N)) then 18049 Error_Msg_N 18050 ("completion of tagged private type must be tagged", 18051 N); 18052 end if; 18053 end if; 18054 18055 -- Ada 2005 (AI-251): Private extension declaration of a task 18056 -- type or a protected type. This case arises when covering 18057 -- interface types. 18058 18059 elsif Nkind (N) in N_Task_Type_Declaration 18060 | N_Protected_Type_Declaration 18061 then 18062 null; 18063 18064 elsif Nkind (N) /= N_Full_Type_Declaration 18065 or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition 18066 then 18067 Error_Msg_N 18068 ("full view of private extension must be an extension", N); 18069 18070 elsif not (Abstract_Present (Parent (Prev))) 18071 and then Abstract_Present (Type_Definition (N)) 18072 then 18073 Error_Msg_N 18074 ("full view of non-abstract extension cannot be abstract", N); 18075 end if; 18076 18077 if not In_Private_Part (Current_Scope) then 18078 Error_Msg_N 18079 ("declaration of full view must appear in private part", N); 18080 end if; 18081 18082 if Ada_Version >= Ada_2012 then 18083 Check_Duplicate_Aspects; 18084 end if; 18085 18086 Copy_And_Swap (Prev, Id); 18087 Set_Has_Private_Declaration (Prev); 18088 Set_Has_Private_Declaration (Id); 18089 18090 -- AI12-0133: Indicate whether we have a partial view with 18091 -- unknown discriminants, in which case initialization of objects 18092 -- of the type do not receive an invariant check. 18093 18094 Set_Partial_View_Has_Unknown_Discr 18095 (Prev, Has_Unknown_Discriminants (Id)); 18096 18097 -- Preserve aspect and iterator flags that may have been set on 18098 -- the partial view. 18099 18100 Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id)); 18101 Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id)); 18102 18103 -- If no error, propagate freeze_node from private to full view. 18104 -- It may have been generated for an early operational item. 18105 18106 if Present (Freeze_Node (Id)) 18107 and then Serious_Errors_Detected = 0 18108 and then No (Full_View (Id)) 18109 then 18110 Set_Freeze_Node (Prev, Freeze_Node (Id)); 18111 Set_Freeze_Node (Id, Empty); 18112 Set_First_Rep_Item (Prev, First_Rep_Item (Id)); 18113 end if; 18114 18115 Set_Full_View (Id, Prev); 18116 New_Id := Prev; 18117 end if; 18118 18119 -- Verify that full declaration conforms to partial one 18120 18121 if Is_Incomplete_Or_Private_Type (Prev) 18122 and then Present (Discriminant_Specifications (Prev_Par)) 18123 then 18124 if Present (Discriminant_Specifications (N)) then 18125 if Ekind (Prev) = E_Incomplete_Type then 18126 Check_Discriminant_Conformance (N, Prev, Prev); 18127 else 18128 Check_Discriminant_Conformance (N, Prev, Id); 18129 end if; 18130 18131 else 18132 Error_Msg_N 18133 ("missing discriminants in full type declaration", N); 18134 18135 -- To avoid cascaded errors on subsequent use, share the 18136 -- discriminants of the partial view. 18137 18138 Set_Discriminant_Specifications (N, 18139 Discriminant_Specifications (Prev_Par)); 18140 end if; 18141 end if; 18142 18143 -- A prior untagged partial view can have an associated class-wide 18144 -- type due to use of the class attribute, and in this case the full 18145 -- type must also be tagged. This Ada 95 usage is deprecated in favor 18146 -- of incomplete tagged declarations, but we check for it. 18147 18148 if Is_Type (Prev) 18149 and then (Is_Tagged_Type (Prev) 18150 or else Present (Class_Wide_Type (Prev))) 18151 then 18152 -- Ada 2012 (AI05-0162): A private type may be the completion of 18153 -- an incomplete type. 18154 18155 if Ada_Version >= Ada_2012 18156 and then Is_Incomplete_Type (Prev) 18157 and then Nkind (N) in N_Private_Type_Declaration 18158 | N_Private_Extension_Declaration 18159 then 18160 -- No need to check private extensions since they are tagged 18161 18162 if Nkind (N) = N_Private_Type_Declaration 18163 and then not Tagged_Present (N) 18164 then 18165 Tag_Mismatch; 18166 end if; 18167 18168 -- The full declaration is either a tagged type (including 18169 -- a synchronized type that implements interfaces) or a 18170 -- type extension, otherwise this is an error. 18171 18172 elsif Nkind (N) in N_Task_Type_Declaration 18173 | N_Protected_Type_Declaration 18174 then 18175 if No (Interface_List (N)) and then not Error_Posted (N) then 18176 Tag_Mismatch; 18177 end if; 18178 18179 elsif Nkind (Type_Definition (N)) = N_Record_Definition then 18180 18181 -- Indicate that the previous declaration (tagged incomplete 18182 -- or private declaration) requires the same on the full one. 18183 18184 if not Tagged_Present (Type_Definition (N)) then 18185 Tag_Mismatch; 18186 Set_Is_Tagged_Type (Id); 18187 end if; 18188 18189 elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 18190 if No (Record_Extension_Part (Type_Definition (N))) then 18191 Error_Msg_NE 18192 ("full declaration of } must be a record extension", 18193 Prev, Id); 18194 18195 -- Set some attributes to produce a usable full view 18196 18197 Set_Is_Tagged_Type (Id); 18198 end if; 18199 18200 else 18201 Tag_Mismatch; 18202 end if; 18203 end if; 18204 18205 if Present (Prev) 18206 and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration 18207 and then Present (Premature_Use (Parent (Prev))) 18208 then 18209 Error_Msg_Sloc := Sloc (N); 18210 Error_Msg_N 18211 ("\full declaration #", Premature_Use (Parent (Prev))); 18212 end if; 18213 18214 return New_Id; 18215 end if; 18216 end Find_Type_Name; 18217 18218 ------------------------- 18219 -- Find_Type_Of_Object -- 18220 ------------------------- 18221 18222 function Find_Type_Of_Object 18223 (Obj_Def : Node_Id; 18224 Related_Nod : Node_Id) return Entity_Id 18225 is 18226 Def_Kind : constant Node_Kind := Nkind (Obj_Def); 18227 P : Node_Id := Parent (Obj_Def); 18228 T : Entity_Id; 18229 Nam : Name_Id; 18230 18231 begin 18232 -- If the parent is a component_definition node we climb to the 18233 -- component_declaration node 18234 18235 if Nkind (P) = N_Component_Definition then 18236 P := Parent (P); 18237 end if; 18238 18239 -- Case of an anonymous array subtype 18240 18241 if Def_Kind in N_Array_Type_Definition then 18242 T := Empty; 18243 Array_Type_Declaration (T, Obj_Def); 18244 18245 -- Create an explicit subtype whenever possible 18246 18247 elsif Nkind (P) /= N_Component_Declaration 18248 and then Def_Kind = N_Subtype_Indication 18249 then 18250 -- Base name of subtype on object name, which will be unique in 18251 -- the current scope. 18252 18253 -- If this is a duplicate declaration, return base type, to avoid 18254 -- generating duplicate anonymous types. 18255 18256 if Error_Posted (P) then 18257 Analyze (Subtype_Mark (Obj_Def)); 18258 return Entity (Subtype_Mark (Obj_Def)); 18259 end if; 18260 18261 Nam := 18262 New_External_Name 18263 (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T'); 18264 18265 T := Make_Defining_Identifier (Sloc (P), Nam); 18266 18267 -- If In_Spec_Expression, for example within a pre/postcondition, 18268 -- provide enough information for use of the subtype without 18269 -- depending on full analysis and freezing, which will happen when 18270 -- building the correspondiing subprogram. 18271 18272 if In_Spec_Expression then 18273 Analyze (Subtype_Mark (Obj_Def)); 18274 18275 declare 18276 Base_T : constant Entity_Id := Entity (Subtype_Mark (Obj_Def)); 18277 Decl : constant Node_Id := 18278 Make_Subtype_Declaration (Sloc (P), 18279 Defining_Identifier => T, 18280 Subtype_Indication => Relocate_Node (Obj_Def)); 18281 begin 18282 Set_Etype (T, Base_T); 18283 Mutate_Ekind (T, Subtype_Kind (Ekind (Base_T))); 18284 Set_Parent (T, Obj_Def); 18285 18286 if Ekind (T) = E_Array_Subtype then 18287 Set_First_Index (T, First_Index (Base_T)); 18288 Set_Is_Constrained (T); 18289 18290 elsif Ekind (T) = E_Record_Subtype then 18291 Set_First_Entity (T, First_Entity (Base_T)); 18292 Set_Has_Discriminants (T, Has_Discriminants (Base_T)); 18293 Set_Is_Constrained (T); 18294 end if; 18295 18296 Insert_Before (Related_Nod, Decl); 18297 end; 18298 18299 return T; 18300 end if; 18301 18302 -- When generating code, insert subtype declaration ahead of 18303 -- declaration that generated it. 18304 18305 Insert_Action (Obj_Def, 18306 Make_Subtype_Declaration (Sloc (P), 18307 Defining_Identifier => T, 18308 Subtype_Indication => Relocate_Node (Obj_Def))); 18309 18310 -- This subtype may need freezing, and this will not be done 18311 -- automatically if the object declaration is not in declarative 18312 -- part. Since this is an object declaration, the type cannot always 18313 -- be frozen here. Deferred constants do not freeze their type 18314 -- (which often enough will be private). 18315 18316 if Nkind (P) = N_Object_Declaration 18317 and then Constant_Present (P) 18318 and then No (Expression (P)) 18319 then 18320 null; 18321 18322 -- Here we freeze the base type of object type to catch premature use 18323 -- of discriminated private type without a full view. 18324 18325 else 18326 Insert_Actions (Obj_Def, Freeze_Entity (Base_Type (T), P)); 18327 end if; 18328 18329 -- Ada 2005 AI-406: the object definition in an object declaration 18330 -- can be an access definition. 18331 18332 elsif Def_Kind = N_Access_Definition then 18333 T := Access_Definition (Related_Nod, Obj_Def); 18334 18335 Set_Is_Local_Anonymous_Access 18336 (T, Ada_Version < Ada_2012 18337 or else Nkind (P) /= N_Object_Declaration 18338 or else Is_Library_Level_Entity (Defining_Identifier (P))); 18339 18340 -- Otherwise, the object definition is just a subtype_mark 18341 18342 else 18343 T := Process_Subtype (Obj_Def, Related_Nod); 18344 end if; 18345 18346 return T; 18347 end Find_Type_Of_Object; 18348 18349 -------------------------------- 18350 -- Find_Type_Of_Subtype_Indic -- 18351 -------------------------------- 18352 18353 function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is 18354 Typ : Entity_Id; 18355 18356 begin 18357 -- Case of subtype mark with a constraint 18358 18359 if Nkind (S) = N_Subtype_Indication then 18360 Find_Type (Subtype_Mark (S)); 18361 Typ := Entity (Subtype_Mark (S)); 18362 18363 if not 18364 Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S))) 18365 then 18366 Error_Msg_N 18367 ("incorrect constraint for this kind of type", Constraint (S)); 18368 Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); 18369 end if; 18370 18371 -- Otherwise we have a subtype mark without a constraint 18372 18373 elsif Error_Posted (S) then 18374 Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S))); 18375 return Any_Type; 18376 18377 else 18378 Find_Type (S); 18379 Typ := Entity (S); 18380 end if; 18381 18382 return Typ; 18383 end Find_Type_Of_Subtype_Indic; 18384 18385 ------------------------------------- 18386 -- Floating_Point_Type_Declaration -- 18387 ------------------------------------- 18388 18389 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is 18390 Digs : constant Node_Id := Digits_Expression (Def); 18391 Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float); 18392 Digs_Val : Uint; 18393 Base_Typ : Entity_Id; 18394 Implicit_Base : Entity_Id; 18395 18396 function Can_Derive_From (E : Entity_Id) return Boolean; 18397 -- Find if given digits value, and possibly a specified range, allows 18398 -- derivation from specified type 18399 18400 procedure Convert_Bound (B : Node_Id); 18401 -- If specified, the bounds must be static but may be of different 18402 -- types. They must be converted into machine numbers of the base type, 18403 -- in accordance with RM 4.9(38). 18404 18405 function Find_Base_Type return Entity_Id; 18406 -- Find a predefined base type that Def can derive from, or generate 18407 -- an error and substitute Long_Long_Float if none exists. 18408 18409 --------------------- 18410 -- Can_Derive_From -- 18411 --------------------- 18412 18413 function Can_Derive_From (E : Entity_Id) return Boolean is 18414 Spec : constant Entity_Id := Real_Range_Specification (Def); 18415 18416 begin 18417 -- Check specified "digits" constraint 18418 18419 if Digs_Val > Digits_Value (E) then 18420 return False; 18421 end if; 18422 18423 -- Check for matching range, if specified 18424 18425 if Present (Spec) then 18426 if Expr_Value_R (Type_Low_Bound (E)) > 18427 Expr_Value_R (Low_Bound (Spec)) 18428 then 18429 return False; 18430 end if; 18431 18432 if Expr_Value_R (Type_High_Bound (E)) < 18433 Expr_Value_R (High_Bound (Spec)) 18434 then 18435 return False; 18436 end if; 18437 end if; 18438 18439 return True; 18440 end Can_Derive_From; 18441 18442 ------------------- 18443 -- Convert_Bound -- 18444 -------------------- 18445 18446 procedure Convert_Bound (B : Node_Id) is 18447 begin 18448 -- If the bound is not a literal it can only be static if it is 18449 -- a static constant, possibly of a specified type. 18450 18451 if Is_Entity_Name (B) 18452 and then Ekind (Entity (B)) = E_Constant 18453 then 18454 Rewrite (B, Constant_Value (Entity (B))); 18455 end if; 18456 18457 if Nkind (B) = N_Real_Literal then 18458 Set_Realval (B, Machine (Base_Typ, Realval (B), Round, B)); 18459 Set_Is_Machine_Number (B); 18460 Set_Etype (B, Base_Typ); 18461 end if; 18462 end Convert_Bound; 18463 18464 -------------------- 18465 -- Find_Base_Type -- 18466 -------------------- 18467 18468 function Find_Base_Type return Entity_Id is 18469 Choice : Elmt_Id := First_Elmt (Predefined_Float_Types); 18470 18471 begin 18472 -- Iterate over the predefined types in order, returning the first 18473 -- one that Def can derive from. 18474 18475 while Present (Choice) loop 18476 if Can_Derive_From (Node (Choice)) then 18477 return Node (Choice); 18478 end if; 18479 18480 Next_Elmt (Choice); 18481 end loop; 18482 18483 -- If we can't derive from any existing type, use Long_Long_Float 18484 -- and give appropriate message explaining the problem. 18485 18486 if Digs_Val > Max_Digs_Val then 18487 -- It might be the case that there is a type with the requested 18488 -- range, just not the combination of digits and range. 18489 18490 Error_Msg_N 18491 ("no predefined type has requested range and precision", 18492 Real_Range_Specification (Def)); 18493 18494 else 18495 Error_Msg_N 18496 ("range too large for any predefined type", 18497 Real_Range_Specification (Def)); 18498 end if; 18499 18500 return Standard_Long_Long_Float; 18501 end Find_Base_Type; 18502 18503 -- Start of processing for Floating_Point_Type_Declaration 18504 18505 begin 18506 Check_Restriction (No_Floating_Point, Def); 18507 18508 -- Create an implicit base type 18509 18510 Implicit_Base := 18511 Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B'); 18512 18513 -- Analyze and verify digits value 18514 18515 Analyze_And_Resolve (Digs, Any_Integer); 18516 Check_Digits_Expression (Digs); 18517 Digs_Val := Expr_Value (Digs); 18518 18519 -- Process possible range spec and find correct type to derive from 18520 18521 Process_Real_Range_Specification (Def); 18522 18523 -- Check that requested number of digits is not too high. 18524 18525 if Digs_Val > Max_Digs_Val then 18526 18527 -- The check for Max_Base_Digits may be somewhat expensive, as it 18528 -- requires reading System, so only do it when necessary. 18529 18530 declare 18531 Max_Base_Digits : constant Uint := 18532 Expr_Value 18533 (Expression 18534 (Parent (RTE (RE_Max_Base_Digits)))); 18535 18536 begin 18537 if Digs_Val > Max_Base_Digits then 18538 Error_Msg_Uint_1 := Max_Base_Digits; 18539 Error_Msg_N ("digits value out of range, maximum is ^", Digs); 18540 18541 elsif No (Real_Range_Specification (Def)) then 18542 Error_Msg_Uint_1 := Max_Digs_Val; 18543 Error_Msg_N ("types with more than ^ digits need range spec " 18544 & "(RM 3.5.7(6))", Digs); 18545 end if; 18546 end; 18547 end if; 18548 18549 -- Find a suitable type to derive from or complain and use a substitute 18550 18551 Base_Typ := Find_Base_Type; 18552 18553 -- If there are bounds given in the declaration use them as the bounds 18554 -- of the type, otherwise use the bounds of the predefined base type 18555 -- that was chosen based on the Digits value. 18556 18557 if Present (Real_Range_Specification (Def)) then 18558 Set_Scalar_Range (T, Real_Range_Specification (Def)); 18559 Set_Is_Constrained (T); 18560 18561 Convert_Bound (Type_Low_Bound (T)); 18562 Convert_Bound (Type_High_Bound (T)); 18563 18564 else 18565 Set_Scalar_Range (T, Scalar_Range (Base_Typ)); 18566 end if; 18567 18568 -- Complete definition of implicit base and declared first subtype. The 18569 -- inheritance of the rep item chain ensures that SPARK-related pragmas 18570 -- are not clobbered when the floating point type acts as a full view of 18571 -- a private type. 18572 18573 Set_Etype (Implicit_Base, Base_Typ); 18574 Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); 18575 Set_Size_Info (Implicit_Base, Base_Typ); 18576 Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); 18577 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); 18578 Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); 18579 Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); 18580 18581 Mutate_Ekind (T, E_Floating_Point_Subtype); 18582 Set_Etype (T, Implicit_Base); 18583 Set_Size_Info (T, Implicit_Base); 18584 Set_RM_Size (T, RM_Size (Implicit_Base)); 18585 Inherit_Rep_Item_Chain (T, Implicit_Base); 18586 18587 if Digs_Val >= Uint_1 then 18588 Set_Digits_Value (T, Digs_Val); 18589 else 18590 pragma Assert (Serious_Errors_Detected > 0); null; 18591 end if; 18592 end Floating_Point_Type_Declaration; 18593 18594 ---------------------------- 18595 -- Get_Discriminant_Value -- 18596 ---------------------------- 18597 18598 -- This is the situation: 18599 18600 -- There is a non-derived type 18601 18602 -- type T0 (Dx, Dy, Dz...) 18603 18604 -- There are zero or more levels of derivation, with each derivation 18605 -- either purely inheriting the discriminants, or defining its own. 18606 18607 -- type Ti is new Ti-1 18608 -- or 18609 -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y) 18610 -- or 18611 -- subtype Ti is ... 18612 18613 -- The subtype issue is avoided by the use of Original_Record_Component, 18614 -- and the fact that derived subtypes also derive the constraints. 18615 18616 -- This chain leads back from 18617 18618 -- Typ_For_Constraint 18619 18620 -- Typ_For_Constraint has discriminants, and the value for each 18621 -- discriminant is given by its corresponding Elmt of Constraints. 18622 18623 -- Discriminant is some discriminant in this hierarchy 18624 18625 -- We need to return its value 18626 18627 -- We do this by recursively searching each level, and looking for 18628 -- Discriminant. Once we get to the bottom, we start backing up 18629 -- returning the value for it which may in turn be a discriminant 18630 -- further up, so on the backup we continue the substitution. 18631 18632 function Get_Discriminant_Value 18633 (Discriminant : Entity_Id; 18634 Typ_For_Constraint : Entity_Id; 18635 Constraint : Elist_Id) return Node_Id 18636 is 18637 function Root_Corresponding_Discriminant 18638 (Discr : Entity_Id) return Entity_Id; 18639 -- Given a discriminant, traverse the chain of inherited discriminants 18640 -- and return the topmost discriminant. 18641 18642 function Search_Derivation_Levels 18643 (Ti : Entity_Id; 18644 Discrim_Values : Elist_Id; 18645 Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id; 18646 -- This is the routine that performs the recursive search of levels 18647 -- as described above. 18648 18649 ------------------------------------- 18650 -- Root_Corresponding_Discriminant -- 18651 ------------------------------------- 18652 18653 function Root_Corresponding_Discriminant 18654 (Discr : Entity_Id) return Entity_Id 18655 is 18656 D : Entity_Id; 18657 18658 begin 18659 D := Discr; 18660 while Present (Corresponding_Discriminant (D)) loop 18661 D := Corresponding_Discriminant (D); 18662 end loop; 18663 18664 return D; 18665 end Root_Corresponding_Discriminant; 18666 18667 ------------------------------ 18668 -- Search_Derivation_Levels -- 18669 ------------------------------ 18670 18671 function Search_Derivation_Levels 18672 (Ti : Entity_Id; 18673 Discrim_Values : Elist_Id; 18674 Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id 18675 is 18676 Assoc : Elmt_Id; 18677 Disc : Entity_Id; 18678 Result : Node_Or_Entity_Id; 18679 Result_Entity : Node_Id; 18680 18681 begin 18682 -- If inappropriate type, return Error, this happens only in 18683 -- cascaded error situations, and we want to avoid a blow up. 18684 18685 if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then 18686 return Error; 18687 end if; 18688 18689 -- Look deeper if possible. Use Stored_Constraints only for 18690 -- untagged types. For tagged types use the given constraint. 18691 -- This asymmetry needs explanation??? 18692 18693 if not Stored_Discrim_Values 18694 and then Present (Stored_Constraint (Ti)) 18695 and then not Is_Tagged_Type (Ti) 18696 then 18697 Result := 18698 Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True); 18699 18700 else 18701 declare 18702 Td : Entity_Id := Etype (Ti); 18703 18704 begin 18705 -- If the parent type is private, the full view may include 18706 -- renamed discriminants, and it is those stored values that 18707 -- may be needed (the partial view never has more information 18708 -- than the full view). 18709 18710 if Is_Private_Type (Td) and then Present (Full_View (Td)) then 18711 Td := Full_View (Td); 18712 end if; 18713 18714 if Td = Ti then 18715 Result := Discriminant; 18716 18717 else 18718 if Present (Stored_Constraint (Ti)) then 18719 Result := 18720 Search_Derivation_Levels 18721 (Td, Stored_Constraint (Ti), True); 18722 else 18723 Result := 18724 Search_Derivation_Levels 18725 (Td, Discrim_Values, Stored_Discrim_Values); 18726 end if; 18727 end if; 18728 end; 18729 end if; 18730 18731 -- Extra underlying places to search, if not found above. For 18732 -- concurrent types, the relevant discriminant appears in the 18733 -- corresponding record. For a type derived from a private type 18734 -- without discriminant, the full view inherits the discriminants 18735 -- of the full view of the parent. 18736 18737 if Result = Discriminant then 18738 if Is_Concurrent_Type (Ti) 18739 and then Present (Corresponding_Record_Type (Ti)) 18740 then 18741 Result := 18742 Search_Derivation_Levels ( 18743 Corresponding_Record_Type (Ti), 18744 Discrim_Values, 18745 Stored_Discrim_Values); 18746 18747 elsif Is_Private_Type (Ti) 18748 and then not Has_Discriminants (Ti) 18749 and then Present (Full_View (Ti)) 18750 and then Etype (Full_View (Ti)) /= Ti 18751 then 18752 Result := 18753 Search_Derivation_Levels ( 18754 Full_View (Ti), 18755 Discrim_Values, 18756 Stored_Discrim_Values); 18757 end if; 18758 end if; 18759 18760 -- If Result is not a (reference to a) discriminant, return it, 18761 -- otherwise set Result_Entity to the discriminant. 18762 18763 if Nkind (Result) = N_Defining_Identifier then 18764 pragma Assert (Result = Discriminant); 18765 Result_Entity := Result; 18766 18767 else 18768 if not Denotes_Discriminant (Result) then 18769 return Result; 18770 end if; 18771 18772 Result_Entity := Entity (Result); 18773 end if; 18774 18775 -- See if this level of derivation actually has discriminants because 18776 -- tagged derivations can add them, hence the lower levels need not 18777 -- have any. 18778 18779 if not Has_Discriminants (Ti) then 18780 return Result; 18781 end if; 18782 18783 -- Scan Ti's discriminants for Result_Entity, and return its 18784 -- corresponding value, if any. 18785 18786 Result_Entity := Original_Record_Component (Result_Entity); 18787 18788 Assoc := First_Elmt (Discrim_Values); 18789 18790 if Stored_Discrim_Values then 18791 Disc := First_Stored_Discriminant (Ti); 18792 else 18793 Disc := First_Discriminant (Ti); 18794 end if; 18795 18796 while Present (Disc) loop 18797 18798 -- If no further associations return the discriminant, value will 18799 -- be found on the second pass. 18800 18801 if No (Assoc) then 18802 return Result; 18803 end if; 18804 18805 if Original_Record_Component (Disc) = Result_Entity then 18806 return Node (Assoc); 18807 end if; 18808 18809 Next_Elmt (Assoc); 18810 18811 if Stored_Discrim_Values then 18812 Next_Stored_Discriminant (Disc); 18813 else 18814 Next_Discriminant (Disc); 18815 end if; 18816 end loop; 18817 18818 -- Could not find it 18819 18820 return Result; 18821 end Search_Derivation_Levels; 18822 18823 -- Local Variables 18824 18825 Result : Node_Or_Entity_Id; 18826 18827 -- Start of processing for Get_Discriminant_Value 18828 18829 begin 18830 -- ??? This routine is a gigantic mess and will be deleted. For the 18831 -- time being just test for the trivial case before calling recurse. 18832 18833 -- We are now celebrating the 20th anniversary of this comment! 18834 18835 if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then 18836 declare 18837 D : Entity_Id; 18838 E : Elmt_Id; 18839 18840 begin 18841 D := First_Discriminant (Typ_For_Constraint); 18842 E := First_Elmt (Constraint); 18843 while Present (D) loop 18844 if Chars (D) = Chars (Discriminant) then 18845 return Node (E); 18846 end if; 18847 18848 Next_Discriminant (D); 18849 Next_Elmt (E); 18850 end loop; 18851 end; 18852 end if; 18853 18854 Result := Search_Derivation_Levels 18855 (Typ_For_Constraint, Constraint, False); 18856 18857 -- ??? hack to disappear when this routine is gone 18858 18859 if Nkind (Result) = N_Defining_Identifier then 18860 declare 18861 D : Entity_Id; 18862 E : Elmt_Id; 18863 18864 begin 18865 D := First_Discriminant (Typ_For_Constraint); 18866 E := First_Elmt (Constraint); 18867 while Present (D) loop 18868 if Root_Corresponding_Discriminant (D) = Discriminant then 18869 return Node (E); 18870 end if; 18871 18872 Next_Discriminant (D); 18873 Next_Elmt (E); 18874 end loop; 18875 end; 18876 end if; 18877 18878 pragma Assert (Nkind (Result) /= N_Defining_Identifier); 18879 return Result; 18880 end Get_Discriminant_Value; 18881 18882 -------------------------- 18883 -- Has_Range_Constraint -- 18884 -------------------------- 18885 18886 function Has_Range_Constraint (N : Node_Id) return Boolean is 18887 C : constant Node_Id := Constraint (N); 18888 18889 begin 18890 if Nkind (C) = N_Range_Constraint then 18891 return True; 18892 18893 elsif Nkind (C) = N_Digits_Constraint then 18894 return 18895 Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N))) 18896 or else Present (Range_Constraint (C)); 18897 18898 elsif Nkind (C) = N_Delta_Constraint then 18899 return Present (Range_Constraint (C)); 18900 18901 else 18902 return False; 18903 end if; 18904 end Has_Range_Constraint; 18905 18906 ------------------------ 18907 -- Inherit_Components -- 18908 ------------------------ 18909 18910 function Inherit_Components 18911 (N : Node_Id; 18912 Parent_Base : Entity_Id; 18913 Derived_Base : Entity_Id; 18914 Is_Tagged : Boolean; 18915 Inherit_Discr : Boolean; 18916 Discs : Elist_Id) return Elist_Id 18917 is 18918 Assoc_List : constant Elist_Id := New_Elmt_List; 18919 18920 procedure Inherit_Component 18921 (Old_C : Entity_Id; 18922 Plain_Discrim : Boolean := False; 18923 Stored_Discrim : Boolean := False); 18924 -- Inherits component Old_C from Parent_Base to the Derived_Base. If 18925 -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is 18926 -- True, Old_C is a stored discriminant. If they are both false then 18927 -- Old_C is a regular component. 18928 18929 ----------------------- 18930 -- Inherit_Component -- 18931 ----------------------- 18932 18933 procedure Inherit_Component 18934 (Old_C : Entity_Id; 18935 Plain_Discrim : Boolean := False; 18936 Stored_Discrim : Boolean := False) 18937 is 18938 procedure Set_Anonymous_Type (Id : Entity_Id); 18939 -- Id denotes the entity of an access discriminant or anonymous 18940 -- access component. Set the type of Id to either the same type of 18941 -- Old_C or create a new one depending on whether the parent and 18942 -- the child types are in the same scope. 18943 18944 ------------------------ 18945 -- Set_Anonymous_Type -- 18946 ------------------------ 18947 18948 procedure Set_Anonymous_Type (Id : Entity_Id) is 18949 Old_Typ : constant Entity_Id := Etype (Old_C); 18950 18951 begin 18952 if Scope (Parent_Base) = Scope (Derived_Base) then 18953 Set_Etype (Id, Old_Typ); 18954 18955 -- The parent and the derived type are in two different scopes. 18956 -- Reuse the type of the original discriminant / component by 18957 -- copying it in order to preserve all attributes. 18958 18959 else 18960 declare 18961 Typ : constant Entity_Id := New_Copy (Old_Typ); 18962 18963 begin 18964 Set_Etype (Id, Typ); 18965 18966 -- Since we do not generate component declarations for 18967 -- inherited components, associate the itype with the 18968 -- derived type. 18969 18970 Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base)); 18971 Set_Scope (Typ, Derived_Base); 18972 end; 18973 end if; 18974 end Set_Anonymous_Type; 18975 18976 -- Local variables and constants 18977 18978 New_C : constant Entity_Id := New_Copy (Old_C); 18979 18980 Corr_Discrim : Entity_Id; 18981 Discrim : Entity_Id; 18982 18983 -- Start of processing for Inherit_Component 18984 18985 begin 18986 pragma Assert (not Is_Tagged or not Stored_Discrim); 18987 18988 Set_Parent (New_C, Parent (Old_C)); 18989 18990 -- Regular discriminants and components must be inserted in the scope 18991 -- of the Derived_Base. Do it here. 18992 18993 if not Stored_Discrim then 18994 Enter_Name (New_C); 18995 end if; 18996 18997 -- For tagged types the Original_Record_Component must point to 18998 -- whatever this field was pointing to in the parent type. This has 18999 -- already been achieved by the call to New_Copy above. 19000 19001 if not Is_Tagged then 19002 Set_Original_Record_Component (New_C, New_C); 19003 Set_Corresponding_Record_Component (New_C, Old_C); 19004 end if; 19005 19006 -- Set the proper type of an access discriminant 19007 19008 if Ekind (New_C) = E_Discriminant 19009 and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type 19010 then 19011 Set_Anonymous_Type (New_C); 19012 end if; 19013 19014 -- If we have inherited a component then see if its Etype contains 19015 -- references to Parent_Base discriminants. In this case, replace 19016 -- these references with the constraints given in Discs. We do not 19017 -- do this for the partial view of private types because this is 19018 -- not needed (only the components of the full view will be used 19019 -- for code generation) and cause problem. We also avoid this 19020 -- transformation in some error situations. 19021 19022 if Ekind (New_C) = E_Component then 19023 19024 -- Set the proper type of an anonymous access component 19025 19026 if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then 19027 Set_Anonymous_Type (New_C); 19028 19029 elsif (Is_Private_Type (Derived_Base) 19030 and then not Is_Generic_Type (Derived_Base)) 19031 or else (Is_Empty_Elmt_List (Discs) 19032 and then not Expander_Active) 19033 then 19034 Set_Etype (New_C, Etype (Old_C)); 19035 19036 else 19037 -- The current component introduces a circularity of the 19038 -- following kind: 19039 19040 -- limited with Pack_2; 19041 -- package Pack_1 is 19042 -- type T_1 is tagged record 19043 -- Comp : access Pack_2.T_2; 19044 -- ... 19045 -- end record; 19046 -- end Pack_1; 19047 19048 -- with Pack_1; 19049 -- package Pack_2 is 19050 -- type T_2 is new Pack_1.T_1 with ...; 19051 -- end Pack_2; 19052 19053 Set_Etype 19054 (New_C, 19055 Constrain_Component_Type 19056 (Old_C, Derived_Base, N, Parent_Base, Discs)); 19057 end if; 19058 end if; 19059 19060 -- In derived tagged types it is illegal to reference a non 19061 -- discriminant component in the parent type. To catch this, mark 19062 -- these components with an Ekind of E_Void. This will be reset in 19063 -- Record_Type_Definition after processing the record extension of 19064 -- the derived type. 19065 19066 -- If the declaration is a private extension, there is no further 19067 -- record extension to process, and the components retain their 19068 -- current kind, because they are visible at this point. 19069 19070 if Is_Tagged and then Ekind (New_C) = E_Component 19071 and then Nkind (N) /= N_Private_Extension_Declaration 19072 then 19073 Mutate_Ekind (New_C, E_Void); 19074 end if; 19075 19076 if Plain_Discrim then 19077 Set_Corresponding_Discriminant (New_C, Old_C); 19078 Build_Discriminal (New_C); 19079 19080 -- If we are explicitly inheriting a stored discriminant it will be 19081 -- completely hidden. 19082 19083 elsif Stored_Discrim then 19084 Set_Corresponding_Discriminant (New_C, Empty); 19085 Set_Discriminal (New_C, Empty); 19086 Set_Is_Completely_Hidden (New_C); 19087 19088 -- Set the Original_Record_Component of each discriminant in the 19089 -- derived base to point to the corresponding stored that we just 19090 -- created. 19091 19092 Discrim := First_Discriminant (Derived_Base); 19093 while Present (Discrim) loop 19094 Corr_Discrim := Corresponding_Discriminant (Discrim); 19095 19096 -- Corr_Discrim could be missing in an error situation 19097 19098 if Present (Corr_Discrim) 19099 and then Original_Record_Component (Corr_Discrim) = Old_C 19100 then 19101 Set_Original_Record_Component (Discrim, New_C); 19102 Set_Corresponding_Record_Component (Discrim, Empty); 19103 end if; 19104 19105 Next_Discriminant (Discrim); 19106 end loop; 19107 19108 Append_Entity (New_C, Derived_Base); 19109 end if; 19110 19111 if not Is_Tagged then 19112 Append_Elmt (Old_C, Assoc_List); 19113 Append_Elmt (New_C, Assoc_List); 19114 end if; 19115 end Inherit_Component; 19116 19117 -- Variables local to Inherit_Component 19118 19119 Loc : constant Source_Ptr := Sloc (N); 19120 19121 Parent_Discrim : Entity_Id; 19122 Stored_Discrim : Entity_Id; 19123 D : Entity_Id; 19124 Component : Entity_Id; 19125 19126 -- Start of processing for Inherit_Components 19127 19128 begin 19129 if not Is_Tagged then 19130 Append_Elmt (Parent_Base, Assoc_List); 19131 Append_Elmt (Derived_Base, Assoc_List); 19132 end if; 19133 19134 -- Inherit parent discriminants if needed 19135 19136 if Inherit_Discr then 19137 Parent_Discrim := First_Discriminant (Parent_Base); 19138 while Present (Parent_Discrim) loop 19139 Inherit_Component (Parent_Discrim, Plain_Discrim => True); 19140 Next_Discriminant (Parent_Discrim); 19141 end loop; 19142 end if; 19143 19144 -- Create explicit stored discrims for untagged types when necessary 19145 19146 if not Has_Unknown_Discriminants (Derived_Base) 19147 and then Has_Discriminants (Parent_Base) 19148 and then not Is_Tagged 19149 and then 19150 (not Inherit_Discr 19151 or else First_Discriminant (Parent_Base) /= 19152 First_Stored_Discriminant (Parent_Base)) 19153 then 19154 Stored_Discrim := First_Stored_Discriminant (Parent_Base); 19155 while Present (Stored_Discrim) loop 19156 Inherit_Component (Stored_Discrim, Stored_Discrim => True); 19157 Next_Stored_Discriminant (Stored_Discrim); 19158 end loop; 19159 end if; 19160 19161 -- See if we can apply the second transformation for derived types, as 19162 -- explained in point 6. in the comments above Build_Derived_Record_Type 19163 -- This is achieved by appending Derived_Base discriminants into Discs, 19164 -- which has the side effect of returning a non empty Discs list to the 19165 -- caller of Inherit_Components, which is what we want. This must be 19166 -- done for private derived types if there are explicit stored 19167 -- discriminants, to ensure that we can retrieve the values of the 19168 -- constraints provided in the ancestors. 19169 19170 if Inherit_Discr 19171 and then Is_Empty_Elmt_List (Discs) 19172 and then Present (First_Discriminant (Derived_Base)) 19173 and then 19174 (not Is_Private_Type (Derived_Base) 19175 or else Is_Completely_Hidden 19176 (First_Stored_Discriminant (Derived_Base)) 19177 or else Is_Generic_Type (Derived_Base)) 19178 then 19179 D := First_Discriminant (Derived_Base); 19180 while Present (D) loop 19181 Append_Elmt (New_Occurrence_Of (D, Loc), Discs); 19182 Next_Discriminant (D); 19183 end loop; 19184 end if; 19185 19186 -- Finally, inherit non-discriminant components unless they are not 19187 -- visible because defined or inherited from the full view of the 19188 -- parent. Don't inherit the _parent field of the parent type. 19189 19190 Component := First_Entity (Parent_Base); 19191 while Present (Component) loop 19192 19193 -- Ada 2005 (AI-251): Do not inherit components associated with 19194 -- secondary tags of the parent. 19195 19196 if Ekind (Component) = E_Component 19197 and then Present (Related_Type (Component)) 19198 then 19199 null; 19200 19201 elsif Ekind (Component) /= E_Component 19202 or else Chars (Component) = Name_uParent 19203 then 19204 null; 19205 19206 -- If the derived type is within the parent type's declarative 19207 -- region, then the components can still be inherited even though 19208 -- they aren't visible at this point. This can occur for cases 19209 -- such as within public child units where the components must 19210 -- become visible upon entering the child unit's private part. 19211 19212 elsif not Is_Visible_Component (Component) 19213 and then not In_Open_Scopes (Scope (Parent_Base)) 19214 then 19215 null; 19216 19217 elsif Ekind (Derived_Base) in E_Private_Type | E_Limited_Private_Type 19218 then 19219 null; 19220 19221 else 19222 Inherit_Component (Component); 19223 end if; 19224 19225 Next_Entity (Component); 19226 end loop; 19227 19228 -- For tagged derived types, inherited discriminants cannot be used in 19229 -- component declarations of the record extension part. To achieve this 19230 -- we mark the inherited discriminants as not visible. 19231 19232 if Is_Tagged and then Inherit_Discr then 19233 D := First_Discriminant (Derived_Base); 19234 while Present (D) loop 19235 Set_Is_Immediately_Visible (D, False); 19236 Next_Discriminant (D); 19237 end loop; 19238 end if; 19239 19240 return Assoc_List; 19241 end Inherit_Components; 19242 19243 ---------------------- 19244 -- Is_EVF_Procedure -- 19245 ---------------------- 19246 19247 function Is_EVF_Procedure (Subp : Entity_Id) return Boolean is 19248 Formal : Entity_Id; 19249 19250 begin 19251 -- Examine the formals of an Extensions_Visible False procedure looking 19252 -- for a controlling OUT parameter. 19253 19254 if Ekind (Subp) = E_Procedure 19255 and then Extensions_Visible_Status (Subp) = Extensions_Visible_False 19256 then 19257 Formal := First_Formal (Subp); 19258 while Present (Formal) loop 19259 if Ekind (Formal) = E_Out_Parameter 19260 and then Is_Controlling_Formal (Formal) 19261 then 19262 return True; 19263 end if; 19264 19265 Next_Formal (Formal); 19266 end loop; 19267 end if; 19268 19269 return False; 19270 end Is_EVF_Procedure; 19271 19272 -------------------------- 19273 -- Is_Private_Primitive -- 19274 -------------------------- 19275 19276 function Is_Private_Primitive (Prim : Entity_Id) return Boolean is 19277 Prim_Scope : constant Entity_Id := Scope (Prim); 19278 Priv_Entity : Entity_Id; 19279 begin 19280 if Is_Package_Or_Generic_Package (Prim_Scope) then 19281 Priv_Entity := First_Private_Entity (Prim_Scope); 19282 19283 while Present (Priv_Entity) loop 19284 if Priv_Entity = Prim then 19285 return True; 19286 end if; 19287 19288 Next_Entity (Priv_Entity); 19289 end loop; 19290 end if; 19291 19292 return False; 19293 end Is_Private_Primitive; 19294 19295 ------------------------------ 19296 -- Is_Valid_Constraint_Kind -- 19297 ------------------------------ 19298 19299 function Is_Valid_Constraint_Kind 19300 (T_Kind : Type_Kind; 19301 Constraint_Kind : Node_Kind) return Boolean 19302 is 19303 begin 19304 case T_Kind is 19305 when Enumeration_Kind 19306 | Integer_Kind 19307 => 19308 return Constraint_Kind = N_Range_Constraint; 19309 19310 when Decimal_Fixed_Point_Kind => 19311 return Constraint_Kind in N_Digits_Constraint | N_Range_Constraint; 19312 19313 when Ordinary_Fixed_Point_Kind => 19314 return Constraint_Kind in N_Delta_Constraint | N_Range_Constraint; 19315 19316 when Float_Kind => 19317 return Constraint_Kind in N_Digits_Constraint | N_Range_Constraint; 19318 19319 when Access_Kind 19320 | Array_Kind 19321 | Class_Wide_Kind 19322 | Concurrent_Kind 19323 | Private_Kind 19324 | E_Incomplete_Type 19325 | E_Record_Subtype 19326 | E_Record_Type 19327 => 19328 return Constraint_Kind = N_Index_Or_Discriminant_Constraint; 19329 19330 when others => 19331 return True; -- Error will be detected later 19332 end case; 19333 end Is_Valid_Constraint_Kind; 19334 19335 -------------------------- 19336 -- Is_Visible_Component -- 19337 -------------------------- 19338 19339 function Is_Visible_Component 19340 (C : Entity_Id; 19341 N : Node_Id := Empty) return Boolean 19342 is 19343 Original_Comp : Entity_Id := Empty; 19344 Original_Type : Entity_Id; 19345 Type_Scope : Entity_Id; 19346 19347 function Is_Local_Type (Typ : Entity_Id) return Boolean; 19348 -- Check whether parent type of inherited component is declared locally, 19349 -- possibly within a nested package or instance. The current scope is 19350 -- the derived record itself. 19351 19352 ------------------- 19353 -- Is_Local_Type -- 19354 ------------------- 19355 19356 function Is_Local_Type (Typ : Entity_Id) return Boolean is 19357 begin 19358 return Scope_Within (Inner => Typ, Outer => Scope (Current_Scope)); 19359 end Is_Local_Type; 19360 19361 -- Start of processing for Is_Visible_Component 19362 19363 begin 19364 if Ekind (C) in E_Component | E_Discriminant then 19365 Original_Comp := Original_Record_Component (C); 19366 end if; 19367 19368 if No (Original_Comp) then 19369 19370 -- Premature usage, or previous error 19371 19372 return False; 19373 19374 else 19375 Original_Type := Scope (Original_Comp); 19376 Type_Scope := Scope (Base_Type (Scope (C))); 19377 end if; 19378 19379 -- This test only concerns tagged types 19380 19381 if not Is_Tagged_Type (Original_Type) then 19382 19383 -- Check if this is a renamed discriminant (hidden either by the 19384 -- derived type or by some ancestor), unless we are analyzing code 19385 -- generated by the expander since it may reference such components 19386 -- (for example see the expansion of Deep_Adjust). 19387 19388 if Ekind (C) = E_Discriminant and then Present (N) then 19389 return 19390 not Comes_From_Source (N) 19391 or else not Is_Completely_Hidden (C); 19392 else 19393 return True; 19394 end if; 19395 19396 -- If it is _Parent or _Tag, there is no visibility issue 19397 19398 elsif not Comes_From_Source (Original_Comp) then 19399 return True; 19400 19401 -- Discriminants are visible unless the (private) type has unknown 19402 -- discriminants. If the discriminant reference is inserted for a 19403 -- discriminant check on a full view it is also visible. 19404 19405 elsif Ekind (Original_Comp) = E_Discriminant 19406 and then 19407 (not Has_Unknown_Discriminants (Original_Type) 19408 or else (Present (N) 19409 and then Nkind (N) = N_Selected_Component 19410 and then Nkind (Prefix (N)) = N_Type_Conversion 19411 and then not Comes_From_Source (Prefix (N)))) 19412 then 19413 return True; 19414 19415 -- If the component has been declared in an ancestor which is currently 19416 -- a private type, then it is not visible. The same applies if the 19417 -- component's containing type is not in an open scope and the original 19418 -- component's enclosing type is a visible full view of a private type 19419 -- (which can occur in cases where an attempt is being made to reference 19420 -- a component in a sibling package that is inherited from a visible 19421 -- component of a type in an ancestor package; the component in the 19422 -- sibling package should not be visible even though the component it 19423 -- inherited from is visible), but instance bodies are not subject to 19424 -- this second case since they have the Has_Private_View mechanism to 19425 -- ensure proper visibility. This does not apply however in the case 19426 -- where the scope of the type is a private child unit, or when the 19427 -- parent comes from a local package in which the ancestor is currently 19428 -- visible. The latter suppression of visibility is needed for cases 19429 -- that are tested in B730006. 19430 19431 elsif Is_Private_Type (Original_Type) 19432 or else 19433 (not Is_Private_Descendant (Type_Scope) 19434 and then not In_Open_Scopes (Type_Scope) 19435 and then Has_Private_Declaration (Original_Type) 19436 and then not In_Instance_Body) 19437 then 19438 -- If the type derives from an entity in a formal package, there 19439 -- are no additional visible components. 19440 19441 if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) = 19442 N_Formal_Package_Declaration 19443 then 19444 return False; 19445 19446 -- if we are not in the private part of the current package, there 19447 -- are no additional visible components. 19448 19449 elsif Ekind (Scope (Current_Scope)) = E_Package 19450 and then not In_Private_Part (Scope (Current_Scope)) 19451 then 19452 return False; 19453 else 19454 return 19455 Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) 19456 and then In_Open_Scopes (Scope (Original_Type)) 19457 and then Is_Local_Type (Type_Scope); 19458 end if; 19459 19460 -- There is another weird way in which a component may be invisible when 19461 -- the private and the full view are not derived from the same ancestor. 19462 -- Here is an example : 19463 19464 -- type A1 is tagged record F1 : integer; end record; 19465 -- type A2 is new A1 with record F2 : integer; end record; 19466 -- type T is new A1 with private; 19467 -- private 19468 -- type T is new A2 with null record; 19469 19470 -- In this case, the full view of T inherits F1 and F2 but the private 19471 -- view inherits only F1 19472 19473 else 19474 declare 19475 Ancestor : Entity_Id := Scope (C); 19476 19477 begin 19478 loop 19479 if Ancestor = Original_Type then 19480 return True; 19481 19482 -- The ancestor may have a partial view of the original type, 19483 -- but if the full view is in scope, as in a child body, the 19484 -- component is visible. 19485 19486 elsif In_Private_Part (Scope (Original_Type)) 19487 and then Full_View (Ancestor) = Original_Type 19488 then 19489 return True; 19490 19491 elsif Ancestor = Etype (Ancestor) then 19492 19493 -- No further ancestors to examine 19494 19495 return False; 19496 end if; 19497 19498 Ancestor := Etype (Ancestor); 19499 end loop; 19500 end; 19501 end if; 19502 end Is_Visible_Component; 19503 19504 -------------------------- 19505 -- Make_Class_Wide_Type -- 19506 -------------------------- 19507 19508 procedure Make_Class_Wide_Type (T : Entity_Id) is 19509 CW_Type : Entity_Id; 19510 CW_Name : Name_Id; 19511 Next_E : Entity_Id; 19512 Prev_E : Entity_Id; 19513 19514 begin 19515 if Present (Class_Wide_Type (T)) then 19516 19517 -- The class-wide type is a partially decorated entity created for a 19518 -- unanalyzed tagged type referenced through a limited with clause. 19519 -- When the tagged type is analyzed, its class-wide type needs to be 19520 -- redecorated. Note that we reuse the entity created by Decorate_ 19521 -- Tagged_Type in order to preserve all links. 19522 19523 if Materialize_Entity (Class_Wide_Type (T)) then 19524 CW_Type := Class_Wide_Type (T); 19525 Set_Materialize_Entity (CW_Type, False); 19526 19527 -- The class wide type can have been defined by the partial view, in 19528 -- which case everything is already done. 19529 19530 else 19531 return; 19532 end if; 19533 19534 -- Default case, we need to create a new class-wide type 19535 19536 else 19537 CW_Type := 19538 New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T'); 19539 end if; 19540 19541 -- Inherit root type characteristics 19542 19543 CW_Name := Chars (CW_Type); 19544 Next_E := Next_Entity (CW_Type); 19545 Prev_E := Prev_Entity (CW_Type); 19546 Copy_Node (T, CW_Type); 19547 Set_Comes_From_Source (CW_Type, False); 19548 Set_Chars (CW_Type, CW_Name); 19549 Set_Parent (CW_Type, Parent (T)); 19550 Set_Prev_Entity (CW_Type, Prev_E); 19551 Set_Next_Entity (CW_Type, Next_E); 19552 19553 -- Ensure we have a new freeze node for the class-wide type. The partial 19554 -- view may have freeze action of its own, requiring a proper freeze 19555 -- node, and the same freeze node cannot be shared between the two 19556 -- types. 19557 19558 Set_Has_Delayed_Freeze (CW_Type); 19559 Set_Freeze_Node (CW_Type, Empty); 19560 19561 -- Customize the class-wide type: It has no prim. op., it cannot be 19562 -- abstract, its Etype points back to the specific root type, and it 19563 -- cannot have any invariants. 19564 19565 if Ekind (CW_Type) in Incomplete_Or_Private_Kind then 19566 Reinit_Field_To_Zero (CW_Type, F_Private_Dependents); 19567 19568 elsif Ekind (CW_Type) in Concurrent_Kind then 19569 Reinit_Field_To_Zero (CW_Type, F_First_Private_Entity); 19570 Reinit_Field_To_Zero (CW_Type, F_Scope_Depth_Value); 19571 19572 if Ekind (CW_Type) in Task_Kind then 19573 Reinit_Field_To_Zero (CW_Type, F_Is_Elaboration_Checks_OK_Id); 19574 Reinit_Field_To_Zero (CW_Type, F_Is_Elaboration_Warnings_OK_Id); 19575 end if; 19576 19577 if Ekind (CW_Type) in E_Task_Type | E_Protected_Type then 19578 Reinit_Field_To_Zero (CW_Type, F_SPARK_Aux_Pragma_Inherited); 19579 end if; 19580 end if; 19581 19582 Mutate_Ekind (CW_Type, E_Class_Wide_Type); 19583 Set_Is_Tagged_Type (CW_Type, True); 19584 Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); 19585 Set_Is_Abstract_Type (CW_Type, False); 19586 Set_Is_Constrained (CW_Type, False); 19587 Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); 19588 Set_Default_SSO (CW_Type); 19589 Set_Has_Inheritable_Invariants (CW_Type, False); 19590 Set_Has_Inherited_Invariants (CW_Type, False); 19591 Set_Has_Own_Invariants (CW_Type, False); 19592 19593 if Ekind (T) = E_Class_Wide_Subtype then 19594 Set_Etype (CW_Type, Etype (Base_Type (T))); 19595 else 19596 Set_Etype (CW_Type, T); 19597 end if; 19598 19599 Set_No_Tagged_Streams_Pragma (CW_Type, No_Tagged_Streams); 19600 19601 -- If this is the class_wide type of a constrained subtype, it does 19602 -- not have discriminants. 19603 19604 Set_Has_Discriminants (CW_Type, 19605 Has_Discriminants (T) and then not Is_Constrained (T)); 19606 19607 Set_Has_Unknown_Discriminants (CW_Type, True); 19608 Set_Class_Wide_Type (T, CW_Type); 19609 Set_Equivalent_Type (CW_Type, Empty); 19610 19611 -- The class-wide type of a class-wide type is itself (RM 3.9(14)) 19612 19613 Set_Class_Wide_Type (CW_Type, CW_Type); 19614 end Make_Class_Wide_Type; 19615 19616 ---------------- 19617 -- Make_Index -- 19618 ---------------- 19619 19620 procedure Make_Index 19621 (N : Node_Id; 19622 Related_Nod : Node_Id; 19623 Related_Id : Entity_Id := Empty; 19624 Suffix_Index : Pos := 1) 19625 is 19626 R : Node_Id; 19627 T : Entity_Id; 19628 Def_Id : Entity_Id := Empty; 19629 Found : Boolean := False; 19630 19631 begin 19632 -- For a discrete range used in a constrained array definition and 19633 -- defined by a range, an implicit conversion to the predefined type 19634 -- INTEGER is assumed if each bound is either a numeric literal, a named 19635 -- number, or an attribute, and the type of both bounds (prior to the 19636 -- implicit conversion) is the type universal_integer. Otherwise, both 19637 -- bounds must be of the same discrete type, other than universal 19638 -- integer; this type must be determinable independently of the 19639 -- context, but using the fact that the type must be discrete and that 19640 -- both bounds must have the same type. 19641 19642 -- Character literals also have a universal type in the absence of 19643 -- of additional context, and are resolved to Standard_Character. 19644 19645 if Nkind (N) = N_Range then 19646 19647 -- The index is given by a range constraint. The bounds are known 19648 -- to be of a consistent type. 19649 19650 if not Is_Overloaded (N) then 19651 T := Etype (N); 19652 19653 -- For universal bounds, choose the specific predefined type 19654 19655 if T = Universal_Integer then 19656 T := Standard_Integer; 19657 19658 elsif T = Any_Character then 19659 Ambiguous_Character (Low_Bound (N)); 19660 19661 T := Standard_Character; 19662 end if; 19663 19664 -- The node may be overloaded because some user-defined operators 19665 -- are available, but if a universal interpretation exists it is 19666 -- also the selected one. 19667 19668 elsif Universal_Interpretation (N) = Universal_Integer then 19669 T := Standard_Integer; 19670 19671 else 19672 T := Any_Type; 19673 19674 declare 19675 Ind : Interp_Index; 19676 It : Interp; 19677 19678 begin 19679 Get_First_Interp (N, Ind, It); 19680 while Present (It.Typ) loop 19681 if Is_Discrete_Type (It.Typ) then 19682 19683 if Found 19684 and then not Covers (It.Typ, T) 19685 and then not Covers (T, It.Typ) 19686 then 19687 Error_Msg_N ("ambiguous bounds in discrete range", N); 19688 exit; 19689 else 19690 T := It.Typ; 19691 Found := True; 19692 end if; 19693 end if; 19694 19695 Get_Next_Interp (Ind, It); 19696 end loop; 19697 19698 if T = Any_Type then 19699 Error_Msg_N ("discrete type required for range", N); 19700 Set_Etype (N, Any_Type); 19701 return; 19702 19703 elsif T = Universal_Integer then 19704 T := Standard_Integer; 19705 end if; 19706 end; 19707 end if; 19708 19709 if not Is_Discrete_Type (T) then 19710 Error_Msg_N ("discrete type required for range", N); 19711 Set_Etype (N, Any_Type); 19712 return; 19713 end if; 19714 19715 -- If the range bounds are "T'First .. T'Last" where T is a name of a 19716 -- discrete type, then use T as the type of the index. 19717 19718 if Nkind (Low_Bound (N)) = N_Attribute_Reference 19719 and then Attribute_Name (Low_Bound (N)) = Name_First 19720 and then Is_Entity_Name (Prefix (Low_Bound (N))) 19721 and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N)))) 19722 19723 and then Nkind (High_Bound (N)) = N_Attribute_Reference 19724 and then Attribute_Name (High_Bound (N)) = Name_Last 19725 and then Is_Entity_Name (Prefix (High_Bound (N))) 19726 and then Entity (Prefix (High_Bound (N))) = Def_Id 19727 then 19728 Def_Id := Entity (Prefix (Low_Bound (N))); 19729 end if; 19730 19731 R := N; 19732 Process_Range_Expr_In_Decl (R, T); 19733 19734 elsif Nkind (N) = N_Subtype_Indication then 19735 19736 -- The index is given by a subtype with a range constraint 19737 19738 T := Base_Type (Entity (Subtype_Mark (N))); 19739 19740 if not Is_Discrete_Type (T) then 19741 Error_Msg_N ("discrete type required for range", N); 19742 Set_Etype (N, Any_Type); 19743 return; 19744 end if; 19745 19746 R := Range_Expression (Constraint (N)); 19747 19748 Resolve (R, T); 19749 Process_Range_Expr_In_Decl (R, Entity (Subtype_Mark (N))); 19750 19751 elsif Nkind (N) = N_Attribute_Reference then 19752 19753 -- Catch beginner's error (use of attribute other than 'Range) 19754 19755 if Attribute_Name (N) /= Name_Range then 19756 Error_Msg_N ("expect attribute ''Range", N); 19757 Set_Etype (N, Any_Type); 19758 return; 19759 end if; 19760 19761 -- If the node denotes the range of a type mark, that is also the 19762 -- resulting type, and we do not need to create an Itype for it. 19763 19764 if Is_Entity_Name (Prefix (N)) 19765 and then Comes_From_Source (N) 19766 and then Is_Discrete_Type (Entity (Prefix (N))) 19767 then 19768 Def_Id := Entity (Prefix (N)); 19769 end if; 19770 19771 Analyze_And_Resolve (N); 19772 T := Etype (N); 19773 R := N; 19774 19775 -- If none of the above, must be a subtype. We convert this to a 19776 -- range attribute reference because in the case of declared first 19777 -- named subtypes, the types in the range reference can be different 19778 -- from the type of the entity. A range attribute normalizes the 19779 -- reference and obtains the correct types for the bounds. 19780 19781 -- This transformation is in the nature of an expansion, is only 19782 -- done if expansion is active. In particular, it is not done on 19783 -- formal generic types, because we need to retain the name of the 19784 -- original index for instantiation purposes. 19785 19786 else 19787 if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then 19788 Error_Msg_N ("invalid subtype mark in discrete range", N); 19789 Set_Etype (N, Any_Integer); 19790 return; 19791 19792 else 19793 -- The type mark may be that of an incomplete type. It is only 19794 -- now that we can get the full view, previous analysis does 19795 -- not look specifically for a type mark. 19796 19797 Set_Entity (N, Get_Full_View (Entity (N))); 19798 Set_Etype (N, Entity (N)); 19799 Def_Id := Entity (N); 19800 19801 if not Is_Discrete_Type (Def_Id) then 19802 Error_Msg_N ("discrete type required for index", N); 19803 Set_Etype (N, Any_Type); 19804 return; 19805 end if; 19806 end if; 19807 19808 if Expander_Active then 19809 Rewrite (N, 19810 Make_Attribute_Reference (Sloc (N), 19811 Attribute_Name => Name_Range, 19812 Prefix => Relocate_Node (N))); 19813 19814 -- The original was a subtype mark that does not freeze. This 19815 -- means that the rewritten version must not freeze either. 19816 19817 Set_Must_Not_Freeze (N); 19818 Set_Must_Not_Freeze (Prefix (N)); 19819 Analyze_And_Resolve (N); 19820 T := Etype (N); 19821 R := N; 19822 19823 -- If expander is inactive, type is legal, nothing else to construct 19824 19825 else 19826 return; 19827 end if; 19828 end if; 19829 19830 if not Is_Discrete_Type (T) then 19831 Error_Msg_N ("discrete type required for range", N); 19832 Set_Etype (N, Any_Type); 19833 return; 19834 19835 elsif T = Any_Type then 19836 Set_Etype (N, Any_Type); 19837 return; 19838 end if; 19839 19840 -- We will now create the appropriate Itype to describe the range, but 19841 -- first a check. If we originally had a subtype, then we just label 19842 -- the range with this subtype. Not only is there no need to construct 19843 -- a new subtype, but it is wrong to do so for two reasons: 19844 19845 -- 1. A legality concern, if we have a subtype, it must not freeze, 19846 -- and the Itype would cause freezing incorrectly 19847 19848 -- 2. An efficiency concern, if we created an Itype, it would not be 19849 -- recognized as the same type for the purposes of eliminating 19850 -- checks in some circumstances. 19851 19852 -- We signal this case by setting the subtype entity in Def_Id 19853 19854 if No (Def_Id) then 19855 Def_Id := 19856 Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index); 19857 Set_Etype (Def_Id, Base_Type (T)); 19858 19859 if Is_Signed_Integer_Type (T) then 19860 Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype); 19861 19862 elsif Is_Modular_Integer_Type (T) then 19863 Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype); 19864 19865 else 19866 Mutate_Ekind (Def_Id, E_Enumeration_Subtype); 19867 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 19868 Set_First_Literal (Def_Id, First_Literal (T)); 19869 end if; 19870 19871 Set_Size_Info (Def_Id, (T)); 19872 Set_RM_Size (Def_Id, RM_Size (T)); 19873 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 19874 19875 Set_Scalar_Range (Def_Id, R); 19876 Conditional_Delay (Def_Id, T); 19877 19878 -- In the subtype indication case inherit properties of the parent 19879 19880 if Nkind (N) = N_Subtype_Indication then 19881 19882 -- It is enough to inherit predicate flags and not the predicate 19883 -- functions, because predicates on an index type are illegal 19884 -- anyway and the flags are enough to detect them. 19885 19886 Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N))); 19887 19888 -- If the immediate parent of the new subtype is nonstatic, then 19889 -- the subtype we create is nonstatic as well, even if its bounds 19890 -- are static. 19891 19892 if not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) then 19893 Set_Is_Non_Static_Subtype (Def_Id); 19894 end if; 19895 end if; 19896 19897 Set_Parent (Def_Id, N); 19898 end if; 19899 19900 -- Final step is to label the index with this constructed type 19901 19902 Set_Etype (N, Def_Id); 19903 end Make_Index; 19904 19905 ------------------------------ 19906 -- Modular_Type_Declaration -- 19907 ------------------------------ 19908 19909 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is 19910 Mod_Expr : constant Node_Id := Expression (Def); 19911 M_Val : Uint; 19912 19913 procedure Set_Modular_Size (Bits : Int); 19914 -- Sets RM_Size to Bits, and Esize to normal word size above this 19915 19916 ---------------------- 19917 -- Set_Modular_Size -- 19918 ---------------------- 19919 19920 procedure Set_Modular_Size (Bits : Int) is 19921 Siz : Int; 19922 19923 begin 19924 Set_RM_Size (T, UI_From_Int (Bits)); 19925 19926 if Bits < System_Max_Binary_Modulus_Power then 19927 Siz := 8; 19928 19929 while Siz < 128 loop 19930 exit when Bits <= Siz; 19931 Siz := Siz * 2; 19932 end loop; 19933 19934 Set_Esize (T, UI_From_Int (Siz)); 19935 19936 else 19937 Set_Esize (T, UI_From_Int (System_Max_Binary_Modulus_Power)); 19938 end if; 19939 19940 if not Non_Binary_Modulus (T) and then Esize (T) = RM_Size (T) then 19941 Set_Is_Known_Valid (T); 19942 end if; 19943 end Set_Modular_Size; 19944 19945 -- Start of processing for Modular_Type_Declaration 19946 19947 begin 19948 -- If the mod expression is (exactly) 2 * literal, where literal is 19949 -- 128 or less, then almost certainly the * was meant to be **. Warn. 19950 19951 if Warn_On_Suspicious_Modulus_Value 19952 and then Nkind (Mod_Expr) = N_Op_Multiply 19953 and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal 19954 and then Intval (Left_Opnd (Mod_Expr)) = Uint_2 19955 and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal 19956 and then Intval (Right_Opnd (Mod_Expr)) <= Uint_128 19957 then 19958 Error_Msg_N 19959 ("suspicious MOD value, was '*'* intended'??.m?", Mod_Expr); 19960 end if; 19961 19962 -- Proceed with analysis of mod expression 19963 19964 Analyze_And_Resolve (Mod_Expr, Any_Integer); 19965 19966 if Ekind (T) in Incomplete_Or_Private_Kind then 19967 Reinit_Field_To_Zero (T, F_Stored_Constraint); 19968 end if; 19969 19970 Set_Etype (T, T); 19971 Mutate_Ekind (T, E_Modular_Integer_Type); 19972 Reinit_Alignment (T); 19973 Set_Is_Constrained (T); 19974 19975 if not Is_OK_Static_Expression (Mod_Expr) then 19976 Flag_Non_Static_Expr 19977 ("non-static expression used for modular type bound!", Mod_Expr); 19978 M_Val := 2 ** System_Max_Binary_Modulus_Power; 19979 else 19980 M_Val := Expr_Value (Mod_Expr); 19981 end if; 19982 19983 if M_Val < 1 then 19984 Error_Msg_N ("modulus value must be positive", Mod_Expr); 19985 M_Val := 2 ** System_Max_Binary_Modulus_Power; 19986 end if; 19987 19988 if M_Val > 2 ** Standard_Long_Integer_Size then 19989 Check_Restriction (No_Long_Long_Integers, Mod_Expr); 19990 end if; 19991 19992 Set_Modulus (T, M_Val); 19993 19994 -- Create bounds for the modular type based on the modulus given in 19995 -- the type declaration and then analyze and resolve those bounds. 19996 19997 Set_Scalar_Range (T, 19998 Make_Range (Sloc (Mod_Expr), 19999 Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0), 20000 High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1))); 20001 20002 -- Properly analyze the literals for the range. We do this manually 20003 -- because we can't go calling Resolve, since we are resolving these 20004 -- bounds with the type, and this type is certainly not complete yet. 20005 20006 Set_Etype (Low_Bound (Scalar_Range (T)), T); 20007 Set_Etype (High_Bound (Scalar_Range (T)), T); 20008 Set_Is_Static_Expression (Low_Bound (Scalar_Range (T))); 20009 Set_Is_Static_Expression (High_Bound (Scalar_Range (T))); 20010 20011 -- Loop through powers of two to find number of bits required 20012 20013 for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop 20014 20015 -- Binary case 20016 20017 if M_Val = 2 ** Bits then 20018 Set_Modular_Size (Bits); 20019 return; 20020 20021 -- Nonbinary case 20022 20023 elsif M_Val < 2 ** Bits then 20024 Set_Non_Binary_Modulus (T); 20025 20026 if Bits > System_Max_Nonbinary_Modulus_Power then 20027 Error_Msg_Uint_1 := 20028 UI_From_Int (System_Max_Nonbinary_Modulus_Power); 20029 Error_Msg_F 20030 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr); 20031 Set_Modular_Size (System_Max_Binary_Modulus_Power); 20032 return; 20033 20034 else 20035 -- In the nonbinary case, set size as per RM 13.3(55) 20036 20037 Set_Modular_Size (Bits); 20038 return; 20039 end if; 20040 end if; 20041 20042 end loop; 20043 20044 -- If we fall through, then the size exceed System.Max_Binary_Modulus 20045 -- so we just signal an error and set the maximum size. 20046 20047 Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power); 20048 Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr); 20049 20050 Set_Modular_Size (System_Max_Binary_Modulus_Power); 20051 Reinit_Alignment (T); 20052 20053 end Modular_Type_Declaration; 20054 20055 -------------------------- 20056 -- New_Concatenation_Op -- 20057 -------------------------- 20058 20059 procedure New_Concatenation_Op (Typ : Entity_Id) is 20060 Loc : constant Source_Ptr := Sloc (Typ); 20061 Op : Entity_Id; 20062 20063 function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id; 20064 -- Create abbreviated declaration for the formal of a predefined 20065 -- Operator 'Op' of type 'Typ' 20066 20067 -------------------- 20068 -- Make_Op_Formal -- 20069 -------------------- 20070 20071 function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is 20072 Formal : Entity_Id; 20073 begin 20074 Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P'); 20075 Set_Etype (Formal, Typ); 20076 Set_Mechanism (Formal, Default_Mechanism); 20077 return Formal; 20078 end Make_Op_Formal; 20079 20080 -- Start of processing for New_Concatenation_Op 20081 20082 begin 20083 Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); 20084 20085 Mutate_Ekind (Op, E_Operator); 20086 Set_Scope (Op, Current_Scope); 20087 Set_Etype (Op, Typ); 20088 Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); 20089 Set_Is_Immediately_Visible (Op); 20090 Set_Is_Intrinsic_Subprogram (Op); 20091 Set_Has_Completion (Op); 20092 Append_Entity (Op, Current_Scope); 20093 20094 Set_Name_Entity_Id (Name_Op_Concat, Op); 20095 20096 Append_Entity (Make_Op_Formal (Typ, Op), Op); 20097 Append_Entity (Make_Op_Formal (Typ, Op), Op); 20098 end New_Concatenation_Op; 20099 20100 ------------------------- 20101 -- OK_For_Limited_Init -- 20102 ------------------------- 20103 20104 -- ???Check all calls of this, and compare the conditions under which it's 20105 -- called. 20106 20107 function OK_For_Limited_Init 20108 (Typ : Entity_Id; 20109 Exp : Node_Id) return Boolean 20110 is 20111 begin 20112 return Is_CPP_Constructor_Call (Exp) 20113 or else (Ada_Version >= Ada_2005 20114 and then not Debug_Flag_Dot_L 20115 and then OK_For_Limited_Init_In_05 (Typ, Exp)); 20116 end OK_For_Limited_Init; 20117 20118 ------------------------------- 20119 -- OK_For_Limited_Init_In_05 -- 20120 ------------------------------- 20121 20122 function OK_For_Limited_Init_In_05 20123 (Typ : Entity_Id; 20124 Exp : Node_Id) return Boolean 20125 is 20126 begin 20127 -- An object of a limited interface type can be initialized with any 20128 -- expression of a nonlimited descendant type. However this does not 20129 -- apply if this is a view conversion of some other expression. This 20130 -- is checked below. 20131 20132 if Is_Class_Wide_Type (Typ) 20133 and then Is_Limited_Interface (Typ) 20134 and then not Is_Limited_Type (Etype (Exp)) 20135 and then Nkind (Exp) /= N_Type_Conversion 20136 then 20137 return True; 20138 end if; 20139 20140 -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in 20141 -- case of limited aggregates (including extension aggregates), and 20142 -- function calls. The function call may have been given in prefixed 20143 -- notation, in which case the original node is an indexed component. 20144 -- If the function is parameterless, the original node was an explicit 20145 -- dereference. The function may also be parameterless, in which case 20146 -- the source node is just an identifier. 20147 20148 -- A branch of a conditional expression may have been removed if the 20149 -- condition is statically known. This happens during expansion, and 20150 -- thus will not happen if previous errors were encountered. The check 20151 -- will have been performed on the chosen branch, which replaces the 20152 -- original conditional expression. 20153 20154 if No (Exp) then 20155 return True; 20156 end if; 20157 20158 case Nkind (Original_Node (Exp)) is 20159 when N_Aggregate 20160 | N_Extension_Aggregate 20161 | N_Function_Call 20162 | N_Op 20163 => 20164 return True; 20165 20166 when N_Identifier => 20167 return Present (Entity (Original_Node (Exp))) 20168 and then Ekind (Entity (Original_Node (Exp))) = E_Function; 20169 20170 when N_Qualified_Expression => 20171 return 20172 OK_For_Limited_Init_In_05 20173 (Typ, Expression (Original_Node (Exp))); 20174 20175 -- Ada 2005 (AI-251): If a class-wide interface object is initialized 20176 -- with a function call, the expander has rewritten the call into an 20177 -- N_Type_Conversion node to force displacement of the pointer to 20178 -- reference the component containing the secondary dispatch table. 20179 -- Otherwise a type conversion is not a legal context. 20180 -- A return statement for a build-in-place function returning a 20181 -- synchronized type also introduces an unchecked conversion. 20182 20183 when N_Type_Conversion 20184 | N_Unchecked_Type_Conversion 20185 => 20186 return not Comes_From_Source (Exp) 20187 and then 20188 -- If the conversion has been rewritten, check Original_Node 20189 20190 ((Original_Node (Exp) /= Exp 20191 and then 20192 OK_For_Limited_Init_In_05 (Typ, Original_Node (Exp))) 20193 20194 -- Otherwise, check the expression of the compiler-generated 20195 -- conversion (which is a conversion that we want to ignore 20196 -- for purposes of the limited-initialization restrictions). 20197 20198 or else 20199 (Original_Node (Exp) = Exp 20200 and then 20201 OK_For_Limited_Init_In_05 (Typ, Expression (Exp)))); 20202 20203 when N_Explicit_Dereference 20204 | N_Indexed_Component 20205 | N_Selected_Component 20206 => 20207 return Nkind (Exp) = N_Function_Call; 20208 20209 -- A use of 'Input is a function call, hence allowed. Normally the 20210 -- attribute will be changed to a call, but the attribute by itself 20211 -- can occur with -gnatc. 20212 20213 when N_Attribute_Reference => 20214 return Attribute_Name (Original_Node (Exp)) = Name_Input; 20215 20216 -- "return raise ..." is OK 20217 20218 when N_Raise_Expression => 20219 return True; 20220 20221 -- For a case expression, all dependent expressions must be legal 20222 20223 when N_Case_Expression => 20224 declare 20225 Alt : Node_Id; 20226 20227 begin 20228 Alt := First (Alternatives (Original_Node (Exp))); 20229 while Present (Alt) loop 20230 if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then 20231 return False; 20232 end if; 20233 20234 Next (Alt); 20235 end loop; 20236 20237 return True; 20238 end; 20239 20240 -- For an if expression, all dependent expressions must be legal 20241 20242 when N_If_Expression => 20243 declare 20244 Then_Expr : constant Node_Id := 20245 Next (First (Expressions (Original_Node (Exp)))); 20246 Else_Expr : constant Node_Id := Next (Then_Expr); 20247 begin 20248 return OK_For_Limited_Init_In_05 (Typ, Then_Expr) 20249 and then 20250 OK_For_Limited_Init_In_05 (Typ, Else_Expr); 20251 end; 20252 20253 when others => 20254 return False; 20255 end case; 20256 end OK_For_Limited_Init_In_05; 20257 20258 ------------------------------------------- 20259 -- Ordinary_Fixed_Point_Type_Declaration -- 20260 ------------------------------------------- 20261 20262 procedure Ordinary_Fixed_Point_Type_Declaration 20263 (T : Entity_Id; 20264 Def : Node_Id) 20265 is 20266 Loc : constant Source_Ptr := Sloc (Def); 20267 Delta_Expr : constant Node_Id := Delta_Expression (Def); 20268 RRS : constant Node_Id := Real_Range_Specification (Def); 20269 Implicit_Base : Entity_Id; 20270 Delta_Val : Ureal; 20271 Small_Val : Ureal; 20272 Low_Val : Ureal; 20273 High_Val : Ureal; 20274 20275 begin 20276 Check_Restriction (No_Fixed_Point, Def); 20277 20278 -- Create implicit base type 20279 20280 Implicit_Base := 20281 Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B'); 20282 Set_Etype (Implicit_Base, Implicit_Base); 20283 20284 -- Analyze and process delta expression 20285 20286 Analyze_And_Resolve (Delta_Expr, Any_Real); 20287 20288 Check_Delta_Expression (Delta_Expr); 20289 Delta_Val := Expr_Value_R (Delta_Expr); 20290 20291 Set_Delta_Value (Implicit_Base, Delta_Val); 20292 20293 -- Compute default small from given delta, which is the largest power 20294 -- of two that does not exceed the given delta value. 20295 20296 declare 20297 Tmp : Ureal; 20298 Scale : Int; 20299 20300 begin 20301 Tmp := Ureal_1; 20302 Scale := 0; 20303 20304 if Delta_Val < Ureal_1 then 20305 while Delta_Val < Tmp loop 20306 Tmp := Tmp / Ureal_2; 20307 Scale := Scale + 1; 20308 end loop; 20309 20310 else 20311 loop 20312 Tmp := Tmp * Ureal_2; 20313 exit when Tmp > Delta_Val; 20314 Scale := Scale - 1; 20315 end loop; 20316 end if; 20317 20318 Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2); 20319 end; 20320 20321 Set_Small_Value (Implicit_Base, Small_Val); 20322 20323 -- If no range was given, set a dummy range 20324 20325 if RRS <= Empty_Or_Error then 20326 Low_Val := -Small_Val; 20327 High_Val := Small_Val; 20328 20329 -- Otherwise analyze and process given range 20330 20331 else 20332 declare 20333 Low : constant Node_Id := Low_Bound (RRS); 20334 High : constant Node_Id := High_Bound (RRS); 20335 20336 begin 20337 Analyze_And_Resolve (Low, Any_Real); 20338 Analyze_And_Resolve (High, Any_Real); 20339 Check_Real_Bound (Low); 20340 Check_Real_Bound (High); 20341 20342 -- Obtain and set the range 20343 20344 Low_Val := Expr_Value_R (Low); 20345 High_Val := Expr_Value_R (High); 20346 20347 if Low_Val > High_Val then 20348 Error_Msg_NE ("??fixed point type& has null range", Def, T); 20349 end if; 20350 end; 20351 end if; 20352 20353 -- The range for both the implicit base and the declared first subtype 20354 -- cannot be set yet, so we use the special routine Set_Fixed_Range to 20355 -- set a temporary range in place. Note that the bounds of the base 20356 -- type will be widened to be symmetrical and to fill the available 20357 -- bits when the type is frozen. 20358 20359 -- We could do this with all discrete types, and probably should, but 20360 -- we absolutely have to do it for fixed-point, since the end-points 20361 -- of the range and the size are determined by the small value, which 20362 -- could be reset before the freeze point. 20363 20364 Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); 20365 Set_Fixed_Range (T, Loc, Low_Val, High_Val); 20366 20367 -- Complete definition of first subtype. The inheritance of the rep item 20368 -- chain ensures that SPARK-related pragmas are not clobbered when the 20369 -- ordinary fixed point type acts as a full view of a private type. 20370 20371 Mutate_Ekind (T, E_Ordinary_Fixed_Point_Subtype); 20372 Set_Etype (T, Implicit_Base); 20373 Reinit_Size_Align (T); 20374 Inherit_Rep_Item_Chain (T, Implicit_Base); 20375 Set_Small_Value (T, Small_Val); 20376 Set_Delta_Value (T, Delta_Val); 20377 Set_Is_Constrained (T); 20378 end Ordinary_Fixed_Point_Type_Declaration; 20379 20380 ---------------------------------- 20381 -- Preanalyze_Assert_Expression -- 20382 ---------------------------------- 20383 20384 procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is 20385 begin 20386 In_Assertion_Expr := In_Assertion_Expr + 1; 20387 Preanalyze_Spec_Expression (N, T); 20388 In_Assertion_Expr := In_Assertion_Expr - 1; 20389 end Preanalyze_Assert_Expression; 20390 20391 ----------------------------------- 20392 -- Preanalyze_Default_Expression -- 20393 ----------------------------------- 20394 20395 procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is 20396 Save_In_Default_Expr : constant Boolean := In_Default_Expr; 20397 Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; 20398 20399 begin 20400 In_Default_Expr := True; 20401 In_Spec_Expression := True; 20402 20403 Preanalyze_With_Freezing_And_Resolve (N, T); 20404 20405 In_Default_Expr := Save_In_Default_Expr; 20406 In_Spec_Expression := Save_In_Spec_Expression; 20407 end Preanalyze_Default_Expression; 20408 20409 -------------------------------- 20410 -- Preanalyze_Spec_Expression -- 20411 -------------------------------- 20412 20413 procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is 20414 Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; 20415 begin 20416 In_Spec_Expression := True; 20417 Preanalyze_And_Resolve (N, T); 20418 In_Spec_Expression := Save_In_Spec_Expression; 20419 end Preanalyze_Spec_Expression; 20420 20421 ---------------------------------------- 20422 -- Prepare_Private_Subtype_Completion -- 20423 ---------------------------------------- 20424 20425 procedure Prepare_Private_Subtype_Completion 20426 (Id : Entity_Id; 20427 Related_Nod : Node_Id) 20428 is 20429 Id_B : constant Entity_Id := Base_Type (Id); 20430 Full_B : constant Entity_Id := Full_View (Id_B); 20431 Full : Entity_Id; 20432 20433 begin 20434 if Present (Full_B) then 20435 20436 -- The Base_Type is already completed, we can complete the subtype 20437 -- now. We have to create a new entity with the same name, Thus we 20438 -- can't use Create_Itype. 20439 20440 Full := Make_Defining_Identifier (Sloc (Id), Chars (Id)); 20441 Set_Is_Itype (Full); 20442 Set_Associated_Node_For_Itype (Full, Related_Nod); 20443 Complete_Private_Subtype (Id, Full, Full_B, Related_Nod); 20444 Set_Full_View (Id, Full); 20445 end if; 20446 20447 -- The parent subtype may be private, but the base might not, in some 20448 -- nested instances. In that case, the subtype does not need to be 20449 -- exchanged. It would still be nice to make private subtypes and their 20450 -- bases consistent at all times ??? 20451 20452 if Is_Private_Type (Id_B) then 20453 Append_Elmt (Id, Private_Dependents (Id_B)); 20454 end if; 20455 end Prepare_Private_Subtype_Completion; 20456 20457 --------------------------- 20458 -- Process_Discriminants -- 20459 --------------------------- 20460 20461 procedure Process_Discriminants 20462 (N : Node_Id; 20463 Prev : Entity_Id := Empty) 20464 is 20465 Elist : constant Elist_Id := New_Elmt_List; 20466 Id : Node_Id; 20467 Discr : Node_Id; 20468 Discr_Number : Uint; 20469 Discr_Type : Entity_Id; 20470 Default_Present : Boolean := False; 20471 Default_Not_Present : Boolean := False; 20472 20473 begin 20474 -- A composite type other than an array type can have discriminants. 20475 -- On entry, the current scope is the composite type. 20476 20477 -- The discriminants are initially entered into the scope of the type 20478 -- via Enter_Name with the default Ekind of E_Void to prevent premature 20479 -- use, as explained at the end of this procedure. 20480 20481 Discr := First (Discriminant_Specifications (N)); 20482 while Present (Discr) loop 20483 Enter_Name (Defining_Identifier (Discr)); 20484 20485 -- For navigation purposes we add a reference to the discriminant 20486 -- in the entity for the type. If the current declaration is a 20487 -- completion, place references on the partial view. Otherwise the 20488 -- type is the current scope. 20489 20490 if Present (Prev) then 20491 20492 -- The references go on the partial view, if present. If the 20493 -- partial view has discriminants, the references have been 20494 -- generated already. 20495 20496 if not Has_Discriminants (Prev) then 20497 Generate_Reference (Prev, Defining_Identifier (Discr), 'd'); 20498 end if; 20499 else 20500 Generate_Reference 20501 (Current_Scope, Defining_Identifier (Discr), 'd'); 20502 end if; 20503 20504 if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then 20505 Check_Anonymous_Access_Component 20506 (Typ_Decl => N, 20507 Typ => Defining_Identifier (N), 20508 Prev => Prev, 20509 Comp_Def => Discr, 20510 Access_Def => Discriminant_Type (Discr)); 20511 20512 -- if Check_Anonymous_Access_Component replaced Discr then 20513 -- its Original_Node points to the old Discr and the access type 20514 -- for Discr_Type has already been created. 20515 20516 if Original_Node (Discr) /= Discr then 20517 Discr_Type := Etype (Discriminant_Type (Discr)); 20518 else 20519 Discr_Type := 20520 Access_Definition (Discr, Discriminant_Type (Discr)); 20521 20522 -- Ada 2005 (AI-254) 20523 20524 if Present (Access_To_Subprogram_Definition 20525 (Discriminant_Type (Discr))) 20526 and then Protected_Present (Access_To_Subprogram_Definition 20527 (Discriminant_Type (Discr))) 20528 then 20529 Discr_Type := 20530 Replace_Anonymous_Access_To_Protected_Subprogram (Discr); 20531 end if; 20532 end if; 20533 else 20534 Find_Type (Discriminant_Type (Discr)); 20535 Discr_Type := Etype (Discriminant_Type (Discr)); 20536 20537 if Error_Posted (Discriminant_Type (Discr)) then 20538 Discr_Type := Any_Type; 20539 end if; 20540 end if; 20541 20542 -- Handling of discriminants that are access types 20543 20544 if Is_Access_Type (Discr_Type) then 20545 20546 -- Ada 2005 (AI-230): Access discriminant allowed in non- 20547 -- limited record types 20548 20549 if Ada_Version < Ada_2005 then 20550 Check_Access_Discriminant_Requires_Limited 20551 (Discr, Discriminant_Type (Discr)); 20552 end if; 20553 20554 if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then 20555 Error_Msg_N 20556 ("(Ada 83) access discriminant not allowed", Discr); 20557 end if; 20558 20559 -- If not access type, must be a discrete type 20560 20561 elsif not Is_Discrete_Type (Discr_Type) then 20562 Error_Msg_N 20563 ("discriminants must have a discrete or access type", 20564 Discriminant_Type (Discr)); 20565 end if; 20566 20567 Set_Etype (Defining_Identifier (Discr), Discr_Type); 20568 20569 -- If a discriminant specification includes the assignment compound 20570 -- delimiter followed by an expression, the expression is the default 20571 -- expression of the discriminant; the default expression must be of 20572 -- the type of the discriminant. (RM 3.7.1) Since this expression is 20573 -- a default expression, we do the special preanalysis, since this 20574 -- expression does not freeze (see section "Handling of Default and 20575 -- Per-Object Expressions" in spec of package Sem). 20576 20577 if Present (Expression (Discr)) then 20578 Preanalyze_Default_Expression (Expression (Discr), Discr_Type); 20579 20580 -- Legaity checks 20581 20582 if Nkind (N) = N_Formal_Type_Declaration then 20583 Error_Msg_N 20584 ("discriminant defaults not allowed for formal type", 20585 Expression (Discr)); 20586 20587 -- Flag an error for a tagged type with defaulted discriminants, 20588 -- excluding limited tagged types when compiling for Ada 2012 20589 -- (see AI05-0214). 20590 20591 elsif Is_Tagged_Type (Current_Scope) 20592 and then (not Is_Limited_Type (Current_Scope) 20593 or else Ada_Version < Ada_2012) 20594 and then Comes_From_Source (N) 20595 then 20596 -- Note: see similar test in Check_Or_Process_Discriminants, to 20597 -- handle the (illegal) case of the completion of an untagged 20598 -- view with discriminants with defaults by a tagged full view. 20599 -- We skip the check if Discr does not come from source, to 20600 -- account for the case of an untagged derived type providing 20601 -- defaults for a renamed discriminant from a private untagged 20602 -- ancestor with a tagged full view (ACATS B460006). 20603 20604 if Ada_Version >= Ada_2012 then 20605 Error_Msg_N 20606 ("discriminants of nonlimited tagged type cannot have" 20607 & " defaults", 20608 Expression (Discr)); 20609 else 20610 Error_Msg_N 20611 ("discriminants of tagged type cannot have defaults", 20612 Expression (Discr)); 20613 end if; 20614 20615 else 20616 Default_Present := True; 20617 Append_Elmt (Expression (Discr), Elist); 20618 20619 -- Tag the defining identifiers for the discriminants with 20620 -- their corresponding default expressions from the tree. 20621 20622 Set_Discriminant_Default_Value 20623 (Defining_Identifier (Discr), Expression (Discr)); 20624 end if; 20625 20626 -- In gnatc or GNATprove mode, make sure set Do_Range_Check flag 20627 -- gets set unless we can be sure that no range check is required. 20628 20629 if not Expander_Active 20630 and then not 20631 Is_In_Range 20632 (Expression (Discr), Discr_Type, Assume_Valid => True) 20633 then 20634 Set_Do_Range_Check (Expression (Discr)); 20635 end if; 20636 20637 -- No default discriminant value given 20638 20639 else 20640 Default_Not_Present := True; 20641 end if; 20642 20643 -- Ada 2005 (AI-231): Create an Itype that is a duplicate of 20644 -- Discr_Type but with the null-exclusion attribute 20645 20646 if Ada_Version >= Ada_2005 then 20647 20648 -- Ada 2005 (AI-231): Static checks 20649 20650 if Can_Never_Be_Null (Discr_Type) then 20651 Null_Exclusion_Static_Checks (Discr); 20652 20653 elsif Is_Access_Type (Discr_Type) 20654 and then Null_Exclusion_Present (Discr) 20655 20656 -- No need to check itypes because in their case this check 20657 -- was done at their point of creation 20658 20659 and then not Is_Itype (Discr_Type) 20660 then 20661 if Can_Never_Be_Null (Discr_Type) then 20662 Error_Msg_NE 20663 ("`NOT NULL` not allowed (& already excludes null)", 20664 Discr, 20665 Discr_Type); 20666 end if; 20667 20668 Set_Etype (Defining_Identifier (Discr), 20669 Create_Null_Excluding_Itype 20670 (T => Discr_Type, 20671 Related_Nod => Discr)); 20672 20673 -- Check for improper null exclusion if the type is otherwise 20674 -- legal for a discriminant. 20675 20676 elsif Null_Exclusion_Present (Discr) 20677 and then Is_Discrete_Type (Discr_Type) 20678 then 20679 Error_Msg_N 20680 ("null exclusion can only apply to an access type", Discr); 20681 end if; 20682 20683 -- Ada 2005 (AI-402): access discriminants of nonlimited types 20684 -- can't have defaults. Synchronized types, or types that are 20685 -- explicitly limited are fine, but special tests apply to derived 20686 -- types in generics: in a generic body we have to assume the 20687 -- worst, and therefore defaults are not allowed if the parent is 20688 -- a generic formal private type (see ACATS B370001). 20689 20690 if Is_Access_Type (Discr_Type) and then Default_Present then 20691 if Ekind (Discr_Type) /= E_Anonymous_Access_Type 20692 or else Is_Limited_Record (Current_Scope) 20693 or else Is_Concurrent_Type (Current_Scope) 20694 or else Is_Concurrent_Record_Type (Current_Scope) 20695 or else Ekind (Current_Scope) = E_Limited_Private_Type 20696 then 20697 if not Is_Derived_Type (Current_Scope) 20698 or else not Is_Generic_Type (Etype (Current_Scope)) 20699 or else not In_Package_Body (Scope (Etype (Current_Scope))) 20700 or else Limited_Present 20701 (Type_Definition (Parent (Current_Scope))) 20702 then 20703 null; 20704 20705 else 20706 Error_Msg_N 20707 ("access discriminants of nonlimited types cannot " 20708 & "have defaults", Expression (Discr)); 20709 end if; 20710 20711 elsif Present (Expression (Discr)) then 20712 Error_Msg_N 20713 ("(Ada 2005) access discriminants of nonlimited types " 20714 & "cannot have defaults", Expression (Discr)); 20715 end if; 20716 end if; 20717 end if; 20718 20719 -- A discriminant cannot be effectively volatile (SPARK RM 7.1.3(4)). 20720 -- This check is relevant only when SPARK_Mode is on as it is not a 20721 -- standard Ada legality rule. The only way for a discriminant to be 20722 -- effectively volatile is to have an effectively volatile type, so 20723 -- we check this directly, because the Ekind of Discr might not be 20724 -- set yet (to help preventing cascaded errors on derived types). 20725 20726 if SPARK_Mode = On 20727 and then Is_Effectively_Volatile (Discr_Type) 20728 then 20729 Error_Msg_N ("discriminant cannot be volatile", Discr); 20730 end if; 20731 20732 Next (Discr); 20733 end loop; 20734 20735 -- An element list consisting of the default expressions of the 20736 -- discriminants is constructed in the above loop and used to set 20737 -- the Discriminant_Constraint attribute for the type. If an object 20738 -- is declared of this (record or task) type without any explicit 20739 -- discriminant constraint given, this element list will form the 20740 -- actual parameters for the corresponding initialization procedure 20741 -- for the type. 20742 20743 Set_Discriminant_Constraint (Current_Scope, Elist); 20744 Set_Stored_Constraint (Current_Scope, No_Elist); 20745 20746 -- Default expressions must be provided either for all or for none 20747 -- of the discriminants of a discriminant part. (RM 3.7.1) 20748 20749 if Default_Present and then Default_Not_Present then 20750 Error_Msg_N 20751 ("incomplete specification of defaults for discriminants", N); 20752 end if; 20753 20754 -- The use of the name of a discriminant is not allowed in default 20755 -- expressions of a discriminant part if the specification of the 20756 -- discriminant is itself given in the discriminant part. (RM 3.7.1) 20757 20758 -- To detect this, the discriminant names are entered initially with an 20759 -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any 20760 -- attempt to use a void entity (for example in an expression that is 20761 -- type-checked) produces the error message: premature usage. Now after 20762 -- completing the semantic analysis of the discriminant part, we can set 20763 -- the Ekind of all the discriminants appropriately. 20764 20765 Discr := First (Discriminant_Specifications (N)); 20766 Discr_Number := Uint_1; 20767 while Present (Discr) loop 20768 Id := Defining_Identifier (Discr); 20769 20770 if Ekind (Id) = E_In_Parameter then 20771 Reinit_Field_To_Zero (Id, F_Discriminal_Link); 20772 end if; 20773 20774 Mutate_Ekind (Id, E_Discriminant); 20775 Reinit_Component_Location (Id); 20776 Reinit_Esize (Id); 20777 Set_Discriminant_Number (Id, Discr_Number); 20778 20779 -- Make sure this is always set, even in illegal programs 20780 20781 Set_Corresponding_Discriminant (Id, Empty); 20782 20783 -- Initialize the Original_Record_Component to the entity itself. 20784 -- Inherit_Components will propagate the right value to 20785 -- discriminants in derived record types. 20786 20787 Set_Original_Record_Component (Id, Id); 20788 20789 -- Create the discriminal for the discriminant 20790 20791 Build_Discriminal (Id); 20792 20793 Next (Discr); 20794 Discr_Number := Discr_Number + 1; 20795 end loop; 20796 20797 Set_Has_Discriminants (Current_Scope); 20798 end Process_Discriminants; 20799 20800 ----------------------- 20801 -- Process_Full_View -- 20802 ----------------------- 20803 20804 -- WARNING: This routine manages Ghost regions. Return statements must be 20805 -- replaced by gotos which jump to the end of the routine and restore the 20806 -- Ghost mode. 20807 20808 procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is 20809 procedure Collect_Implemented_Interfaces 20810 (Typ : Entity_Id; 20811 Ifaces : Elist_Id); 20812 -- Ada 2005: Gather all the interfaces that Typ directly or 20813 -- inherently implements. Duplicate entries are not added to 20814 -- the list Ifaces. 20815 20816 ------------------------------------ 20817 -- Collect_Implemented_Interfaces -- 20818 ------------------------------------ 20819 20820 procedure Collect_Implemented_Interfaces 20821 (Typ : Entity_Id; 20822 Ifaces : Elist_Id) 20823 is 20824 Iface : Entity_Id; 20825 Iface_Elmt : Elmt_Id; 20826 20827 begin 20828 -- Abstract interfaces are only associated with tagged record types 20829 20830 if not Is_Tagged_Type (Typ) or else not Is_Record_Type (Typ) then 20831 return; 20832 end if; 20833 20834 -- Recursively climb to the ancestors 20835 20836 if Etype (Typ) /= Typ 20837 20838 -- Protect the frontend against wrong cyclic declarations like: 20839 20840 -- type B is new A with private; 20841 -- type C is new A with private; 20842 -- private 20843 -- type B is new C with null record; 20844 -- type C is new B with null record; 20845 20846 and then Etype (Typ) /= Priv_T 20847 and then Etype (Typ) /= Full_T 20848 then 20849 -- Keep separate the management of private type declarations 20850 20851 if Ekind (Typ) = E_Record_Type_With_Private then 20852 20853 -- Handle the following illegal usage: 20854 -- type Private_Type is tagged private; 20855 -- private 20856 -- type Private_Type is new Type_Implementing_Iface; 20857 20858 if Present (Full_View (Typ)) 20859 and then Etype (Typ) /= Full_View (Typ) 20860 then 20861 if Is_Interface (Etype (Typ)) then 20862 Append_Unique_Elmt (Etype (Typ), Ifaces); 20863 end if; 20864 20865 Collect_Implemented_Interfaces (Etype (Typ), Ifaces); 20866 end if; 20867 20868 -- Non-private types 20869 20870 else 20871 if Is_Interface (Etype (Typ)) then 20872 Append_Unique_Elmt (Etype (Typ), Ifaces); 20873 end if; 20874 20875 Collect_Implemented_Interfaces (Etype (Typ), Ifaces); 20876 end if; 20877 end if; 20878 20879 -- Handle entities in the list of abstract interfaces 20880 20881 if Present (Interfaces (Typ)) then 20882 Iface_Elmt := First_Elmt (Interfaces (Typ)); 20883 while Present (Iface_Elmt) loop 20884 Iface := Node (Iface_Elmt); 20885 20886 pragma Assert (Is_Interface (Iface)); 20887 20888 if not Contain_Interface (Iface, Ifaces) then 20889 Append_Elmt (Iface, Ifaces); 20890 Collect_Implemented_Interfaces (Iface, Ifaces); 20891 end if; 20892 20893 Next_Elmt (Iface_Elmt); 20894 end loop; 20895 end if; 20896 end Collect_Implemented_Interfaces; 20897 20898 -- Local variables 20899 20900 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 20901 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 20902 -- Save the Ghost-related attributes to restore on exit 20903 20904 Full_Indic : Node_Id; 20905 Full_Parent : Entity_Id; 20906 Priv_Parent : Entity_Id; 20907 20908 -- Start of processing for Process_Full_View 20909 20910 begin 20911 Mark_And_Set_Ghost_Completion (N, Priv_T); 20912 20913 -- First some sanity checks that must be done after semantic 20914 -- decoration of the full view and thus cannot be placed with other 20915 -- similar checks in Find_Type_Name 20916 20917 if not Is_Limited_Type (Priv_T) 20918 and then (Is_Limited_Type (Full_T) 20919 or else Is_Limited_Composite (Full_T)) 20920 then 20921 if In_Instance then 20922 null; 20923 else 20924 Error_Msg_N 20925 ("completion of nonlimited type cannot be limited", Full_T); 20926 Explain_Limited_Type (Full_T, Full_T); 20927 end if; 20928 20929 elsif Is_Abstract_Type (Full_T) 20930 and then not Is_Abstract_Type (Priv_T) 20931 then 20932 Error_Msg_N 20933 ("completion of nonabstract type cannot be abstract", Full_T); 20934 20935 elsif Is_Tagged_Type (Priv_T) 20936 and then Is_Limited_Type (Priv_T) 20937 and then not Is_Limited_Type (Full_T) 20938 then 20939 -- If pragma CPP_Class was applied to the private declaration 20940 -- propagate the limitedness to the full-view 20941 20942 if Is_CPP_Class (Priv_T) then 20943 Set_Is_Limited_Record (Full_T); 20944 20945 -- GNAT allow its own definition of Limited_Controlled to disobey 20946 -- this rule in order in ease the implementation. This test is safe 20947 -- because Root_Controlled is defined in a child of System that 20948 -- normal programs are not supposed to use. 20949 20950 elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then 20951 Set_Is_Limited_Composite (Full_T); 20952 else 20953 Error_Msg_N 20954 ("completion of limited tagged type must be limited", Full_T); 20955 end if; 20956 20957 elsif Is_Generic_Type (Priv_T) then 20958 Error_Msg_N ("generic type cannot have a completion", Full_T); 20959 end if; 20960 20961 -- Check that ancestor interfaces of private and full views are 20962 -- consistent. We omit this check for synchronized types because 20963 -- they are performed on the corresponding record type when frozen. 20964 20965 if Ada_Version >= Ada_2005 20966 and then Is_Tagged_Type (Priv_T) 20967 and then Is_Tagged_Type (Full_T) 20968 and then not Is_Concurrent_Type (Full_T) 20969 then 20970 declare 20971 Iface : Entity_Id; 20972 Priv_T_Ifaces : constant Elist_Id := New_Elmt_List; 20973 Full_T_Ifaces : constant Elist_Id := New_Elmt_List; 20974 20975 begin 20976 Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces); 20977 Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces); 20978 20979 -- Ada 2005 (AI-251): The partial view shall be a descendant of 20980 -- an interface type if and only if the full type is descendant 20981 -- of the interface type (AARM 7.3 (7.3/2)). 20982 20983 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); 20984 20985 if Present (Iface) then 20986 Error_Msg_NE 20987 ("interface in partial view& not implemented by full type " 20988 & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); 20989 end if; 20990 20991 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); 20992 20993 if Present (Iface) then 20994 Error_Msg_NE 20995 ("interface & not implemented by partial view " 20996 & "(RM-2005 7.3 (7.3/2))", Full_T, Iface); 20997 end if; 20998 end; 20999 end if; 21000 21001 if Is_Tagged_Type (Priv_T) 21002 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 21003 and then Is_Derived_Type (Full_T) 21004 then 21005 Priv_Parent := Etype (Priv_T); 21006 21007 -- The full view of a private extension may have been transformed 21008 -- into an unconstrained derived type declaration and a subtype 21009 -- declaration (see build_derived_record_type for details). 21010 21011 if Nkind (N) = N_Subtype_Declaration then 21012 Full_Indic := Subtype_Indication (N); 21013 Full_Parent := Etype (Base_Type (Full_T)); 21014 else 21015 Full_Indic := Subtype_Indication (Type_Definition (N)); 21016 Full_Parent := Etype (Full_T); 21017 end if; 21018 21019 -- Check that the parent type of the full type is a descendant of 21020 -- the ancestor subtype given in the private extension. If either 21021 -- entity has an Etype equal to Any_Type then we had some previous 21022 -- error situation [7.3(8)]. 21023 21024 if Priv_Parent = Any_Type or else Full_Parent = Any_Type then 21025 goto Leave; 21026 21027 -- Ada 2005 (AI-251): Interfaces in the full type can be given in 21028 -- any order. Therefore we don't have to check that its parent must 21029 -- be a descendant of the parent of the private type declaration. 21030 21031 elsif Is_Interface (Priv_Parent) 21032 and then Is_Interface (Full_Parent) 21033 then 21034 null; 21035 21036 -- Ada 2005 (AI-251): If the parent of the private type declaration 21037 -- is an interface there is no need to check that it is an ancestor 21038 -- of the associated full type declaration. The required tests for 21039 -- this case are performed by Build_Derived_Record_Type. 21040 21041 elsif not Is_Interface (Base_Type (Priv_Parent)) 21042 and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) 21043 then 21044 Error_Msg_N 21045 ("parent of full type must descend from parent of private " 21046 & "extension", Full_Indic); 21047 21048 -- First check a formal restriction, and then proceed with checking 21049 -- Ada rules. Since the formal restriction is not a serious error, we 21050 -- don't prevent further error detection for this check, hence the 21051 -- ELSE. 21052 21053 else 21054 -- Check the rules of 7.3(10): if the private extension inherits 21055 -- known discriminants, then the full type must also inherit those 21056 -- discriminants from the same (ancestor) type, and the parent 21057 -- subtype of the full type must be constrained if and only if 21058 -- the ancestor subtype of the private extension is constrained. 21059 21060 if No (Discriminant_Specifications (Parent (Priv_T))) 21061 and then not Has_Unknown_Discriminants (Priv_T) 21062 and then Has_Discriminants (Base_Type (Priv_Parent)) 21063 then 21064 declare 21065 Priv_Indic : constant Node_Id := 21066 Subtype_Indication (Parent (Priv_T)); 21067 21068 Priv_Constr : constant Boolean := 21069 Is_Constrained (Priv_Parent) 21070 or else 21071 Nkind (Priv_Indic) = N_Subtype_Indication 21072 or else 21073 Is_Constrained (Entity (Priv_Indic)); 21074 21075 Full_Constr : constant Boolean := 21076 Is_Constrained (Full_Parent) 21077 or else 21078 Nkind (Full_Indic) = N_Subtype_Indication 21079 or else 21080 Is_Constrained (Entity (Full_Indic)); 21081 21082 Priv_Discr : Entity_Id; 21083 Full_Discr : Entity_Id; 21084 21085 begin 21086 Priv_Discr := First_Discriminant (Priv_Parent); 21087 Full_Discr := First_Discriminant (Full_Parent); 21088 while Present (Priv_Discr) and then Present (Full_Discr) loop 21089 if Original_Record_Component (Priv_Discr) = 21090 Original_Record_Component (Full_Discr) 21091 or else 21092 Corresponding_Discriminant (Priv_Discr) = 21093 Corresponding_Discriminant (Full_Discr) 21094 then 21095 null; 21096 else 21097 exit; 21098 end if; 21099 21100 Next_Discriminant (Priv_Discr); 21101 Next_Discriminant (Full_Discr); 21102 end loop; 21103 21104 if Present (Priv_Discr) or else Present (Full_Discr) then 21105 Error_Msg_N 21106 ("full view must inherit discriminants of the parent " 21107 & "type used in the private extension", Full_Indic); 21108 21109 elsif Priv_Constr and then not Full_Constr then 21110 Error_Msg_N 21111 ("parent subtype of full type must be constrained", 21112 Full_Indic); 21113 21114 elsif Full_Constr and then not Priv_Constr then 21115 Error_Msg_N 21116 ("parent subtype of full type must be unconstrained", 21117 Full_Indic); 21118 end if; 21119 end; 21120 21121 -- Check the rules of 7.3(12): if a partial view has neither 21122 -- known or unknown discriminants, then the full type 21123 -- declaration shall define a definite subtype. 21124 21125 elsif not Has_Unknown_Discriminants (Priv_T) 21126 and then not Has_Discriminants (Priv_T) 21127 and then not Is_Constrained (Full_T) 21128 then 21129 Error_Msg_N 21130 ("full view must define a constrained type if partial view " 21131 & "has no discriminants", Full_T); 21132 end if; 21133 21134 -- Do we implement the following properly??? 21135 -- If the ancestor subtype of a private extension has constrained 21136 -- discriminants, then the parent subtype of the full view shall 21137 -- impose a statically matching constraint on those discriminants 21138 -- [7.3(13)]. 21139 end if; 21140 21141 else 21142 -- For untagged types, verify that a type without discriminants is 21143 -- not completed with an unconstrained type. A separate error message 21144 -- is produced if the full type has defaulted discriminants. 21145 21146 if Is_Definite_Subtype (Priv_T) 21147 and then not Is_Definite_Subtype (Full_T) 21148 then 21149 Error_Msg_Sloc := Sloc (Parent (Priv_T)); 21150 Error_Msg_NE 21151 ("full view of& not compatible with declaration#", 21152 Full_T, Priv_T); 21153 21154 if not Is_Tagged_Type (Full_T) then 21155 Error_Msg_N 21156 ("\one is constrained, the other unconstrained", Full_T); 21157 end if; 21158 end if; 21159 end if; 21160 21161 -- AI-419: verify that the use of "limited" is consistent 21162 21163 declare 21164 Orig_Decl : constant Node_Id := Original_Node (N); 21165 21166 begin 21167 if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 21168 and then Nkind (Orig_Decl) = N_Full_Type_Declaration 21169 and then Nkind 21170 (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition 21171 then 21172 if not Limited_Present (Parent (Priv_T)) 21173 and then not Synchronized_Present (Parent (Priv_T)) 21174 and then Limited_Present (Type_Definition (Orig_Decl)) 21175 then 21176 Error_Msg_N 21177 ("full view of non-limited extension cannot be limited", N); 21178 21179 -- Conversely, if the partial view carries the limited keyword, 21180 -- the full view must as well, even if it may be redundant. 21181 21182 elsif Limited_Present (Parent (Priv_T)) 21183 and then not Limited_Present (Type_Definition (Orig_Decl)) 21184 then 21185 Error_Msg_N 21186 ("full view of limited extension must be explicitly limited", 21187 N); 21188 end if; 21189 end if; 21190 end; 21191 21192 -- Ada 2005 (AI-443): A synchronized private extension must be 21193 -- completed by a task or protected type. 21194 21195 if Ada_Version >= Ada_2005 21196 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 21197 and then Synchronized_Present (Parent (Priv_T)) 21198 and then not Is_Concurrent_Type (Full_T) 21199 then 21200 Error_Msg_N ("full view of synchronized extension must " & 21201 "be synchronized type", N); 21202 end if; 21203 21204 -- Ada 2005 AI-363: if the full view has discriminants with 21205 -- defaults, it is illegal to declare constrained access subtypes 21206 -- whose designated type is the current type. This allows objects 21207 -- of the type that are declared in the heap to be unconstrained. 21208 21209 if not Has_Unknown_Discriminants (Priv_T) 21210 and then not Has_Discriminants (Priv_T) 21211 and then Has_Defaulted_Discriminants (Full_T) 21212 then 21213 Set_Has_Constrained_Partial_View (Base_Type (Full_T)); 21214 Set_Has_Constrained_Partial_View (Priv_T); 21215 end if; 21216 21217 -- Create a full declaration for all its subtypes recorded in 21218 -- Private_Dependents and swap them similarly to the base type. These 21219 -- are subtypes that have been define before the full declaration of 21220 -- the private type. We also swap the entry in Private_Dependents list 21221 -- so we can properly restore the private view on exit from the scope. 21222 21223 declare 21224 Priv_Elmt : Elmt_Id; 21225 Priv_Scop : Entity_Id; 21226 Priv : Entity_Id; 21227 Full : Entity_Id; 21228 21229 begin 21230 Priv_Elmt := First_Elmt (Private_Dependents (Priv_T)); 21231 while Present (Priv_Elmt) loop 21232 Priv := Node (Priv_Elmt); 21233 Priv_Scop := Scope (Priv); 21234 21235 if Ekind (Priv) in E_Private_Subtype 21236 | E_Limited_Private_Subtype 21237 | E_Record_Subtype_With_Private 21238 then 21239 Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); 21240 Set_Is_Itype (Full); 21241 Set_Parent (Full, Parent (Priv)); 21242 Set_Associated_Node_For_Itype (Full, N); 21243 21244 -- Now we need to complete the private subtype, but since the 21245 -- base type has already been swapped, we must also swap the 21246 -- subtypes (and thus, reverse the arguments in the call to 21247 -- Complete_Private_Subtype). Also note that we may need to 21248 -- re-establish the scope of the private subtype. 21249 21250 Copy_And_Swap (Priv, Full); 21251 21252 if not In_Open_Scopes (Priv_Scop) then 21253 Push_Scope (Priv_Scop); 21254 21255 else 21256 -- Reset Priv_Scop to Empty to indicate no scope was pushed 21257 21258 Priv_Scop := Empty; 21259 end if; 21260 21261 Complete_Private_Subtype (Full, Priv, Full_T, N); 21262 Set_Full_View (Full, Priv); 21263 21264 if Present (Priv_Scop) then 21265 Pop_Scope; 21266 end if; 21267 21268 Replace_Elmt (Priv_Elmt, Full); 21269 end if; 21270 21271 Next_Elmt (Priv_Elmt); 21272 end loop; 21273 end; 21274 21275 declare 21276 Disp_Typ : Entity_Id; 21277 Full_List : Elist_Id; 21278 Prim : Entity_Id; 21279 Prim_Elmt : Elmt_Id; 21280 Priv_List : Elist_Id; 21281 21282 function Contains 21283 (E : Entity_Id; 21284 L : Elist_Id) return Boolean; 21285 -- Determine whether list L contains element E 21286 21287 -------------- 21288 -- Contains -- 21289 -------------- 21290 21291 function Contains 21292 (E : Entity_Id; 21293 L : Elist_Id) return Boolean 21294 is 21295 List_Elmt : Elmt_Id; 21296 21297 begin 21298 List_Elmt := First_Elmt (L); 21299 while Present (List_Elmt) loop 21300 if Node (List_Elmt) = E then 21301 return True; 21302 end if; 21303 21304 Next_Elmt (List_Elmt); 21305 end loop; 21306 21307 return False; 21308 end Contains; 21309 21310 -- Start of processing 21311 21312 begin 21313 -- If the private view was tagged, copy the new primitive operations 21314 -- from the private view to the full view. 21315 21316 if Is_Tagged_Type (Full_T) then 21317 if Is_Tagged_Type (Priv_T) then 21318 Priv_List := Primitive_Operations (Priv_T); 21319 Prim_Elmt := First_Elmt (Priv_List); 21320 21321 -- In the case of a concurrent type completing a private tagged 21322 -- type, primitives may have been declared in between the two 21323 -- views. These subprograms need to be wrapped the same way 21324 -- entries and protected procedures are handled because they 21325 -- cannot be directly shared by the two views. 21326 21327 if Is_Concurrent_Type (Full_T) then 21328 declare 21329 Conc_Typ : constant Entity_Id := 21330 Corresponding_Record_Type (Full_T); 21331 Curr_Nod : Node_Id := Parent (Conc_Typ); 21332 Wrap_Spec : Node_Id; 21333 21334 begin 21335 while Present (Prim_Elmt) loop 21336 Prim := Node (Prim_Elmt); 21337 21338 if Comes_From_Source (Prim) 21339 and then not Is_Abstract_Subprogram (Prim) 21340 then 21341 Wrap_Spec := 21342 Make_Subprogram_Declaration (Sloc (Prim), 21343 Specification => 21344 Build_Wrapper_Spec 21345 (Subp_Id => Prim, 21346 Obj_Typ => Conc_Typ, 21347 Formals => 21348 Parameter_Specifications 21349 (Parent (Prim)))); 21350 21351 Insert_After (Curr_Nod, Wrap_Spec); 21352 Curr_Nod := Wrap_Spec; 21353 21354 Analyze (Wrap_Spec); 21355 21356 -- Remove the wrapper from visibility to avoid 21357 -- spurious conflict with the wrapped entity. 21358 21359 Set_Is_Immediately_Visible 21360 (Defining_Entity (Specification (Wrap_Spec)), 21361 False); 21362 end if; 21363 21364 Next_Elmt (Prim_Elmt); 21365 end loop; 21366 21367 goto Leave; 21368 end; 21369 21370 -- For nonconcurrent types, transfer explicit primitives, but 21371 -- omit those inherited from the parent of the private view 21372 -- since they will be re-inherited later on. 21373 21374 else 21375 Full_List := Primitive_Operations (Full_T); 21376 while Present (Prim_Elmt) loop 21377 Prim := Node (Prim_Elmt); 21378 21379 if Comes_From_Source (Prim) 21380 and then not Contains (Prim, Full_List) 21381 then 21382 Append_Elmt (Prim, Full_List); 21383 end if; 21384 21385 Next_Elmt (Prim_Elmt); 21386 end loop; 21387 end if; 21388 21389 -- Untagged private view 21390 21391 else 21392 Full_List := Primitive_Operations (Full_T); 21393 21394 -- In this case the partial view is untagged, so here we locate 21395 -- all of the earlier primitives that need to be treated as 21396 -- dispatching (those that appear between the two views). Note 21397 -- that these additional operations must all be new operations 21398 -- (any earlier operations that override inherited operations 21399 -- of the full view will already have been inserted in the 21400 -- primitives list, marked by Check_Operation_From_Private_View 21401 -- as dispatching. Note that implicit "/=" operators are 21402 -- excluded from being added to the primitives list since they 21403 -- shouldn't be treated as dispatching (tagged "/=" is handled 21404 -- specially). 21405 21406 Prim := Next_Entity (Full_T); 21407 while Present (Prim) and then Prim /= Priv_T loop 21408 if Ekind (Prim) in E_Procedure | E_Function then 21409 Disp_Typ := Find_Dispatching_Type (Prim); 21410 21411 if Disp_Typ = Full_T 21412 and then (Chars (Prim) /= Name_Op_Ne 21413 or else Comes_From_Source (Prim)) 21414 then 21415 Check_Controlling_Formals (Full_T, Prim); 21416 21417 if Is_Suitable_Primitive (Prim) 21418 and then not Is_Dispatching_Operation (Prim) 21419 then 21420 Append_Elmt (Prim, Full_List); 21421 Set_Is_Dispatching_Operation (Prim); 21422 Set_DT_Position_Value (Prim, No_Uint); 21423 end if; 21424 21425 elsif Is_Dispatching_Operation (Prim) 21426 and then Disp_Typ /= Full_T 21427 then 21428 -- Verify that it is not otherwise controlled by a 21429 -- formal or a return value of type T. 21430 21431 Check_Controlling_Formals (Disp_Typ, Prim); 21432 end if; 21433 end if; 21434 21435 Next_Entity (Prim); 21436 end loop; 21437 end if; 21438 21439 -- For the tagged case, the two views can share the same primitive 21440 -- operations list and the same class-wide type. Update attributes 21441 -- of the class-wide type which depend on the full declaration. 21442 21443 if Is_Tagged_Type (Priv_T) then 21444 Set_Direct_Primitive_Operations (Priv_T, Full_List); 21445 Set_Class_Wide_Type 21446 (Base_Type (Full_T), Class_Wide_Type (Priv_T)); 21447 21448 Propagate_Concurrent_Flags (Class_Wide_Type (Priv_T), Full_T); 21449 end if; 21450 21451 -- For untagged types, copy the primitives across from the private 21452 -- view to the full view, for support of prefixed calls when 21453 -- extensions are enabled, and better error messages otherwise. 21454 21455 else 21456 Priv_List := Primitive_Operations (Priv_T); 21457 Prim_Elmt := First_Elmt (Priv_List); 21458 21459 Full_List := Primitive_Operations (Full_T); 21460 while Present (Prim_Elmt) loop 21461 Prim := Node (Prim_Elmt); 21462 Append_Elmt (Prim, Full_List); 21463 Next_Elmt (Prim_Elmt); 21464 end loop; 21465 end if; 21466 end; 21467 21468 -- Ada 2005 AI 161: Check preelaborable initialization consistency 21469 21470 if Known_To_Have_Preelab_Init (Priv_T) then 21471 21472 -- Case where there is a pragma Preelaborable_Initialization. We 21473 -- always allow this in predefined units, which is cheating a bit, 21474 -- but it means we don't have to struggle to meet the requirements in 21475 -- the RM for having Preelaborable Initialization. Otherwise we 21476 -- require that the type meets the RM rules. But we can't check that 21477 -- yet, because of the rule about overriding Initialize, so we simply 21478 -- set a flag that will be checked at freeze time. 21479 21480 if not In_Predefined_Unit (Full_T) then 21481 Set_Must_Have_Preelab_Init (Full_T); 21482 end if; 21483 end if; 21484 21485 -- If pragma CPP_Class was applied to the private type declaration, 21486 -- propagate it now to the full type declaration. 21487 21488 if Is_CPP_Class (Priv_T) then 21489 Set_Is_CPP_Class (Full_T); 21490 Set_Convention (Full_T, Convention_CPP); 21491 21492 -- Check that components of imported CPP types do not have default 21493 -- expressions. 21494 21495 Check_CPP_Type_Has_No_Defaults (Full_T); 21496 end if; 21497 21498 -- If the private view has user specified stream attributes, then so has 21499 -- the full view. 21500 21501 -- Why the test, how could these flags be already set in Full_T ??? 21502 21503 if Has_Specified_Stream_Read (Priv_T) then 21504 Set_Has_Specified_Stream_Read (Full_T); 21505 end if; 21506 21507 if Has_Specified_Stream_Write (Priv_T) then 21508 Set_Has_Specified_Stream_Write (Full_T); 21509 end if; 21510 21511 if Has_Specified_Stream_Input (Priv_T) then 21512 Set_Has_Specified_Stream_Input (Full_T); 21513 end if; 21514 21515 if Has_Specified_Stream_Output (Priv_T) then 21516 Set_Has_Specified_Stream_Output (Full_T); 21517 end if; 21518 21519 -- Propagate Default_Initial_Condition-related attributes from the 21520 -- partial view to the full view. 21521 21522 Propagate_DIC_Attributes (Full_T, From_Typ => Priv_T); 21523 21524 -- And to the underlying full view, if any 21525 21526 if Is_Private_Type (Full_T) 21527 and then Present (Underlying_Full_View (Full_T)) 21528 then 21529 Propagate_DIC_Attributes 21530 (Underlying_Full_View (Full_T), From_Typ => Priv_T); 21531 end if; 21532 21533 -- Propagate invariant-related attributes from the partial view to the 21534 -- full view. 21535 21536 Propagate_Invariant_Attributes (Full_T, From_Typ => Priv_T); 21537 21538 -- And to the underlying full view, if any 21539 21540 if Is_Private_Type (Full_T) 21541 and then Present (Underlying_Full_View (Full_T)) 21542 then 21543 Propagate_Invariant_Attributes 21544 (Underlying_Full_View (Full_T), From_Typ => Priv_T); 21545 end if; 21546 21547 -- AI12-0041: Detect an attempt to inherit a class-wide type invariant 21548 -- in the full view without advertising the inheritance in the partial 21549 -- view. This can only occur when the partial view has no parent type 21550 -- and the full view has an interface as a parent. Any other scenarios 21551 -- are illegal because implemented interfaces must match between the 21552 -- two views. 21553 21554 if Is_Tagged_Type (Priv_T) and then Is_Tagged_Type (Full_T) then 21555 declare 21556 Full_Par : constant Entity_Id := Etype (Full_T); 21557 Priv_Par : constant Entity_Id := Etype (Priv_T); 21558 21559 begin 21560 if not Is_Interface (Priv_Par) 21561 and then Is_Interface (Full_Par) 21562 and then Has_Inheritable_Invariants (Full_Par) 21563 then 21564 Error_Msg_N 21565 ("hidden inheritance of class-wide type invariants not " 21566 & "allowed", N); 21567 end if; 21568 end; 21569 end if; 21570 21571 -- Propagate predicates to full type, and predicate function if already 21572 -- defined. It is not clear that this can actually happen? the partial 21573 -- view cannot be frozen yet, and the predicate function has not been 21574 -- built. Still it is a cheap check and seems safer to make it. 21575 21576 Propagate_Predicate_Attributes (Full_T, Priv_T); 21577 21578 if Is_Private_Type (Full_T) 21579 and then Present (Underlying_Full_View (Full_T)) 21580 then 21581 Propagate_Predicate_Attributes 21582 (Underlying_Full_View (Full_T), Priv_T); 21583 end if; 21584 21585 <<Leave>> 21586 Restore_Ghost_Region (Saved_GM, Saved_IGR); 21587 end Process_Full_View; 21588 21589 ----------------------------------- 21590 -- Process_Incomplete_Dependents -- 21591 ----------------------------------- 21592 21593 procedure Process_Incomplete_Dependents 21594 (N : Node_Id; 21595 Full_T : Entity_Id; 21596 Inc_T : Entity_Id) 21597 is 21598 Inc_Elmt : Elmt_Id; 21599 Priv_Dep : Entity_Id; 21600 New_Subt : Entity_Id; 21601 21602 Disc_Constraint : Elist_Id; 21603 21604 begin 21605 if No (Private_Dependents (Inc_T)) then 21606 return; 21607 end if; 21608 21609 -- Itypes that may be generated by the completion of an incomplete 21610 -- subtype are not used by the back-end and not attached to the tree. 21611 -- They are created only for constraint-checking purposes. 21612 21613 Inc_Elmt := First_Elmt (Private_Dependents (Inc_T)); 21614 while Present (Inc_Elmt) loop 21615 Priv_Dep := Node (Inc_Elmt); 21616 21617 if Ekind (Priv_Dep) = E_Subprogram_Type then 21618 21619 -- An Access_To_Subprogram type may have a return type or a 21620 -- parameter type that is incomplete. Replace with the full view. 21621 21622 if Etype (Priv_Dep) = Inc_T then 21623 Set_Etype (Priv_Dep, Full_T); 21624 end if; 21625 21626 declare 21627 Formal : Entity_Id; 21628 21629 begin 21630 Formal := First_Formal (Priv_Dep); 21631 while Present (Formal) loop 21632 if Etype (Formal) = Inc_T then 21633 Set_Etype (Formal, Full_T); 21634 end if; 21635 21636 Next_Formal (Formal); 21637 end loop; 21638 end; 21639 21640 elsif Is_Overloadable (Priv_Dep) then 21641 21642 -- If a subprogram in the incomplete dependents list is primitive 21643 -- for a tagged full type then mark it as a dispatching operation, 21644 -- check whether it overrides an inherited subprogram, and check 21645 -- restrictions on its controlling formals. Note that a protected 21646 -- operation is never dispatching: only its wrapper operation 21647 -- (which has convention Ada) is. 21648 21649 if Is_Tagged_Type (Full_T) 21650 and then Is_Primitive (Priv_Dep) 21651 and then Convention (Priv_Dep) /= Convention_Protected 21652 then 21653 Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T); 21654 Set_Is_Dispatching_Operation (Priv_Dep); 21655 Check_Controlling_Formals (Full_T, Priv_Dep); 21656 end if; 21657 21658 elsif Ekind (Priv_Dep) = E_Subprogram_Body then 21659 21660 -- Can happen during processing of a body before the completion 21661 -- of a TA type. Ignore, because spec is also on dependent list. 21662 21663 return; 21664 21665 -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a 21666 -- corresponding subtype of the full view. 21667 21668 elsif Ekind (Priv_Dep) = E_Incomplete_Subtype 21669 and then Comes_From_Source (Priv_Dep) 21670 then 21671 Set_Subtype_Indication 21672 (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep))); 21673 Reinit_Field_To_Zero 21674 (Priv_Dep, F_Private_Dependents, 21675 Old_Ekind => E_Incomplete_Subtype); 21676 Mutate_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); 21677 Set_Etype (Priv_Dep, Full_T); 21678 Set_Analyzed (Parent (Priv_Dep), False); 21679 21680 -- Reanalyze the declaration, suppressing the call to Enter_Name 21681 -- to avoid duplicate names. 21682 21683 Analyze_Subtype_Declaration 21684 (N => Parent (Priv_Dep), 21685 Skip => True); 21686 21687 -- Dependent is a subtype 21688 21689 else 21690 -- We build a new subtype indication using the full view of the 21691 -- incomplete parent. The discriminant constraints have been 21692 -- elaborated already at the point of the subtype declaration. 21693 21694 New_Subt := Create_Itype (E_Void, N); 21695 21696 if Has_Discriminants (Full_T) then 21697 Disc_Constraint := Discriminant_Constraint (Priv_Dep); 21698 else 21699 Disc_Constraint := No_Elist; 21700 end if; 21701 21702 Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N); 21703 Set_Full_View (Priv_Dep, New_Subt); 21704 end if; 21705 21706 Next_Elmt (Inc_Elmt); 21707 end loop; 21708 end Process_Incomplete_Dependents; 21709 21710 -------------------------------- 21711 -- Process_Range_Expr_In_Decl -- 21712 -------------------------------- 21713 21714 procedure Process_Range_Expr_In_Decl 21715 (R : Node_Id; 21716 T : Entity_Id; 21717 Subtyp : Entity_Id := Empty; 21718 Check_List : List_Id := No_List) 21719 is 21720 Lo, Hi : Node_Id; 21721 R_Checks : Check_Result; 21722 Insert_Node : Node_Id; 21723 Def_Id : Entity_Id; 21724 21725 begin 21726 Analyze_And_Resolve (R, Base_Type (T)); 21727 21728 if Nkind (R) = N_Range then 21729 Lo := Low_Bound (R); 21730 Hi := High_Bound (R); 21731 21732 -- Validity checks on the range of a quantified expression are 21733 -- delayed until the construct is transformed into a loop. 21734 21735 if Nkind (Parent (R)) = N_Loop_Parameter_Specification 21736 and then Nkind (Parent (Parent (R))) = N_Quantified_Expression 21737 then 21738 null; 21739 21740 -- We need to ensure validity of the bounds here, because if we 21741 -- go ahead and do the expansion, then the expanded code will get 21742 -- analyzed with range checks suppressed and we miss the check. 21743 21744 -- WARNING: The capture of the range bounds with xxx_FIRST/_LAST and 21745 -- the temporaries generated by routine Remove_Side_Effects by means 21746 -- of validity checks must use the same names. When a range appears 21747 -- in the parent of a generic, the range is processed with checks 21748 -- disabled as part of the generic context and with checks enabled 21749 -- for code generation purposes. This leads to link issues as the 21750 -- generic contains references to xxx_FIRST/_LAST, but the inlined 21751 -- template sees the temporaries generated by Remove_Side_Effects. 21752 21753 else 21754 Validity_Check_Range (R, Subtyp); 21755 end if; 21756 21757 -- If there were errors in the declaration, try and patch up some 21758 -- common mistakes in the bounds. The cases handled are literals 21759 -- which are Integer where the expected type is Real and vice versa. 21760 -- These corrections allow the compilation process to proceed further 21761 -- along since some basic assumptions of the format of the bounds 21762 -- are guaranteed. 21763 21764 if Etype (R) = Any_Type then 21765 if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then 21766 Rewrite (Lo, 21767 Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo)))); 21768 21769 elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then 21770 Rewrite (Hi, 21771 Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi)))); 21772 21773 elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then 21774 Rewrite (Lo, 21775 Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo)))); 21776 21777 elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then 21778 Rewrite (Hi, 21779 Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi)))); 21780 end if; 21781 21782 Set_Etype (Lo, T); 21783 Set_Etype (Hi, T); 21784 end if; 21785 21786 -- If the bounds of the range have been mistakenly given as string 21787 -- literals (perhaps in place of character literals), then an error 21788 -- has already been reported, but we rewrite the string literal as a 21789 -- bound of the range's type to avoid blowups in later processing 21790 -- that looks at static values. 21791 21792 if Nkind (Lo) = N_String_Literal then 21793 Rewrite (Lo, 21794 Make_Attribute_Reference (Sloc (Lo), 21795 Prefix => New_Occurrence_Of (T, Sloc (Lo)), 21796 Attribute_Name => Name_First)); 21797 Analyze_And_Resolve (Lo); 21798 end if; 21799 21800 if Nkind (Hi) = N_String_Literal then 21801 Rewrite (Hi, 21802 Make_Attribute_Reference (Sloc (Hi), 21803 Prefix => New_Occurrence_Of (T, Sloc (Hi)), 21804 Attribute_Name => Name_First)); 21805 Analyze_And_Resolve (Hi); 21806 end if; 21807 21808 -- If bounds aren't scalar at this point then exit, avoiding 21809 -- problems with further processing of the range in this procedure. 21810 21811 if not Is_Scalar_Type (Etype (Lo)) then 21812 return; 21813 end if; 21814 21815 -- Resolve (actually Sem_Eval) has checked that the bounds are in 21816 -- then range of the base type. Here we check whether the bounds 21817 -- are in the range of the subtype itself. Note that if the bounds 21818 -- represent the null range the Constraint_Error exception should 21819 -- not be raised. 21820 21821 -- Capture values of bounds and generate temporaries for them 21822 -- if needed, before applying checks, since checks may cause 21823 -- duplication of the expression without forcing evaluation. 21824 21825 -- The forced evaluation removes side effects from expressions, 21826 -- which should occur also in GNATprove mode. Otherwise, we end up 21827 -- with unexpected insertions of actions at places where this is 21828 -- not supposed to occur, e.g. on default parameters of a call. 21829 21830 if Expander_Active or GNATprove_Mode then 21831 21832 -- Call Force_Evaluation to create declarations as needed 21833 -- to deal with side effects, and also create typ_FIRST/LAST 21834 -- entities for bounds if we have a subtype name. 21835 21836 -- Note: we do this transformation even if expansion is not 21837 -- active if we are in GNATprove_Mode since the transformation 21838 -- is in general required to ensure that the resulting tree has 21839 -- proper Ada semantics. 21840 21841 Force_Evaluation 21842 (Lo, Related_Id => Subtyp, Is_Low_Bound => True); 21843 Force_Evaluation 21844 (Hi, Related_Id => Subtyp, Is_High_Bound => True); 21845 end if; 21846 21847 -- We use a flag here instead of suppressing checks on the type 21848 -- because the type we check against isn't necessarily the place 21849 -- where we put the check. 21850 21851 R_Checks := Get_Range_Checks (R, T); 21852 21853 -- Look up tree to find an appropriate insertion point. We can't 21854 -- just use insert_actions because later processing depends on 21855 -- the insertion node. Prior to Ada 2012 the insertion point could 21856 -- only be a declaration or a loop, but quantified expressions can 21857 -- appear within any context in an expression, and the insertion 21858 -- point can be any statement, pragma, or declaration. 21859 21860 Insert_Node := Parent (R); 21861 while Present (Insert_Node) loop 21862 exit when 21863 Nkind (Insert_Node) in N_Declaration 21864 and then 21865 Nkind (Insert_Node) not in N_Component_Declaration 21866 | N_Loop_Parameter_Specification 21867 | N_Function_Specification 21868 | N_Procedure_Specification; 21869 21870 exit when Nkind (Insert_Node) in 21871 N_Later_Decl_Item | 21872 N_Statement_Other_Than_Procedure_Call | 21873 N_Procedure_Call_Statement | 21874 N_Pragma; 21875 21876 Insert_Node := Parent (Insert_Node); 21877 end loop; 21878 21879 if Present (Insert_Node) then 21880 21881 -- Case of loop statement. Verify that the range is part of the 21882 -- subtype indication of the iteration scheme. 21883 21884 if Nkind (Insert_Node) = N_Loop_Statement then 21885 declare 21886 Indic : Node_Id; 21887 21888 begin 21889 Indic := Parent (R); 21890 while Present (Indic) 21891 and then Nkind (Indic) /= N_Subtype_Indication 21892 loop 21893 Indic := Parent (Indic); 21894 end loop; 21895 21896 if Present (Indic) then 21897 Def_Id := Etype (Subtype_Mark (Indic)); 21898 21899 Insert_Range_Checks 21900 (R_Checks, 21901 Insert_Node, 21902 Def_Id, 21903 Sloc (Insert_Node), 21904 Do_Before => True); 21905 end if; 21906 end; 21907 21908 -- Case of declarations. If the declaration is for a type and 21909 -- involves discriminants, the checks are premature at the 21910 -- declaration point and need to wait for the expansion of the 21911 -- initialization procedure, which will pass in the list to put 21912 -- them on; otherwise, the checks are done at the declaration 21913 -- point and there is no need to do them again in the 21914 -- initialization procedure. 21915 21916 elsif Nkind (Insert_Node) in N_Declaration then 21917 Def_Id := Defining_Identifier (Insert_Node); 21918 21919 if (Ekind (Def_Id) = E_Record_Type 21920 and then Depends_On_Discriminant (R)) 21921 or else 21922 (Ekind (Def_Id) = E_Protected_Type 21923 and then Has_Discriminants (Def_Id)) 21924 then 21925 if Present (Check_List) then 21926 Append_Range_Checks 21927 (R_Checks, 21928 Check_List, Def_Id, Sloc (Insert_Node)); 21929 end if; 21930 21931 else 21932 if No (Check_List) then 21933 Insert_Range_Checks 21934 (R_Checks, 21935 Insert_Node, Def_Id, Sloc (Insert_Node)); 21936 end if; 21937 end if; 21938 21939 -- Case of statements. Drop the checks, as the range appears in 21940 -- the context of a quantified expression. Insertion will take 21941 -- place when expression is expanded. 21942 21943 else 21944 null; 21945 end if; 21946 end if; 21947 21948 -- Case of other than an explicit N_Range node 21949 21950 -- The forced evaluation removes side effects from expressions, which 21951 -- should occur also in GNATprove mode. Otherwise, we end up with 21952 -- unexpected insertions of actions at places where this is not 21953 -- supposed to occur, e.g. on default parameters of a call. 21954 21955 elsif Expander_Active or GNATprove_Mode then 21956 Get_Index_Bounds (R, Lo, Hi); 21957 Force_Evaluation (Lo); 21958 Force_Evaluation (Hi); 21959 end if; 21960 end Process_Range_Expr_In_Decl; 21961 21962 -------------------------------------- 21963 -- Process_Real_Range_Specification -- 21964 -------------------------------------- 21965 21966 procedure Process_Real_Range_Specification (Def : Node_Id) is 21967 Spec : constant Node_Id := Real_Range_Specification (Def); 21968 Lo : Node_Id; 21969 Hi : Node_Id; 21970 Err : Boolean := False; 21971 21972 procedure Analyze_Bound (N : Node_Id); 21973 -- Analyze and check one bound 21974 21975 ------------------- 21976 -- Analyze_Bound -- 21977 ------------------- 21978 21979 procedure Analyze_Bound (N : Node_Id) is 21980 begin 21981 Analyze_And_Resolve (N, Any_Real); 21982 21983 if not Is_OK_Static_Expression (N) then 21984 Flag_Non_Static_Expr 21985 ("bound in real type definition is not static!", N); 21986 Err := True; 21987 end if; 21988 end Analyze_Bound; 21989 21990 -- Start of processing for Process_Real_Range_Specification 21991 21992 begin 21993 if Present (Spec) then 21994 Lo := Low_Bound (Spec); 21995 Hi := High_Bound (Spec); 21996 Analyze_Bound (Lo); 21997 Analyze_Bound (Hi); 21998 21999 -- If error, clear away junk range specification 22000 22001 if Err then 22002 Set_Real_Range_Specification (Def, Empty); 22003 end if; 22004 end if; 22005 end Process_Real_Range_Specification; 22006 22007 --------------------- 22008 -- Process_Subtype -- 22009 --------------------- 22010 22011 function Process_Subtype 22012 (S : Node_Id; 22013 Related_Nod : Node_Id; 22014 Related_Id : Entity_Id := Empty; 22015 Suffix : Character := ' ') return Entity_Id 22016 is 22017 procedure Check_Incomplete (T : Node_Id); 22018 -- Called to verify that an incomplete type is not used prematurely 22019 22020 ---------------------- 22021 -- Check_Incomplete -- 22022 ---------------------- 22023 22024 procedure Check_Incomplete (T : Node_Id) is 22025 begin 22026 -- Ada 2005 (AI-412): Incomplete subtypes are legal 22027 22028 if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type 22029 and then 22030 not (Ada_Version >= Ada_2005 22031 and then 22032 (Nkind (Parent (T)) = N_Subtype_Declaration 22033 or else (Nkind (Parent (T)) = N_Subtype_Indication 22034 and then Nkind (Parent (Parent (T))) = 22035 N_Subtype_Declaration))) 22036 then 22037 Error_Msg_N ("invalid use of type before its full declaration", T); 22038 end if; 22039 end Check_Incomplete; 22040 22041 -- Local variables 22042 22043 P : Node_Id; 22044 Def_Id : Entity_Id; 22045 Error_Node : Node_Id; 22046 Full_View_Id : Entity_Id; 22047 Subtype_Mark_Id : Entity_Id; 22048 22049 May_Have_Null_Exclusion : Boolean; 22050 22051 -- Start of processing for Process_Subtype 22052 22053 begin 22054 -- Case of no constraints present 22055 22056 if Nkind (S) /= N_Subtype_Indication then 22057 Find_Type (S); 22058 22059 -- No way to proceed if the subtype indication is malformed. This 22060 -- will happen for example when the subtype indication in an object 22061 -- declaration is missing altogether and the expression is analyzed 22062 -- as if it were that indication. 22063 22064 if not Is_Entity_Name (S) then 22065 return Any_Type; 22066 end if; 22067 22068 Check_Incomplete (S); 22069 P := Parent (S); 22070 22071 -- The following mirroring of assertion in Null_Exclusion_Present is 22072 -- ugly, can't we have a range, a static predicate or even a flag??? 22073 22074 May_Have_Null_Exclusion := 22075 Present (P) 22076 and then 22077 Nkind (P) in N_Access_Definition 22078 | N_Access_Function_Definition 22079 | N_Access_Procedure_Definition 22080 | N_Access_To_Object_Definition 22081 | N_Allocator 22082 | N_Component_Definition 22083 | N_Derived_Type_Definition 22084 | N_Discriminant_Specification 22085 | N_Formal_Object_Declaration 22086 | N_Function_Specification 22087 | N_Object_Declaration 22088 | N_Object_Renaming_Declaration 22089 | N_Parameter_Specification 22090 | N_Subtype_Declaration; 22091 22092 -- Ada 2005 (AI-231): Static check 22093 22094 if Ada_Version >= Ada_2005 22095 and then May_Have_Null_Exclusion 22096 and then Null_Exclusion_Present (P) 22097 and then Nkind (P) /= N_Access_To_Object_Definition 22098 and then not Is_Access_Type (Entity (S)) 22099 then 22100 Error_Msg_N ("`NOT NULL` only allowed for an access type", S); 22101 end if; 22102 22103 -- Create an Itype that is a duplicate of Entity (S) but with the 22104 -- null-exclusion attribute. 22105 22106 if May_Have_Null_Exclusion 22107 and then Is_Access_Type (Entity (S)) 22108 and then Null_Exclusion_Present (P) 22109 22110 -- No need to check the case of an access to object definition. 22111 -- It is correct to define double not-null pointers. 22112 22113 -- Example: 22114 -- type Not_Null_Int_Ptr is not null access Integer; 22115 -- type Acc is not null access Not_Null_Int_Ptr; 22116 22117 and then Nkind (P) /= N_Access_To_Object_Definition 22118 then 22119 if Can_Never_Be_Null (Entity (S)) then 22120 case Nkind (Related_Nod) is 22121 when N_Full_Type_Declaration => 22122 if Nkind (Type_Definition (Related_Nod)) 22123 in N_Array_Type_Definition 22124 then 22125 Error_Node := 22126 Subtype_Indication 22127 (Component_Definition 22128 (Type_Definition (Related_Nod))); 22129 else 22130 Error_Node := 22131 Subtype_Indication (Type_Definition (Related_Nod)); 22132 end if; 22133 22134 when N_Subtype_Declaration => 22135 Error_Node := Subtype_Indication (Related_Nod); 22136 22137 when N_Object_Declaration => 22138 Error_Node := Object_Definition (Related_Nod); 22139 22140 when N_Component_Declaration => 22141 Error_Node := 22142 Subtype_Indication (Component_Definition (Related_Nod)); 22143 22144 when N_Allocator => 22145 Error_Node := Expression (Related_Nod); 22146 22147 when others => 22148 pragma Assert (False); 22149 Error_Node := Related_Nod; 22150 end case; 22151 22152 Error_Msg_NE 22153 ("`NOT NULL` not allowed (& already excludes null)", 22154 Error_Node, 22155 Entity (S)); 22156 end if; 22157 22158 Set_Etype (S, 22159 Create_Null_Excluding_Itype 22160 (T => Entity (S), 22161 Related_Nod => P)); 22162 Set_Entity (S, Etype (S)); 22163 end if; 22164 22165 return Entity (S); 22166 22167 -- Case of constraint present, so that we have an N_Subtype_Indication 22168 -- node (this node is created only if constraints are present). 22169 22170 else 22171 Find_Type (Subtype_Mark (S)); 22172 22173 if Nkind (Parent (S)) /= N_Access_To_Object_Definition 22174 and then not 22175 (Nkind (Parent (S)) = N_Subtype_Declaration 22176 and then Is_Itype (Defining_Identifier (Parent (S)))) 22177 then 22178 Check_Incomplete (Subtype_Mark (S)); 22179 end if; 22180 22181 P := Parent (S); 22182 Subtype_Mark_Id := Entity (Subtype_Mark (S)); 22183 22184 -- Explicit subtype declaration case 22185 22186 if Nkind (P) = N_Subtype_Declaration then 22187 Def_Id := Defining_Identifier (P); 22188 22189 -- Explicit derived type definition case 22190 22191 elsif Nkind (P) = N_Derived_Type_Definition then 22192 Def_Id := Defining_Identifier (Parent (P)); 22193 22194 -- Implicit case, the Def_Id must be created as an implicit type. 22195 -- The one exception arises in the case of concurrent types, array 22196 -- and access types, where other subsidiary implicit types may be 22197 -- created and must appear before the main implicit type. In these 22198 -- cases we leave Def_Id set to Empty as a signal that Create_Itype 22199 -- has not yet been called to create Def_Id. 22200 22201 else 22202 if Is_Array_Type (Subtype_Mark_Id) 22203 or else Is_Concurrent_Type (Subtype_Mark_Id) 22204 or else Is_Access_Type (Subtype_Mark_Id) 22205 then 22206 Def_Id := Empty; 22207 22208 -- For the other cases, we create a new unattached Itype, 22209 -- and set the indication to ensure it gets attached later. 22210 22211 else 22212 Def_Id := 22213 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 22214 end if; 22215 end if; 22216 22217 -- If the kind of constraint is invalid for this kind of type, 22218 -- then give an error, and then pretend no constraint was given. 22219 22220 if not Is_Valid_Constraint_Kind 22221 (Ekind (Subtype_Mark_Id), Nkind (Constraint (S))) 22222 then 22223 Error_Msg_N 22224 ("incorrect constraint for this kind of type", Constraint (S)); 22225 22226 Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); 22227 22228 -- Set Ekind of orphan itype, to prevent cascaded errors 22229 22230 if Present (Def_Id) then 22231 Mutate_Ekind (Def_Id, Ekind (Any_Type)); 22232 end if; 22233 22234 -- Make recursive call, having got rid of the bogus constraint 22235 22236 return Process_Subtype (S, Related_Nod, Related_Id, Suffix); 22237 end if; 22238 22239 -- Remaining processing depends on type. Select on Base_Type kind to 22240 -- ensure getting to the concrete type kind in the case of a private 22241 -- subtype (needed when only doing semantic analysis). 22242 22243 case Ekind (Base_Type (Subtype_Mark_Id)) is 22244 when Access_Kind => 22245 22246 -- If this is a constraint on a class-wide type, discard it. 22247 -- There is currently no way to express a partial discriminant 22248 -- constraint on a type with unknown discriminants. This is 22249 -- a pathology that the ACATS wisely decides not to test. 22250 22251 if Is_Class_Wide_Type (Designated_Type (Subtype_Mark_Id)) then 22252 if Comes_From_Source (S) then 22253 Error_Msg_N 22254 ("constraint on class-wide type ignored??", 22255 Constraint (S)); 22256 end if; 22257 22258 if Nkind (P) = N_Subtype_Declaration then 22259 Set_Subtype_Indication (P, 22260 New_Occurrence_Of (Subtype_Mark_Id, Sloc (S))); 22261 end if; 22262 22263 return Subtype_Mark_Id; 22264 end if; 22265 22266 Constrain_Access (Def_Id, S, Related_Nod); 22267 22268 if Expander_Active 22269 and then Is_Itype (Designated_Type (Def_Id)) 22270 and then Nkind (Related_Nod) = N_Subtype_Declaration 22271 and then not Is_Incomplete_Type (Designated_Type (Def_Id)) 22272 then 22273 Build_Itype_Reference 22274 (Designated_Type (Def_Id), Related_Nod); 22275 end if; 22276 22277 when Array_Kind => 22278 Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); 22279 22280 when Decimal_Fixed_Point_Kind => 22281 Constrain_Decimal (Def_Id, S); 22282 22283 when Enumeration_Kind => 22284 Constrain_Enumeration (Def_Id, S); 22285 22286 when Ordinary_Fixed_Point_Kind => 22287 Constrain_Ordinary_Fixed (Def_Id, S); 22288 22289 when Float_Kind => 22290 Constrain_Float (Def_Id, S); 22291 22292 when Integer_Kind => 22293 Constrain_Integer (Def_Id, S); 22294 22295 when Class_Wide_Kind 22296 | E_Incomplete_Type 22297 | E_Record_Subtype 22298 | E_Record_Type 22299 => 22300 Constrain_Discriminated_Type (Def_Id, S, Related_Nod); 22301 22302 if Ekind (Def_Id) = E_Incomplete_Type then 22303 Set_Private_Dependents (Def_Id, New_Elmt_List); 22304 end if; 22305 22306 when Private_Kind => 22307 22308 -- A private type with unknown discriminants may be completed 22309 -- by an unconstrained array type. 22310 22311 if Has_Unknown_Discriminants (Subtype_Mark_Id) 22312 and then Present (Full_View (Subtype_Mark_Id)) 22313 and then Is_Array_Type (Full_View (Subtype_Mark_Id)) 22314 then 22315 Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); 22316 22317 -- ... but more commonly is completed by a discriminated record 22318 -- type. 22319 22320 else 22321 Constrain_Discriminated_Type (Def_Id, S, Related_Nod); 22322 end if; 22323 22324 -- The base type may be private but Def_Id may be a full view 22325 -- in an instance. 22326 22327 if Is_Private_Type (Def_Id) then 22328 Set_Private_Dependents (Def_Id, New_Elmt_List); 22329 end if; 22330 22331 -- In case of an invalid constraint prevent further processing 22332 -- since the type constructed is missing expected fields. 22333 22334 if Etype (Def_Id) = Any_Type then 22335 return Def_Id; 22336 end if; 22337 22338 -- If the full view is that of a task with discriminants, 22339 -- we must constrain both the concurrent type and its 22340 -- corresponding record type. Otherwise we will just propagate 22341 -- the constraint to the full view, if available. 22342 22343 if Present (Full_View (Subtype_Mark_Id)) 22344 and then Has_Discriminants (Subtype_Mark_Id) 22345 and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id)) 22346 then 22347 Full_View_Id := 22348 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 22349 22350 Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id)); 22351 Constrain_Concurrent (Full_View_Id, S, 22352 Related_Nod, Related_Id, Suffix); 22353 Set_Entity (Subtype_Mark (S), Subtype_Mark_Id); 22354 Set_Full_View (Def_Id, Full_View_Id); 22355 22356 -- Introduce an explicit reference to the private subtype, 22357 -- to prevent scope anomalies in gigi if first use appears 22358 -- in a nested context, e.g. a later function body. 22359 -- Should this be generated in other contexts than a full 22360 -- type declaration? 22361 22362 if Is_Itype (Def_Id) 22363 and then 22364 Nkind (Parent (P)) = N_Full_Type_Declaration 22365 then 22366 Build_Itype_Reference (Def_Id, Parent (P)); 22367 end if; 22368 22369 else 22370 Prepare_Private_Subtype_Completion (Def_Id, Related_Nod); 22371 end if; 22372 22373 when Concurrent_Kind => 22374 Constrain_Concurrent (Def_Id, S, 22375 Related_Nod, Related_Id, Suffix); 22376 22377 when others => 22378 Error_Msg_N ("invalid subtype mark in subtype indication", S); 22379 end case; 22380 22381 -- Size, Alignment, Representation aspects and Convention are always 22382 -- inherited from the base type. 22383 22384 Set_Size_Info (Def_Id, (Subtype_Mark_Id)); 22385 Set_Rep_Info (Def_Id, (Subtype_Mark_Id)); 22386 Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); 22387 22388 -- The anonymous subtype created for the subtype indication 22389 -- inherits the predicates of the parent. 22390 22391 if Has_Predicates (Subtype_Mark_Id) then 22392 Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); 22393 22394 -- Indicate where the predicate function may be found 22395 22396 if No (Predicate_Function (Def_Id)) and then Is_Itype (Def_Id) then 22397 Set_Predicated_Parent (Def_Id, Subtype_Mark_Id); 22398 end if; 22399 end if; 22400 22401 return Def_Id; 22402 end if; 22403 end Process_Subtype; 22404 22405 ----------------------------- 22406 -- Record_Type_Declaration -- 22407 ----------------------------- 22408 22409 procedure Record_Type_Declaration 22410 (T : Entity_Id; 22411 N : Node_Id; 22412 Prev : Entity_Id) 22413 is 22414 Def : constant Node_Id := Type_Definition (N); 22415 Is_Tagged : Boolean; 22416 Tag_Comp : Entity_Id; 22417 22418 begin 22419 -- These flags must be initialized before calling Process_Discriminants 22420 -- because this routine makes use of them. 22421 22422 Mutate_Ekind (T, E_Record_Type); 22423 Set_Etype (T, T); 22424 Reinit_Size_Align (T); 22425 Set_Interfaces (T, No_Elist); 22426 Set_Stored_Constraint (T, No_Elist); 22427 Set_Default_SSO (T); 22428 Set_No_Reordering (T, No_Component_Reordering); 22429 22430 -- Normal case 22431 22432 if Ada_Version < Ada_2005 or else not Interface_Present (Def) then 22433 -- The flag Is_Tagged_Type might have already been set by 22434 -- Find_Type_Name if it detected an error for declaration T. This 22435 -- arises in the case of private tagged types where the full view 22436 -- omits the word tagged. 22437 22438 Is_Tagged := 22439 Tagged_Present (Def) 22440 or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T)); 22441 22442 Set_Is_Limited_Record (T, Limited_Present (Def)); 22443 22444 if Is_Tagged then 22445 Set_Is_Tagged_Type (T, True); 22446 Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); 22447 end if; 22448 22449 -- Type is abstract if full declaration carries keyword, or if 22450 -- previous partial view did. 22451 22452 Set_Is_Abstract_Type (T, Is_Abstract_Type (T) 22453 or else Abstract_Present (Def)); 22454 22455 else 22456 Is_Tagged := True; 22457 Analyze_Interface_Declaration (T, Def); 22458 22459 if Present (Discriminant_Specifications (N)) then 22460 Error_Msg_N 22461 ("interface types cannot have discriminants", 22462 Defining_Identifier 22463 (First (Discriminant_Specifications (N)))); 22464 end if; 22465 end if; 22466 22467 -- First pass: if there are self-referential access components, 22468 -- create the required anonymous access type declarations, and if 22469 -- need be an incomplete type declaration for T itself. 22470 22471 Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def)); 22472 22473 if Ada_Version >= Ada_2005 22474 and then Present (Interface_List (Def)) 22475 then 22476 Check_Interfaces (N, Def); 22477 22478 declare 22479 Ifaces_List : Elist_Id; 22480 22481 begin 22482 -- Ada 2005 (AI-251): Collect the list of progenitors that are not 22483 -- already in the parents. 22484 22485 Collect_Interfaces 22486 (T => T, 22487 Ifaces_List => Ifaces_List, 22488 Exclude_Parents => True); 22489 22490 Set_Interfaces (T, Ifaces_List); 22491 end; 22492 end if; 22493 22494 -- Records constitute a scope for the component declarations within. 22495 -- The scope is created prior to the processing of these declarations. 22496 -- Discriminants are processed first, so that they are visible when 22497 -- processing the other components. The Ekind of the record type itself 22498 -- is set to E_Record_Type (subtypes appear as E_Record_Subtype). 22499 22500 -- Enter record scope 22501 22502 Push_Scope (T); 22503 22504 -- If an incomplete or private type declaration was already given for 22505 -- the type, then this scope already exists, and the discriminants have 22506 -- been declared within. We must verify that the full declaration 22507 -- matches the incomplete one. 22508 22509 Check_Or_Process_Discriminants (N, T, Prev); 22510 22511 Set_Is_Constrained (T, not Has_Discriminants (T)); 22512 Set_Has_Delayed_Freeze (T, True); 22513 22514 -- For tagged types add a manually analyzed component corresponding 22515 -- to the component _tag, the corresponding piece of tree will be 22516 -- expanded as part of the freezing actions if it is not a CPP_Class. 22517 22518 if Is_Tagged then 22519 22520 -- Do not add the tag unless we are in expansion mode 22521 22522 if Expander_Active then 22523 Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag); 22524 Enter_Name (Tag_Comp); 22525 22526 Mutate_Ekind (Tag_Comp, E_Component); 22527 Set_Is_Tag (Tag_Comp); 22528 Set_Is_Aliased (Tag_Comp); 22529 Set_Is_Independent (Tag_Comp); 22530 Set_Etype (Tag_Comp, RTE (RE_Tag)); 22531 Set_DT_Entry_Count (Tag_Comp, No_Uint); 22532 Set_Original_Record_Component (Tag_Comp, Tag_Comp); 22533 Reinit_Component_Location (Tag_Comp); 22534 22535 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the 22536 -- implemented interfaces. 22537 22538 if Has_Interfaces (T) then 22539 Add_Interface_Tag_Components (N, T); 22540 end if; 22541 end if; 22542 22543 Make_Class_Wide_Type (T); 22544 Set_Direct_Primitive_Operations (T, New_Elmt_List); 22545 end if; 22546 22547 -- We must suppress range checks when processing record components in 22548 -- the presence of discriminants, since we don't want spurious checks to 22549 -- be generated during their analysis, but Suppress_Range_Checks flags 22550 -- must be reset the after processing the record definition. 22551 22552 -- Note: this is the only use of Kill_Range_Checks, and is a bit odd, 22553 -- couldn't we just use the normal range check suppression method here. 22554 -- That would seem cleaner ??? 22555 22556 if Has_Discriminants (T) and then not Range_Checks_Suppressed (T) then 22557 Set_Kill_Range_Checks (T, True); 22558 Record_Type_Definition (Def, Prev); 22559 Set_Kill_Range_Checks (T, False); 22560 else 22561 Record_Type_Definition (Def, Prev); 22562 end if; 22563 22564 -- Exit from record scope 22565 22566 End_Scope; 22567 22568 -- Ada 2005 (AI-251 and AI-345): Derive the interface subprograms of all 22569 -- the implemented interfaces and associate them an aliased entity. 22570 22571 if Is_Tagged 22572 and then not Is_Empty_List (Interface_List (Def)) 22573 then 22574 Derive_Progenitor_Subprograms (T, T); 22575 end if; 22576 22577 Check_Function_Writable_Actuals (N); 22578 end Record_Type_Declaration; 22579 22580 ---------------------------- 22581 -- Record_Type_Definition -- 22582 ---------------------------- 22583 22584 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is 22585 Component : Entity_Id; 22586 Ctrl_Components : Boolean := False; 22587 Final_Storage_Only : Boolean; 22588 T : Entity_Id; 22589 22590 begin 22591 if Ekind (Prev_T) = E_Incomplete_Type then 22592 T := Full_View (Prev_T); 22593 else 22594 T := Prev_T; 22595 end if; 22596 22597 Final_Storage_Only := not Is_Controlled (T); 22598 22599 -- Ada 2005: Check whether an explicit "limited" is present in a derived 22600 -- type declaration. 22601 22602 if Parent_Kind (Def) = N_Derived_Type_Definition 22603 and then Limited_Present (Parent (Def)) 22604 then 22605 Set_Is_Limited_Record (T); 22606 end if; 22607 22608 -- If the component list of a record type is defined by the reserved 22609 -- word null and there is no discriminant part, then the record type has 22610 -- no components and all records of the type are null records (RM 3.7) 22611 -- This procedure is also called to process the extension part of a 22612 -- record extension, in which case the current scope may have inherited 22613 -- components. 22614 22615 if Present (Def) 22616 and then Present (Component_List (Def)) 22617 and then not Null_Present (Component_List (Def)) 22618 then 22619 Analyze_Declarations (Component_Items (Component_List (Def))); 22620 22621 if Present (Variant_Part (Component_List (Def))) then 22622 Analyze (Variant_Part (Component_List (Def))); 22623 end if; 22624 end if; 22625 22626 -- After completing the semantic analysis of the record definition, 22627 -- record components, both new and inherited, are accessible. Set their 22628 -- kind accordingly. Exclude malformed itypes from illegal declarations, 22629 -- whose Ekind may be void. 22630 22631 Component := First_Entity (Current_Scope); 22632 while Present (Component) loop 22633 if Ekind (Component) = E_Void 22634 and then not Is_Itype (Component) 22635 then 22636 Mutate_Ekind (Component, E_Component); 22637 Reinit_Component_Location (Component); 22638 end if; 22639 22640 Propagate_Concurrent_Flags (T, Etype (Component)); 22641 22642 if Ekind (Component) /= E_Component then 22643 null; 22644 22645 -- Do not set Has_Controlled_Component on a class-wide equivalent 22646 -- type. See Make_CW_Equivalent_Type. 22647 22648 elsif not Is_Class_Wide_Equivalent_Type (T) 22649 and then (Has_Controlled_Component (Etype (Component)) 22650 or else (Chars (Component) /= Name_uParent 22651 and then Is_Controlled (Etype (Component)))) 22652 then 22653 Set_Has_Controlled_Component (T, True); 22654 Final_Storage_Only := 22655 Final_Storage_Only 22656 and then Finalize_Storage_Only (Etype (Component)); 22657 Ctrl_Components := True; 22658 end if; 22659 22660 Next_Entity (Component); 22661 end loop; 22662 22663 -- A Type is Finalize_Storage_Only only if all its controlled components 22664 -- are also. 22665 22666 if Ctrl_Components then 22667 Set_Finalize_Storage_Only (T, Final_Storage_Only); 22668 end if; 22669 22670 -- Place reference to end record on the proper entity, which may 22671 -- be a partial view. 22672 22673 if Present (Def) then 22674 Process_End_Label (Def, 'e', Prev_T); 22675 end if; 22676 end Record_Type_Definition; 22677 22678 --------------------------- 22679 -- Replace_Discriminants -- 22680 --------------------------- 22681 22682 procedure Replace_Discriminants (Typ : Entity_Id; Decl : Node_Id) is 22683 function Process (N : Node_Id) return Traverse_Result; 22684 22685 ------------- 22686 -- Process -- 22687 ------------- 22688 22689 function Process (N : Node_Id) return Traverse_Result is 22690 Comp : Entity_Id; 22691 22692 begin 22693 if Nkind (N) = N_Discriminant_Specification then 22694 Comp := First_Discriminant (Typ); 22695 while Present (Comp) loop 22696 if Original_Record_Component (Comp) = Defining_Identifier (N) 22697 or else Chars (Comp) = Chars (Defining_Identifier (N)) 22698 then 22699 Set_Defining_Identifier (N, Comp); 22700 exit; 22701 end if; 22702 22703 Next_Discriminant (Comp); 22704 end loop; 22705 22706 elsif Nkind (N) = N_Variant_Part then 22707 Comp := First_Discriminant (Typ); 22708 while Present (Comp) loop 22709 if Original_Record_Component (Comp) = Entity (Name (N)) 22710 or else Chars (Comp) = Chars (Name (N)) 22711 then 22712 -- Make sure to preserve the type coming from the parent on 22713 -- the Name, even if the subtype of the discriminant can be 22714 -- constrained, so that discrete choices inherited from the 22715 -- parent in the variant part are not flagged as violating 22716 -- the constraints of the subtype. 22717 22718 declare 22719 Typ : constant Entity_Id := Etype (Name (N)); 22720 begin 22721 Rewrite (Name (N), New_Occurrence_Of (Comp, Sloc (N))); 22722 Set_Etype (Name (N), Typ); 22723 end; 22724 exit; 22725 end if; 22726 22727 Next_Discriminant (Comp); 22728 end loop; 22729 end if; 22730 22731 return OK; 22732 end Process; 22733 22734 procedure Replace is new Traverse_Proc (Process); 22735 22736 -- Start of processing for Replace_Discriminants 22737 22738 begin 22739 Replace (Decl); 22740 end Replace_Discriminants; 22741 22742 ------------------------------- 22743 -- Set_Completion_Referenced -- 22744 ------------------------------- 22745 22746 procedure Set_Completion_Referenced (E : Entity_Id) is 22747 begin 22748 -- If in main unit, mark entity that is a completion as referenced, 22749 -- warnings go on the partial view when needed. 22750 22751 if In_Extended_Main_Source_Unit (E) then 22752 Set_Referenced (E); 22753 end if; 22754 end Set_Completion_Referenced; 22755 22756 --------------------- 22757 -- Set_Default_SSO -- 22758 --------------------- 22759 22760 procedure Set_Default_SSO (T : Entity_Id) is 22761 begin 22762 case Opt.Default_SSO is 22763 when ' ' => 22764 null; 22765 when 'L' => 22766 Set_SSO_Set_Low_By_Default (T, True); 22767 when 'H' => 22768 Set_SSO_Set_High_By_Default (T, True); 22769 when others => 22770 raise Program_Error; 22771 end case; 22772 end Set_Default_SSO; 22773 22774 --------------------- 22775 -- Set_Fixed_Range -- 22776 --------------------- 22777 22778 -- The range for fixed-point types is complicated by the fact that we 22779 -- do not know the exact end points at the time of the declaration. This 22780 -- is true for three reasons: 22781 22782 -- A size clause may affect the fudging of the end-points. 22783 -- A small clause may affect the values of the end-points. 22784 -- We try to include the end-points if it does not affect the size. 22785 22786 -- This means that the actual end-points must be established at the 22787 -- point when the type is frozen. Meanwhile, we first narrow the range 22788 -- as permitted (so that it will fit if necessary in a small specified 22789 -- size), and then build a range subtree with these narrowed bounds. 22790 -- Set_Fixed_Range constructs the range from real literal values, and 22791 -- sets the range as the Scalar_Range of the given fixed-point type entity. 22792 22793 -- The parent of this range is set to point to the entity so that it is 22794 -- properly hooked into the tree (unlike normal Scalar_Range entries for 22795 -- other scalar types, which are just pointers to the range in the 22796 -- original tree, this would otherwise be an orphan). 22797 22798 -- The tree is left unanalyzed. When the type is frozen, the processing 22799 -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not 22800 -- analyzed, and uses this as an indication that it should complete 22801 -- work on the range (it will know the final small and size values). 22802 22803 procedure Set_Fixed_Range 22804 (E : Entity_Id; 22805 Loc : Source_Ptr; 22806 Lo : Ureal; 22807 Hi : Ureal) 22808 is 22809 S : constant Node_Id := 22810 Make_Range (Loc, 22811 Low_Bound => Make_Real_Literal (Loc, Lo), 22812 High_Bound => Make_Real_Literal (Loc, Hi)); 22813 begin 22814 Set_Scalar_Range (E, S); 22815 Set_Parent (S, E); 22816 22817 -- Before the freeze point, the bounds of a fixed point are universal 22818 -- and carry the corresponding type. 22819 22820 Set_Etype (Low_Bound (S), Universal_Real); 22821 Set_Etype (High_Bound (S), Universal_Real); 22822 end Set_Fixed_Range; 22823 22824 ---------------------------------- 22825 -- Set_Scalar_Range_For_Subtype -- 22826 ---------------------------------- 22827 22828 procedure Set_Scalar_Range_For_Subtype 22829 (Def_Id : Entity_Id; 22830 R : Node_Id; 22831 Subt : Entity_Id) 22832 is 22833 Kind : constant Entity_Kind := Ekind (Def_Id); 22834 22835 begin 22836 -- Defend against previous error 22837 22838 if Nkind (R) = N_Error then 22839 return; 22840 end if; 22841 22842 Set_Scalar_Range (Def_Id, R); 22843 22844 -- We need to link the range into the tree before resolving it so 22845 -- that types that are referenced, including importantly the subtype 22846 -- itself, are properly frozen (Freeze_Expression requires that the 22847 -- expression be properly linked into the tree). Of course if it is 22848 -- already linked in, then we do not disturb the current link. 22849 22850 if No (Parent (R)) then 22851 Set_Parent (R, Def_Id); 22852 end if; 22853 22854 -- Reset the kind of the subtype during analysis of the range, to 22855 -- catch possible premature use in the bounds themselves. 22856 22857 Mutate_Ekind (Def_Id, E_Void); 22858 Process_Range_Expr_In_Decl (R, Subt, Subtyp => Def_Id); 22859 Mutate_Ekind (Def_Id, Kind); 22860 end Set_Scalar_Range_For_Subtype; 22861 22862 -------------------------------------------------------- 22863 -- Set_Stored_Constraint_From_Discriminant_Constraint -- 22864 -------------------------------------------------------- 22865 22866 procedure Set_Stored_Constraint_From_Discriminant_Constraint 22867 (E : Entity_Id) 22868 is 22869 begin 22870 -- Make sure set if encountered during Expand_To_Stored_Constraint 22871 22872 Set_Stored_Constraint (E, No_Elist); 22873 22874 -- Give it the right value 22875 22876 if Is_Constrained (E) and then Has_Discriminants (E) then 22877 Set_Stored_Constraint (E, 22878 Expand_To_Stored_Constraint (E, Discriminant_Constraint (E))); 22879 end if; 22880 end Set_Stored_Constraint_From_Discriminant_Constraint; 22881 22882 ------------------------------------- 22883 -- Signed_Integer_Type_Declaration -- 22884 ------------------------------------- 22885 22886 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is 22887 Implicit_Base : Entity_Id; 22888 Base_Typ : Entity_Id; 22889 Lo_Val : Uint; 22890 Hi_Val : Uint; 22891 Errs : Boolean := False; 22892 Lo : Node_Id; 22893 Hi : Node_Id; 22894 22895 function Can_Derive_From (E : Entity_Id) return Boolean; 22896 -- Determine whether given bounds allow derivation from specified type 22897 22898 procedure Check_Bound (Expr : Node_Id); 22899 -- Check bound to make sure it is integral and static. If not, post 22900 -- appropriate error message and set Errs flag 22901 22902 --------------------- 22903 -- Can_Derive_From -- 22904 --------------------- 22905 22906 -- Note we check both bounds against both end values, to deal with 22907 -- strange types like ones with a range of 0 .. -12341234. 22908 22909 function Can_Derive_From (E : Entity_Id) return Boolean is 22910 Lo : constant Uint := Expr_Value (Type_Low_Bound (E)); 22911 Hi : constant Uint := Expr_Value (Type_High_Bound (E)); 22912 begin 22913 return Lo <= Lo_Val and then Lo_Val <= Hi 22914 and then 22915 Lo <= Hi_Val and then Hi_Val <= Hi; 22916 end Can_Derive_From; 22917 22918 ----------------- 22919 -- Check_Bound -- 22920 ----------------- 22921 22922 procedure Check_Bound (Expr : Node_Id) is 22923 begin 22924 -- If a range constraint is used as an integer type definition, each 22925 -- bound of the range must be defined by a static expression of some 22926 -- integer type, but the two bounds need not have the same integer 22927 -- type (Negative bounds are allowed.) (RM 3.5.4) 22928 22929 if not Is_Integer_Type (Etype (Expr)) then 22930 Error_Msg_N 22931 ("integer type definition bounds must be of integer type", Expr); 22932 Errs := True; 22933 22934 elsif not Is_OK_Static_Expression (Expr) then 22935 Flag_Non_Static_Expr 22936 ("non-static expression used for integer type bound!", Expr); 22937 Errs := True; 22938 22939 -- Otherwise the bounds are folded into literals 22940 22941 elsif Is_Entity_Name (Expr) then 22942 Fold_Uint (Expr, Expr_Value (Expr), True); 22943 end if; 22944 end Check_Bound; 22945 22946 -- Start of processing for Signed_Integer_Type_Declaration 22947 22948 begin 22949 -- Create an anonymous base type 22950 22951 Implicit_Base := 22952 Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B'); 22953 22954 -- Analyze and check the bounds, they can be of any integer type 22955 22956 Lo := Low_Bound (Def); 22957 Hi := High_Bound (Def); 22958 22959 -- Arbitrarily use Integer as the type if either bound had an error 22960 22961 if Hi = Error or else Lo = Error then 22962 Base_Typ := Any_Integer; 22963 Set_Error_Posted (T, True); 22964 Errs := True; 22965 22966 -- Here both bounds are OK expressions 22967 22968 else 22969 Analyze_And_Resolve (Lo, Any_Integer); 22970 Analyze_And_Resolve (Hi, Any_Integer); 22971 22972 Check_Bound (Lo); 22973 Check_Bound (Hi); 22974 22975 if Errs then 22976 Hi := Type_High_Bound (Standard_Long_Long_Long_Integer); 22977 Lo := Type_Low_Bound (Standard_Long_Long_Long_Integer); 22978 end if; 22979 22980 -- Find type to derive from 22981 22982 Lo_Val := Expr_Value (Lo); 22983 Hi_Val := Expr_Value (Hi); 22984 22985 if Can_Derive_From (Standard_Short_Short_Integer) then 22986 Base_Typ := Base_Type (Standard_Short_Short_Integer); 22987 22988 elsif Can_Derive_From (Standard_Short_Integer) then 22989 Base_Typ := Base_Type (Standard_Short_Integer); 22990 22991 elsif Can_Derive_From (Standard_Integer) then 22992 Base_Typ := Base_Type (Standard_Integer); 22993 22994 elsif Can_Derive_From (Standard_Long_Integer) then 22995 Base_Typ := Base_Type (Standard_Long_Integer); 22996 22997 elsif Can_Derive_From (Standard_Long_Long_Integer) then 22998 Check_Restriction (No_Long_Long_Integers, Def); 22999 Base_Typ := Base_Type (Standard_Long_Long_Integer); 23000 23001 elsif Can_Derive_From (Standard_Long_Long_Long_Integer) then 23002 Check_Restriction (No_Long_Long_Integers, Def); 23003 Base_Typ := Base_Type (Standard_Long_Long_Long_Integer); 23004 23005 else 23006 Base_Typ := Base_Type (Standard_Long_Long_Long_Integer); 23007 Error_Msg_N ("integer type definition bounds out of range", Def); 23008 Hi := Type_High_Bound (Standard_Long_Long_Long_Integer); 23009 Lo := Type_Low_Bound (Standard_Long_Long_Long_Integer); 23010 end if; 23011 end if; 23012 23013 -- Set the type of the bounds to the implicit base: we cannot set it to 23014 -- the new type, because this would be a forward reference for the code 23015 -- generator and, if the original type is user-defined, this could even 23016 -- lead to spurious semantic errors. Furthermore we do not set it to be 23017 -- universal, because this could make it much larger than needed here. 23018 23019 if not Errs then 23020 Set_Etype (Lo, Implicit_Base); 23021 Set_Etype (Hi, Implicit_Base); 23022 end if; 23023 23024 -- Complete both implicit base and declared first subtype entities. The 23025 -- inheritance of the rep item chain ensures that SPARK-related pragmas 23026 -- are not clobbered when the signed integer type acts as a full view of 23027 -- a private type. 23028 23029 Set_Etype (Implicit_Base, Base_Typ); 23030 Set_Size_Info (Implicit_Base, Base_Typ); 23031 Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); 23032 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); 23033 Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); 23034 23035 Mutate_Ekind (T, E_Signed_Integer_Subtype); 23036 Set_Etype (T, Implicit_Base); 23037 Set_Size_Info (T, Implicit_Base); 23038 Inherit_Rep_Item_Chain (T, Implicit_Base); 23039 Set_Scalar_Range (T, Def); 23040 Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); 23041 Set_Is_Constrained (T); 23042 end Signed_Integer_Type_Declaration; 23043 23044end Sem_Ch3; 23045