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-2013, 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 Debug; use Debug; 30with Elists; use Elists; 31with Einfo; use Einfo; 32with Errout; use Errout; 33with Eval_Fat; use Eval_Fat; 34with Exp_Ch3; use Exp_Ch3; 35with Exp_Ch9; use Exp_Ch9; 36with Exp_Disp; use Exp_Disp; 37with Exp_Dist; use Exp_Dist; 38with Exp_Tss; use Exp_Tss; 39with Exp_Util; use Exp_Util; 40with Fname; use Fname; 41with Freeze; use Freeze; 42with Itypes; use Itypes; 43with Layout; use Layout; 44with Lib; use Lib; 45with Lib.Xref; use Lib.Xref; 46with Namet; use Namet; 47with Nmake; use Nmake; 48with Opt; use Opt; 49with Restrict; use Restrict; 50with Rident; use Rident; 51with Rtsfind; use Rtsfind; 52with Sem; use Sem; 53with Sem_Aux; use Sem_Aux; 54with Sem_Case; use Sem_Case; 55with Sem_Cat; use Sem_Cat; 56with Sem_Ch6; use Sem_Ch6; 57with Sem_Ch7; use Sem_Ch7; 58with Sem_Ch8; use Sem_Ch8; 59with Sem_Ch13; use Sem_Ch13; 60with Sem_Dim; use Sem_Dim; 61with Sem_Disp; use Sem_Disp; 62with Sem_Dist; use Sem_Dist; 63with Sem_Elim; use Sem_Elim; 64with Sem_Eval; use Sem_Eval; 65with Sem_Mech; use Sem_Mech; 66with Sem_Prag; use Sem_Prag; 67with Sem_Res; use Sem_Res; 68with Sem_Smem; use Sem_Smem; 69with Sem_Type; use Sem_Type; 70with Sem_Util; use Sem_Util; 71with Sem_Warn; use Sem_Warn; 72with Stand; use Stand; 73with Sinfo; use Sinfo; 74with Sinput; use Sinput; 75with Snames; use Snames; 76with Targparm; use Targparm; 77with Tbuild; use Tbuild; 78with Ttypes; use Ttypes; 79with Uintp; use Uintp; 80with Urealp; use Urealp; 81 82package body Sem_Ch3 is 83 84 ----------------------- 85 -- Local Subprograms -- 86 ----------------------- 87 88 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id); 89 -- Ada 2005 (AI-251): Add the tag components corresponding to all the 90 -- abstract interface types implemented by a record type or a derived 91 -- record type. 92 93 procedure Build_Derived_Type 94 (N : Node_Id; 95 Parent_Type : Entity_Id; 96 Derived_Type : Entity_Id; 97 Is_Completion : Boolean; 98 Derive_Subps : Boolean := True); 99 -- Create and decorate a Derived_Type given the Parent_Type entity. N is 100 -- the N_Full_Type_Declaration node containing the derived type definition. 101 -- Parent_Type is the entity for the parent type in the derived type 102 -- definition and Derived_Type the actual derived type. Is_Completion must 103 -- be set to False if Derived_Type is the N_Defining_Identifier node in N 104 -- (i.e. Derived_Type = Defining_Identifier (N)). In this case N is not the 105 -- completion of a private type declaration. If Is_Completion is set to 106 -- True, N is the completion of a private type declaration and Derived_Type 107 -- is different from the defining identifier inside N (i.e. Derived_Type /= 108 -- Defining_Identifier (N)). Derive_Subps indicates whether the parent 109 -- subprograms should be derived. The only case where this parameter is 110 -- False is when Build_Derived_Type is recursively called to process an 111 -- implicit derived full type for a type derived from a private type (in 112 -- that case the subprograms must only be derived for the private view of 113 -- the type). 114 -- 115 -- ??? These flags need a bit of re-examination and re-documentation: 116 -- ??? are they both necessary (both seem related to the recursion)? 117 118 procedure Build_Derived_Access_Type 119 (N : Node_Id; 120 Parent_Type : Entity_Id; 121 Derived_Type : Entity_Id); 122 -- Subsidiary procedure to Build_Derived_Type. For a derived access type, 123 -- create an implicit base if the parent type is constrained or if the 124 -- subtype indication has a constraint. 125 126 procedure Build_Derived_Array_Type 127 (N : Node_Id; 128 Parent_Type : Entity_Id; 129 Derived_Type : Entity_Id); 130 -- Subsidiary procedure to Build_Derived_Type. For a derived array type, 131 -- create an implicit base if the parent type is constrained or if the 132 -- subtype indication has a constraint. 133 134 procedure Build_Derived_Concurrent_Type 135 (N : Node_Id; 136 Parent_Type : Entity_Id; 137 Derived_Type : Entity_Id); 138 -- Subsidiary procedure to Build_Derived_Type. For a derived task or 139 -- protected type, inherit entries and protected subprograms, check 140 -- legality of discriminant constraints if any. 141 142 procedure Build_Derived_Enumeration_Type 143 (N : Node_Id; 144 Parent_Type : Entity_Id; 145 Derived_Type : Entity_Id); 146 -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration 147 -- type, we must create a new list of literals. Types derived from 148 -- Character and [Wide_]Wide_Character are special-cased. 149 150 procedure Build_Derived_Numeric_Type 151 (N : Node_Id; 152 Parent_Type : Entity_Id; 153 Derived_Type : Entity_Id); 154 -- Subsidiary procedure to Build_Derived_Type. For numeric types, create 155 -- an anonymous base type, and propagate constraint to subtype if needed. 156 157 procedure Build_Derived_Private_Type 158 (N : Node_Id; 159 Parent_Type : Entity_Id; 160 Derived_Type : Entity_Id; 161 Is_Completion : Boolean; 162 Derive_Subps : Boolean := True); 163 -- Subsidiary procedure to Build_Derived_Type. This procedure is complex 164 -- because the parent may or may not have a completion, and the derivation 165 -- may itself be a completion. 166 167 procedure Build_Derived_Record_Type 168 (N : Node_Id; 169 Parent_Type : Entity_Id; 170 Derived_Type : Entity_Id; 171 Derive_Subps : Boolean := True); 172 -- Subsidiary procedure for Build_Derived_Type and 173 -- Analyze_Private_Extension_Declaration used for tagged and untagged 174 -- record types. All parameters are as in Build_Derived_Type except that 175 -- N, in addition to being an N_Full_Type_Declaration node, can also be an 176 -- N_Private_Extension_Declaration node. See the definition of this routine 177 -- for much more info. Derive_Subps indicates whether subprograms should 178 -- be derived from the parent type. The only case where Derive_Subps is 179 -- False is for an implicit derived full type for a type derived from a 180 -- private type (see Build_Derived_Type). 181 182 procedure Build_Discriminal (Discrim : Entity_Id); 183 -- Create the discriminal corresponding to discriminant Discrim, that is 184 -- the parameter corresponding to Discrim to be used in initialization 185 -- procedures for the type where Discrim is a discriminant. Discriminals 186 -- are not used during semantic analysis, and are not fully defined 187 -- entities until expansion. Thus they are not given a scope until 188 -- initialization procedures are built. 189 190 function Build_Discriminant_Constraints 191 (T : Entity_Id; 192 Def : Node_Id; 193 Derived_Def : Boolean := False) return Elist_Id; 194 -- Validate discriminant constraints and return the list of the constraints 195 -- in order of discriminant declarations, where T is the discriminated 196 -- unconstrained type. Def is the N_Subtype_Indication node where the 197 -- discriminants constraints for T are specified. Derived_Def is True 198 -- when building the discriminant constraints in a derived type definition 199 -- of the form "type D (...) is new T (xxx)". In this case T is the parent 200 -- type and Def is the constraint "(xxx)" on T and this routine sets the 201 -- Corresponding_Discriminant field of the discriminants in the derived 202 -- type D to point to the corresponding discriminants in the parent type T. 203 204 procedure Build_Discriminated_Subtype 205 (T : Entity_Id; 206 Def_Id : Entity_Id; 207 Elist : Elist_Id; 208 Related_Nod : Node_Id; 209 For_Access : Boolean := False); 210 -- Subsidiary procedure to Constrain_Discriminated_Type and to 211 -- Process_Incomplete_Dependents. Given 212 -- 213 -- T (a possibly discriminated base type) 214 -- Def_Id (a very partially built subtype for T), 215 -- 216 -- the call completes Def_Id to be the appropriate E_*_Subtype. 217 -- 218 -- The Elist is the list of discriminant constraints if any (it is set 219 -- to No_Elist if T is not a discriminated type, and to an empty list if 220 -- T has discriminants but there are no discriminant constraints). The 221 -- Related_Nod is the same as Decl_Node in Create_Constrained_Components. 222 -- The For_Access says whether or not this subtype is really constraining 223 -- an access type. That is its sole purpose is the designated type of an 224 -- access type -- in which case a Private_Subtype Is_For_Access_Subtype 225 -- is built to avoid freezing T when the access subtype is frozen. 226 227 function Build_Scalar_Bound 228 (Bound : Node_Id; 229 Par_T : Entity_Id; 230 Der_T : Entity_Id) return Node_Id; 231 -- The bounds of a derived scalar type are conversions of the bounds of 232 -- the parent type. Optimize the representation if the bounds are literals. 233 -- Needs a more complete spec--what are the parameters exactly, and what 234 -- exactly is the returned value, and how is Bound affected??? 235 236 procedure Build_Underlying_Full_View 237 (N : Node_Id; 238 Typ : Entity_Id; 239 Par : Entity_Id); 240 -- If the completion of a private type is itself derived from a private 241 -- type, or if the full view of a private subtype is itself private, the 242 -- back-end has no way to compute the actual size of this type. We build 243 -- an internal subtype declaration of the proper parent type to convey 244 -- this information. This extra mechanism is needed because a full 245 -- view cannot itself have a full view (it would get clobbered during 246 -- view exchanges). 247 248 procedure Check_Access_Discriminant_Requires_Limited 249 (D : Node_Id; 250 Loc : Node_Id); 251 -- Check the restriction that the type to which an access discriminant 252 -- belongs must be a concurrent type or a descendant of a type with 253 -- the reserved word 'limited' in its declaration. 254 255 procedure Check_Anonymous_Access_Components 256 (Typ_Decl : Node_Id; 257 Typ : Entity_Id; 258 Prev : Entity_Id; 259 Comp_List : Node_Id); 260 -- Ada 2005 AI-382: an access component in a record definition can refer to 261 -- the enclosing record, in which case it denotes the type itself, and not 262 -- the current instance of the type. We create an anonymous access type for 263 -- the component, and flag it as an access to a component, so accessibility 264 -- checks are properly performed on it. The declaration of the access type 265 -- is placed ahead of that of the record to prevent order-of-elaboration 266 -- circularity issues in Gigi. We create an incomplete type for the record 267 -- declaration, which is the designated type of the anonymous access. 268 269 procedure Check_Delta_Expression (E : Node_Id); 270 -- Check that the expression represented by E is suitable for use as a 271 -- delta expression, i.e. it is of real type and is static. 272 273 procedure Check_Digits_Expression (E : Node_Id); 274 -- Check that the expression represented by E is suitable for use as a 275 -- digits expression, i.e. it is of integer type, positive and static. 276 277 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id); 278 -- Validate the initialization of an object declaration. T is the required 279 -- type, and Exp is the initialization expression. 280 281 procedure Check_Interfaces (N : Node_Id; Def : Node_Id); 282 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) 283 284 procedure Check_Or_Process_Discriminants 285 (N : Node_Id; 286 T : Entity_Id; 287 Prev : Entity_Id := Empty); 288 -- If N is the full declaration of the completion T of an incomplete or 289 -- private type, check its discriminants (which are already known to be 290 -- conformant with those of the partial view, see Find_Type_Name), 291 -- otherwise process them. Prev is the entity of the partial declaration, 292 -- if any. 293 294 procedure Check_Real_Bound (Bound : Node_Id); 295 -- Check given bound for being of real type and static. If not, post an 296 -- appropriate message, and rewrite the bound with the real literal zero. 297 298 procedure Constant_Redeclaration 299 (Id : Entity_Id; 300 N : Node_Id; 301 T : out Entity_Id); 302 -- Various checks on legality of full declaration of deferred constant. 303 -- Id is the entity for the redeclaration, N is the N_Object_Declaration, 304 -- node. The caller has not yet set any attributes of this entity. 305 306 function Contain_Interface 307 (Iface : Entity_Id; 308 Ifaces : Elist_Id) return Boolean; 309 -- Ada 2005: Determine whether Iface is present in the list Ifaces 310 311 procedure Convert_Scalar_Bounds 312 (N : Node_Id; 313 Parent_Type : Entity_Id; 314 Derived_Type : Entity_Id; 315 Loc : Source_Ptr); 316 -- For derived scalar types, convert the bounds in the type definition to 317 -- the derived type, and complete their analysis. Given a constraint of the 318 -- form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with 319 -- T'Base, the parent_type. The bounds of the derived type (the anonymous 320 -- base) are copies of Lo and Hi. Finally, the bounds of the derived 321 -- subtype are conversions of those bounds to the derived_type, so that 322 -- their typing is consistent. 323 324 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id); 325 -- Copies attributes from array base type T2 to array base type T1. Copies 326 -- only attributes that apply to base types, but not subtypes. 327 328 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id); 329 -- Copies attributes from array subtype T2 to array subtype T1. Copies 330 -- attributes that apply to both subtypes and base types. 331 332 procedure Create_Constrained_Components 333 (Subt : Entity_Id; 334 Decl_Node : Node_Id; 335 Typ : Entity_Id; 336 Constraints : Elist_Id); 337 -- Build the list of entities for a constrained discriminated record 338 -- subtype. If a component depends on a discriminant, replace its subtype 339 -- using the discriminant values in the discriminant constraint. Subt 340 -- is the defining identifier for the subtype whose list of constrained 341 -- entities we will create. Decl_Node is the type declaration node where 342 -- we will attach all the itypes created. Typ is the base discriminated 343 -- type for the subtype Subt. Constraints is the list of discriminant 344 -- constraints for Typ. 345 346 function Constrain_Component_Type 347 (Comp : Entity_Id; 348 Constrained_Typ : Entity_Id; 349 Related_Node : Node_Id; 350 Typ : Entity_Id; 351 Constraints : Elist_Id) return Entity_Id; 352 -- Given a discriminated base type Typ, a list of discriminant constraint 353 -- Constraints for Typ and a component of Typ, with type Compon_Type, 354 -- create and return the type corresponding to Compon_type where all 355 -- discriminant references are replaced with the corresponding constraint. 356 -- If no discriminant references occur in Compon_Typ then return it as is. 357 -- Constrained_Typ is the final constrained subtype to which the 358 -- constrained Compon_Type belongs. Related_Node is the node where we will 359 -- attach all the itypes created. 360 -- 361 -- Above description is confused, what is Compon_Type??? 362 363 procedure Constrain_Access 364 (Def_Id : in out Entity_Id; 365 S : Node_Id; 366 Related_Nod : Node_Id); 367 -- Apply a list of constraints to an access type. If Def_Id is empty, it is 368 -- an anonymous type created for a subtype indication. In that case it is 369 -- created in the procedure and attached to Related_Nod. 370 371 procedure Constrain_Array 372 (Def_Id : in out Entity_Id; 373 SI : Node_Id; 374 Related_Nod : Node_Id; 375 Related_Id : Entity_Id; 376 Suffix : Character); 377 -- Apply a list of index constraints to an unconstrained array type. The 378 -- first parameter is the entity for the resulting subtype. A value of 379 -- Empty for Def_Id indicates that an implicit type must be created, but 380 -- creation is delayed (and must be done by this procedure) because other 381 -- subsidiary implicit types must be created first (which is why Def_Id 382 -- is an in/out parameter). The second parameter is a subtype indication 383 -- node for the constrained array to be created (e.g. something of the 384 -- form string (1 .. 10)). Related_Nod gives the place where this type 385 -- has to be inserted in the tree. The Related_Id and Suffix parameters 386 -- are used to build the associated Implicit type name. 387 388 procedure Constrain_Concurrent 389 (Def_Id : in out Entity_Id; 390 SI : Node_Id; 391 Related_Nod : Node_Id; 392 Related_Id : Entity_Id; 393 Suffix : Character); 394 -- Apply list of discriminant constraints to an unconstrained concurrent 395 -- type. 396 -- 397 -- SI is the N_Subtype_Indication node containing the constraint and 398 -- the unconstrained type to constrain. 399 -- 400 -- Def_Id is the entity for the resulting constrained subtype. A value 401 -- of Empty for Def_Id indicates that an implicit type must be created, 402 -- but creation is delayed (and must be done by this procedure) because 403 -- other subsidiary implicit types must be created first (which is why 404 -- Def_Id is an in/out parameter). 405 -- 406 -- Related_Nod gives the place where this type has to be inserted 407 -- in the tree 408 -- 409 -- The last two arguments are used to create its external name if needed. 410 411 function Constrain_Corresponding_Record 412 (Prot_Subt : Entity_Id; 413 Corr_Rec : Entity_Id; 414 Related_Nod : Node_Id; 415 Related_Id : Entity_Id) return Entity_Id; 416 -- When constraining a protected type or task type with discriminants, 417 -- constrain the corresponding record with the same discriminant values. 418 419 procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id); 420 -- Constrain a decimal fixed point type with a digits constraint and/or a 421 -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity. 422 423 procedure Constrain_Discriminated_Type 424 (Def_Id : Entity_Id; 425 S : Node_Id; 426 Related_Nod : Node_Id; 427 For_Access : Boolean := False); 428 -- Process discriminant constraints of composite type. Verify that values 429 -- have been provided for all discriminants, that the original type is 430 -- unconstrained, and that the types of the supplied expressions match 431 -- the discriminant types. The first three parameters are like in routine 432 -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation 433 -- of For_Access. 434 435 procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id); 436 -- Constrain an enumeration type with a range constraint. This is identical 437 -- to Constrain_Integer, but for the Ekind of the resulting subtype. 438 439 procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id); 440 -- Constrain a floating point type with either a digits constraint 441 -- and/or a range constraint, building a E_Floating_Point_Subtype. 442 443 procedure Constrain_Index 444 (Index : Node_Id; 445 S : Node_Id; 446 Related_Nod : Node_Id; 447 Related_Id : Entity_Id; 448 Suffix : Character; 449 Suffix_Index : Nat); 450 -- Process an index constraint S in a constrained array declaration. The 451 -- constraint can be a subtype name, or a range with or without an explicit 452 -- subtype mark. The index is the corresponding index of the unconstrained 453 -- array. The Related_Id and Suffix parameters are used to build the 454 -- associated Implicit type name. 455 456 procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id); 457 -- Build subtype of a signed or modular integer type 458 459 procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id); 460 -- Constrain an ordinary fixed point type with a range constraint, and 461 -- build an E_Ordinary_Fixed_Point_Subtype entity. 462 463 procedure Copy_And_Swap (Priv, Full : Entity_Id); 464 -- Copy the Priv entity into the entity of its full declaration then swap 465 -- the two entities in such a manner that the former private type is now 466 -- seen as a full type. 467 468 procedure Decimal_Fixed_Point_Type_Declaration 469 (T : Entity_Id; 470 Def : Node_Id); 471 -- Create a new decimal fixed point type, and apply the constraint to 472 -- obtain a subtype of this new type. 473 474 procedure Complete_Private_Subtype 475 (Priv : Entity_Id; 476 Full : Entity_Id; 477 Full_Base : Entity_Id; 478 Related_Nod : Node_Id); 479 -- Complete the implicit full view of a private subtype by setting the 480 -- appropriate semantic fields. If the full view of the parent is a record 481 -- type, build constrained components of subtype. 482 483 procedure Derive_Progenitor_Subprograms 484 (Parent_Type : Entity_Id; 485 Tagged_Type : Entity_Id); 486 -- Ada 2005 (AI-251): To complete type derivation, collect the primitive 487 -- operations of progenitors of Tagged_Type, and replace the subsidiary 488 -- subtypes with Tagged_Type, to build the specs of the inherited interface 489 -- primitives. The derived primitives are aliased to those of the 490 -- interface. This routine takes care also of transferring to the full view 491 -- subprograms associated with the partial view of Tagged_Type that cover 492 -- interface primitives. 493 494 procedure Derived_Standard_Character 495 (N : Node_Id; 496 Parent_Type : Entity_Id; 497 Derived_Type : Entity_Id); 498 -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles 499 -- derivations from types Standard.Character and Standard.Wide_Character. 500 501 procedure Derived_Type_Declaration 502 (T : Entity_Id; 503 N : Node_Id; 504 Is_Completion : Boolean); 505 -- Process a derived type declaration. Build_Derived_Type is invoked 506 -- to process the actual derived type definition. Parameters N and 507 -- Is_Completion have the same meaning as in Build_Derived_Type. 508 -- T is the N_Defining_Identifier for the entity defined in the 509 -- N_Full_Type_Declaration node N, that is T is the derived type. 510 511 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id); 512 -- Insert each literal in symbol table, as an overloadable identifier. Each 513 -- enumeration type is mapped into a sequence of integers, and each literal 514 -- is defined as a constant with integer value. If any of the literals are 515 -- character literals, the type is a character type, which means that 516 -- strings are legal aggregates for arrays of components of the type. 517 518 function Expand_To_Stored_Constraint 519 (Typ : Entity_Id; 520 Constraint : Elist_Id) return Elist_Id; 521 -- Given a constraint (i.e. a list of expressions) on the discriminants of 522 -- Typ, expand it into a constraint on the stored discriminants and return 523 -- the new list of expressions constraining the stored discriminants. 524 525 function Find_Type_Of_Object 526 (Obj_Def : Node_Id; 527 Related_Nod : Node_Id) return Entity_Id; 528 -- Get type entity for object referenced by Obj_Def, attaching the 529 -- implicit types generated to Related_Nod 530 531 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id); 532 -- Create a new float and apply the constraint to obtain subtype of it 533 534 function Has_Range_Constraint (N : Node_Id) return Boolean; 535 -- Given an N_Subtype_Indication node N, return True if a range constraint 536 -- is present, either directly, or as part of a digits or delta constraint. 537 -- In addition, a digits constraint in the decimal case returns True, since 538 -- it establishes a default range if no explicit range is present. 539 540 function Inherit_Components 541 (N : Node_Id; 542 Parent_Base : Entity_Id; 543 Derived_Base : Entity_Id; 544 Is_Tagged : Boolean; 545 Inherit_Discr : Boolean; 546 Discs : Elist_Id) return Elist_Id; 547 -- Called from Build_Derived_Record_Type to inherit the components of 548 -- Parent_Base (a base type) into the Derived_Base (the derived base type). 549 -- For more information on derived types and component inheritance please 550 -- consult the comment above the body of Build_Derived_Record_Type. 551 -- 552 -- N is the original derived type declaration 553 -- 554 -- Is_Tagged is set if we are dealing with tagged types 555 -- 556 -- If Inherit_Discr is set, Derived_Base inherits its discriminants from 557 -- Parent_Base, otherwise no discriminants are inherited. 558 -- 559 -- Discs gives the list of constraints that apply to Parent_Base in the 560 -- derived type declaration. If Discs is set to No_Elist, then we have 561 -- the following situation: 562 -- 563 -- type Parent (D1..Dn : ..) is [tagged] record ...; 564 -- type Derived is new Parent [with ...]; 565 -- 566 -- which gets treated as 567 -- 568 -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...]; 569 -- 570 -- For untagged types the returned value is an association list. The list 571 -- starts from the association (Parent_Base => Derived_Base), and then it 572 -- contains a sequence of the associations of the form 573 -- 574 -- (Old_Component => New_Component), 575 -- 576 -- where Old_Component is the Entity_Id of a component in Parent_Base and 577 -- New_Component is the Entity_Id of the corresponding component in 578 -- Derived_Base. For untagged records, this association list is needed when 579 -- copying the record declaration for the derived base. In the tagged case 580 -- the value returned is irrelevant. 581 582 function Is_Valid_Constraint_Kind 583 (T_Kind : Type_Kind; 584 Constraint_Kind : Node_Kind) return Boolean; 585 -- Returns True if it is legal to apply the given kind of constraint to the 586 -- given kind of type (index constraint to an array type, for example). 587 588 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id); 589 -- Create new modular type. Verify that modulus is in bounds 590 591 procedure New_Concatenation_Op (Typ : Entity_Id); 592 -- Create an abbreviated declaration for an operator in order to 593 -- materialize concatenation on array types. 594 595 procedure Ordinary_Fixed_Point_Type_Declaration 596 (T : Entity_Id; 597 Def : Node_Id); 598 -- Create a new ordinary fixed point type, and apply the constraint to 599 -- obtain subtype of it. 600 601 procedure Prepare_Private_Subtype_Completion 602 (Id : Entity_Id; 603 Related_Nod : Node_Id); 604 -- Id is a subtype of some private type. Creates the full declaration 605 -- associated with Id whenever possible, i.e. when the full declaration 606 -- of the base type is already known. Records each subtype into 607 -- Private_Dependents of the base type. 608 609 procedure Process_Incomplete_Dependents 610 (N : Node_Id; 611 Full_T : Entity_Id; 612 Inc_T : Entity_Id); 613 -- Process all entities that depend on an incomplete type. There include 614 -- subtypes, subprogram types that mention the incomplete type in their 615 -- profiles, and subprogram with access parameters that designate the 616 -- incomplete type. 617 618 -- Inc_T is the defining identifier of an incomplete type declaration, its 619 -- Ekind is E_Incomplete_Type. 620 -- 621 -- N is the corresponding N_Full_Type_Declaration for Inc_T. 622 -- 623 -- Full_T is N's defining identifier. 624 -- 625 -- Subtypes of incomplete types with discriminants are completed when the 626 -- parent type is. This is simpler than private subtypes, because they can 627 -- only appear in the same scope, and there is no need to exchange views. 628 -- Similarly, access_to_subprogram types may have a parameter or a return 629 -- type that is an incomplete type, and that must be replaced with the 630 -- full type. 631 -- 632 -- If the full type is tagged, subprogram with access parameters that 633 -- designated the incomplete may be primitive operations of the full type, 634 -- and have to be processed accordingly. 635 636 procedure Process_Real_Range_Specification (Def : Node_Id); 637 -- Given the type definition for a real type, this procedure processes and 638 -- checks the real range specification of this type definition if one is 639 -- present. If errors are found, error messages are posted, and the 640 -- Real_Range_Specification of Def is reset to Empty. 641 642 procedure Record_Type_Declaration 643 (T : Entity_Id; 644 N : Node_Id; 645 Prev : Entity_Id); 646 -- Process a record type declaration (for both untagged and tagged 647 -- records). Parameters T and N are exactly like in procedure 648 -- Derived_Type_Declaration, except that no flag Is_Completion is needed 649 -- for this routine. If this is the completion of an incomplete type 650 -- declaration, Prev is the entity of the incomplete declaration, used for 651 -- cross-referencing. Otherwise Prev = T. 652 653 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id); 654 -- This routine is used to process the actual record type definition (both 655 -- for untagged and tagged records). Def is a record type definition node. 656 -- This procedure analyzes the components in this record type definition. 657 -- Prev_T is the entity for the enclosing record type. It is provided so 658 -- that its Has_Task flag can be set if any of the component have Has_Task 659 -- set. If the declaration is the completion of an incomplete type 660 -- declaration, Prev_T is the original incomplete type, whose full view is 661 -- the record type. 662 663 procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id); 664 -- Subsidiary to Build_Derived_Record_Type. For untagged records, we 665 -- build a copy of the declaration tree of the parent, and we create 666 -- independently the list of components for the derived type. Semantic 667 -- information uses the component entities, but record representation 668 -- clauses are validated on the declaration tree. This procedure replaces 669 -- discriminants and components in the declaration with those that have 670 -- been created by Inherit_Components. 671 672 procedure Set_Fixed_Range 673 (E : Entity_Id; 674 Loc : Source_Ptr; 675 Lo : Ureal; 676 Hi : Ureal); 677 -- Build a range node with the given bounds and set it as the Scalar_Range 678 -- of the given fixed-point type entity. Loc is the source location used 679 -- for the constructed range. See body for further details. 680 681 procedure Set_Scalar_Range_For_Subtype 682 (Def_Id : Entity_Id; 683 R : Node_Id; 684 Subt : Entity_Id); 685 -- This routine is used to set the scalar range field for a subtype given 686 -- Def_Id, the entity for the subtype, and R, the range expression for the 687 -- scalar range. Subt provides the parent subtype to be used to analyze, 688 -- resolve, and check the given range. 689 690 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id); 691 -- Create a new signed integer entity, and apply the constraint to obtain 692 -- the required first named subtype of this type. 693 694 procedure Set_Stored_Constraint_From_Discriminant_Constraint 695 (E : Entity_Id); 696 -- E is some record type. This routine computes E's Stored_Constraint 697 -- from its Discriminant_Constraint. 698 699 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id); 700 -- Check that an entity in a list of progenitors is an interface, 701 -- emit error otherwise. 702 703 ----------------------- 704 -- Access_Definition -- 705 ----------------------- 706 707 function Access_Definition 708 (Related_Nod : Node_Id; 709 N : Node_Id) return Entity_Id 710 is 711 Anon_Type : Entity_Id; 712 Anon_Scope : Entity_Id; 713 Desig_Type : Entity_Id; 714 Enclosing_Prot_Type : Entity_Id := Empty; 715 716 begin 717 Check_SPARK_Restriction ("access type is not allowed", N); 718 719 if Is_Entry (Current_Scope) 720 and then Is_Task_Type (Etype (Scope (Current_Scope))) 721 then 722 Error_Msg_N ("task entries cannot have access parameters", N); 723 return Empty; 724 end if; 725 726 -- Ada 2005: for an object declaration the corresponding anonymous 727 -- type is declared in the current scope. 728 729 -- If the access definition is the return type of another access to 730 -- function, scope is the current one, because it is the one of the 731 -- current type declaration, except for the pathological case below. 732 733 if Nkind_In (Related_Nod, N_Object_Declaration, 734 N_Access_Function_Definition) 735 then 736 Anon_Scope := Current_Scope; 737 738 -- A pathological case: function returning access functions that 739 -- return access functions, etc. Each anonymous access type created 740 -- is in the enclosing scope of the outermost function. 741 742 declare 743 Par : Node_Id; 744 745 begin 746 Par := Related_Nod; 747 while Nkind_In (Par, N_Access_Function_Definition, 748 N_Access_Definition) 749 loop 750 Par := Parent (Par); 751 end loop; 752 753 if Nkind (Par) = N_Function_Specification then 754 Anon_Scope := Scope (Defining_Entity (Par)); 755 end if; 756 end; 757 758 -- For the anonymous function result case, retrieve the scope of the 759 -- function specification's associated entity rather than using the 760 -- current scope. The current scope will be the function itself if the 761 -- formal part is currently being analyzed, but will be the parent scope 762 -- in the case of a parameterless function, and we always want to use 763 -- the function's parent scope. Finally, if the function is a child 764 -- unit, we must traverse the tree to retrieve the proper entity. 765 766 elsif Nkind (Related_Nod) = N_Function_Specification 767 and then Nkind (Parent (N)) /= N_Parameter_Specification 768 then 769 -- If the current scope is a protected type, the anonymous access 770 -- is associated with one of the protected operations, and must 771 -- be available in the scope that encloses the protected declaration. 772 -- Otherwise the type is in the scope enclosing the subprogram. 773 774 -- If the function has formals, The return type of a subprogram 775 -- declaration is analyzed in the scope of the subprogram (see 776 -- Process_Formals) and thus the protected type, if present, is 777 -- the scope of the current function scope. 778 779 if Ekind (Current_Scope) = E_Protected_Type then 780 Enclosing_Prot_Type := Current_Scope; 781 782 elsif Ekind (Current_Scope) = E_Function 783 and then Ekind (Scope (Current_Scope)) = E_Protected_Type 784 then 785 Enclosing_Prot_Type := Scope (Current_Scope); 786 end if; 787 788 if Present (Enclosing_Prot_Type) then 789 Anon_Scope := Scope (Enclosing_Prot_Type); 790 791 else 792 Anon_Scope := Scope (Defining_Entity (Related_Nod)); 793 end if; 794 795 -- For an access type definition, if the current scope is a child 796 -- unit it is the scope of the type. 797 798 elsif Is_Compilation_Unit (Current_Scope) then 799 Anon_Scope := Current_Scope; 800 801 -- For access formals, access components, and access discriminants, the 802 -- scope is that of the enclosing declaration, 803 804 else 805 Anon_Scope := Scope (Current_Scope); 806 end if; 807 808 Anon_Type := 809 Create_Itype 810 (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); 811 812 if All_Present (N) 813 and then Ada_Version >= Ada_2005 814 then 815 Error_Msg_N ("ALL is not permitted for anonymous access types", N); 816 end if; 817 818 -- Ada 2005 (AI-254): In case of anonymous access to subprograms call 819 -- the corresponding semantic routine 820 821 if Present (Access_To_Subprogram_Definition (N)) then 822 823 -- Compiler runtime units are compiled in Ada 2005 mode when building 824 -- the runtime library but must also be compilable in Ada 95 mode 825 -- (when bootstrapping the compiler). 826 827 Check_Compiler_Unit (N); 828 829 Access_Subprogram_Declaration 830 (T_Name => Anon_Type, 831 T_Def => Access_To_Subprogram_Definition (N)); 832 833 if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then 834 Set_Ekind 835 (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type); 836 else 837 Set_Ekind 838 (Anon_Type, E_Anonymous_Access_Subprogram_Type); 839 end if; 840 841 Set_Can_Use_Internal_Rep 842 (Anon_Type, not Always_Compatible_Rep_On_Target); 843 844 -- If the anonymous access is associated with a protected operation, 845 -- create a reference to it after the enclosing protected definition 846 -- because the itype will be used in the subsequent bodies. 847 848 if Ekind (Current_Scope) = E_Protected_Type then 849 Build_Itype_Reference (Anon_Type, Parent (Current_Scope)); 850 end if; 851 852 return Anon_Type; 853 end if; 854 855 Find_Type (Subtype_Mark (N)); 856 Desig_Type := Entity (Subtype_Mark (N)); 857 858 Set_Directly_Designated_Type (Anon_Type, Desig_Type); 859 Set_Etype (Anon_Type, Anon_Type); 860 861 -- Make sure the anonymous access type has size and alignment fields 862 -- set, as required by gigi. This is necessary in the case of the 863 -- Task_Body_Procedure. 864 865 if not Has_Private_Component (Desig_Type) then 866 Layout_Type (Anon_Type); 867 end if; 868 869 -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs 870 -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if 871 -- the null value is allowed. In Ada 95 the null value is never allowed. 872 873 if Ada_Version >= Ada_2005 then 874 Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N)); 875 else 876 Set_Can_Never_Be_Null (Anon_Type, True); 877 end if; 878 879 -- The anonymous access type is as public as the discriminated type or 880 -- subprogram that defines it. It is imported (for back-end purposes) 881 -- if the designated type is. 882 883 Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type))); 884 885 -- Ada 2005 (AI-231): Propagate the access-constant attribute 886 887 Set_Is_Access_Constant (Anon_Type, Constant_Present (N)); 888 889 -- The context is either a subprogram declaration, object declaration, 890 -- or an access discriminant, in a private or a full type declaration. 891 -- In the case of a subprogram, if the designated type is incomplete, 892 -- the operation will be a primitive operation of the full type, to be 893 -- updated subsequently. If the type is imported through a limited_with 894 -- clause, the subprogram is not a primitive operation of the type 895 -- (which is declared elsewhere in some other scope). 896 897 if Ekind (Desig_Type) = E_Incomplete_Type 898 and then not From_With_Type (Desig_Type) 899 and then Is_Overloadable (Current_Scope) 900 then 901 Append_Elmt (Current_Scope, Private_Dependents (Desig_Type)); 902 Set_Has_Delayed_Freeze (Current_Scope); 903 end if; 904 905 -- Ada 2005: if the designated type is an interface that may contain 906 -- tasks, create a Master entity for the declaration. This must be done 907 -- before expansion of the full declaration, because the declaration may 908 -- include an expression that is an allocator, whose expansion needs the 909 -- proper Master for the created tasks. 910 911 if Nkind (Related_Nod) = N_Object_Declaration 912 and then Expander_Active 913 then 914 if Is_Interface (Desig_Type) 915 and then Is_Limited_Record (Desig_Type) 916 then 917 Build_Class_Wide_Master (Anon_Type); 918 919 -- Similarly, if the type is an anonymous access that designates 920 -- tasks, create a master entity for it in the current context. 921 922 elsif Has_Task (Desig_Type) 923 and then Comes_From_Source (Related_Nod) 924 then 925 Build_Master_Entity (Defining_Identifier (Related_Nod)); 926 Build_Master_Renaming (Anon_Type); 927 end if; 928 end if; 929 930 -- For a private component of a protected type, it is imperative that 931 -- the back-end elaborate the type immediately after the protected 932 -- declaration, because this type will be used in the declarations 933 -- created for the component within each protected body, so we must 934 -- create an itype reference for it now. 935 936 if Nkind (Parent (Related_Nod)) = N_Protected_Definition then 937 Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod))); 938 939 -- Similarly, if the access definition is the return result of a 940 -- function, create an itype reference for it because it will be used 941 -- within the function body. For a regular function that is not a 942 -- compilation unit, insert reference after the declaration. For a 943 -- protected operation, insert it after the enclosing protected type 944 -- declaration. In either case, do not create a reference for a type 945 -- obtained through a limited_with clause, because this would introduce 946 -- semantic dependencies. 947 948 -- Similarly, do not create a reference if the designated type is a 949 -- generic formal, because no use of it will reach the backend. 950 951 elsif Nkind (Related_Nod) = N_Function_Specification 952 and then not From_With_Type (Desig_Type) 953 and then not Is_Generic_Type (Desig_Type) 954 then 955 if Present (Enclosing_Prot_Type) then 956 Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type)); 957 958 elsif Is_List_Member (Parent (Related_Nod)) 959 and then Nkind (Parent (N)) /= N_Parameter_Specification 960 then 961 Build_Itype_Reference (Anon_Type, Parent (Related_Nod)); 962 end if; 963 964 -- Finally, create an itype reference for an object declaration of an 965 -- anonymous access type. This is strictly necessary only for deferred 966 -- constants, but in any case will avoid out-of-scope problems in the 967 -- back-end. 968 969 elsif Nkind (Related_Nod) = N_Object_Declaration then 970 Build_Itype_Reference (Anon_Type, Related_Nod); 971 end if; 972 973 return Anon_Type; 974 end Access_Definition; 975 976 ----------------------------------- 977 -- Access_Subprogram_Declaration -- 978 ----------------------------------- 979 980 procedure Access_Subprogram_Declaration 981 (T_Name : Entity_Id; 982 T_Def : Node_Id) 983 is 984 985 procedure Check_For_Premature_Usage (Def : Node_Id); 986 -- Check that type T_Name is not used, directly or recursively, as a 987 -- parameter or a return type in Def. Def is either a subtype, an 988 -- access_definition, or an access_to_subprogram_definition. 989 990 ------------------------------- 991 -- Check_For_Premature_Usage -- 992 ------------------------------- 993 994 procedure Check_For_Premature_Usage (Def : Node_Id) is 995 Param : Node_Id; 996 997 begin 998 -- Check for a subtype mark 999 1000 if Nkind (Def) in N_Has_Etype then 1001 if Etype (Def) = T_Name then 1002 Error_Msg_N 1003 ("type& cannot be used before end of its declaration", Def); 1004 end if; 1005 1006 -- If this is not a subtype, then this is an access_definition 1007 1008 elsif Nkind (Def) = N_Access_Definition then 1009 if Present (Access_To_Subprogram_Definition (Def)) then 1010 Check_For_Premature_Usage 1011 (Access_To_Subprogram_Definition (Def)); 1012 else 1013 Check_For_Premature_Usage (Subtype_Mark (Def)); 1014 end if; 1015 1016 -- The only cases left are N_Access_Function_Definition and 1017 -- N_Access_Procedure_Definition. 1018 1019 else 1020 if Present (Parameter_Specifications (Def)) then 1021 Param := First (Parameter_Specifications (Def)); 1022 while Present (Param) loop 1023 Check_For_Premature_Usage (Parameter_Type (Param)); 1024 Param := Next (Param); 1025 end loop; 1026 end if; 1027 1028 if Nkind (Def) = N_Access_Function_Definition then 1029 Check_For_Premature_Usage (Result_Definition (Def)); 1030 end if; 1031 end if; 1032 end Check_For_Premature_Usage; 1033 1034 -- Local variables 1035 1036 Formals : constant List_Id := Parameter_Specifications (T_Def); 1037 Formal : Entity_Id; 1038 D_Ityp : Node_Id; 1039 Desig_Type : constant Entity_Id := 1040 Create_Itype (E_Subprogram_Type, Parent (T_Def)); 1041 1042 -- Start of processing for Access_Subprogram_Declaration 1043 1044 begin 1045 Check_SPARK_Restriction ("access type is not allowed", T_Def); 1046 1047 -- Associate the Itype node with the inner full-type declaration or 1048 -- subprogram spec or entry body. This is required to handle nested 1049 -- anonymous declarations. For example: 1050 1051 -- procedure P 1052 -- (X : access procedure 1053 -- (Y : access procedure 1054 -- (Z : access T))) 1055 1056 D_Ityp := Associated_Node_For_Itype (Desig_Type); 1057 while not (Nkind_In (D_Ityp, N_Full_Type_Declaration, 1058 N_Private_Type_Declaration, 1059 N_Private_Extension_Declaration, 1060 N_Procedure_Specification, 1061 N_Function_Specification, 1062 N_Entry_Body) 1063 1064 or else 1065 Nkind_In (D_Ityp, N_Object_Declaration, 1066 N_Object_Renaming_Declaration, 1067 N_Formal_Object_Declaration, 1068 N_Formal_Type_Declaration, 1069 N_Task_Type_Declaration, 1070 N_Protected_Type_Declaration)) 1071 loop 1072 D_Ityp := Parent (D_Ityp); 1073 pragma Assert (D_Ityp /= Empty); 1074 end loop; 1075 1076 Set_Associated_Node_For_Itype (Desig_Type, D_Ityp); 1077 1078 if Nkind_In (D_Ityp, N_Procedure_Specification, 1079 N_Function_Specification) 1080 then 1081 Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp))); 1082 1083 elsif Nkind_In (D_Ityp, N_Full_Type_Declaration, 1084 N_Object_Declaration, 1085 N_Object_Renaming_Declaration, 1086 N_Formal_Type_Declaration) 1087 then 1088 Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp))); 1089 end if; 1090 1091 if Nkind (T_Def) = N_Access_Function_Definition then 1092 if Nkind (Result_Definition (T_Def)) = N_Access_Definition then 1093 declare 1094 Acc : constant Node_Id := Result_Definition (T_Def); 1095 1096 begin 1097 if Present (Access_To_Subprogram_Definition (Acc)) 1098 and then 1099 Protected_Present (Access_To_Subprogram_Definition (Acc)) 1100 then 1101 Set_Etype 1102 (Desig_Type, 1103 Replace_Anonymous_Access_To_Protected_Subprogram 1104 (T_Def)); 1105 1106 else 1107 Set_Etype 1108 (Desig_Type, 1109 Access_Definition (T_Def, Result_Definition (T_Def))); 1110 end if; 1111 end; 1112 1113 else 1114 Analyze (Result_Definition (T_Def)); 1115 1116 declare 1117 Typ : constant Entity_Id := Entity (Result_Definition (T_Def)); 1118 1119 begin 1120 -- If a null exclusion is imposed on the result type, then 1121 -- create a null-excluding itype (an access subtype) and use 1122 -- it as the function's Etype. 1123 1124 if Is_Access_Type (Typ) 1125 and then Null_Exclusion_In_Return_Present (T_Def) 1126 then 1127 Set_Etype (Desig_Type, 1128 Create_Null_Excluding_Itype 1129 (T => Typ, 1130 Related_Nod => T_Def, 1131 Scope_Id => Current_Scope)); 1132 1133 else 1134 if From_With_Type (Typ) then 1135 1136 -- AI05-151: Incomplete types are allowed in all basic 1137 -- declarations, including access to subprograms. 1138 1139 if Ada_Version >= Ada_2012 then 1140 null; 1141 1142 else 1143 Error_Msg_NE 1144 ("illegal use of incomplete type&", 1145 Result_Definition (T_Def), Typ); 1146 end if; 1147 1148 elsif Ekind (Current_Scope) = E_Package 1149 and then In_Private_Part (Current_Scope) 1150 then 1151 if Ekind (Typ) = E_Incomplete_Type then 1152 Append_Elmt (Desig_Type, Private_Dependents (Typ)); 1153 1154 elsif Is_Class_Wide_Type (Typ) 1155 and then Ekind (Etype (Typ)) = E_Incomplete_Type 1156 then 1157 Append_Elmt 1158 (Desig_Type, Private_Dependents (Etype (Typ))); 1159 end if; 1160 end if; 1161 1162 Set_Etype (Desig_Type, Typ); 1163 end if; 1164 end; 1165 end if; 1166 1167 if not (Is_Type (Etype (Desig_Type))) then 1168 Error_Msg_N 1169 ("expect type in function specification", 1170 Result_Definition (T_Def)); 1171 end if; 1172 1173 else 1174 Set_Etype (Desig_Type, Standard_Void_Type); 1175 end if; 1176 1177 if Present (Formals) then 1178 Push_Scope (Desig_Type); 1179 1180 -- A bit of a kludge here. These kludges will be removed when Itypes 1181 -- have proper parent pointers to their declarations??? 1182 1183 -- Kludge 1) Link defining_identifier of formals. Required by 1184 -- First_Formal to provide its functionality. 1185 1186 declare 1187 F : Node_Id; 1188 1189 begin 1190 F := First (Formals); 1191 1192 -- In ASIS mode, the access_to_subprogram may be analyzed twice, 1193 -- when it is part of an unconstrained type and subtype expansion 1194 -- is disabled. To avoid back-end problems with shared profiles, 1195 -- use previous subprogram type as the designated type, and then 1196 -- remove scope added above. 1197 1198 if ASIS_Mode 1199 and then Present (Scope (Defining_Identifier (F))) 1200 then 1201 Set_Etype (T_Name, T_Name); 1202 Init_Size_Align (T_Name); 1203 Set_Directly_Designated_Type (T_Name, 1204 Scope (Defining_Identifier (F))); 1205 End_Scope; 1206 return; 1207 end if; 1208 1209 while Present (F) loop 1210 if No (Parent (Defining_Identifier (F))) then 1211 Set_Parent (Defining_Identifier (F), F); 1212 end if; 1213 1214 Next (F); 1215 end loop; 1216 end; 1217 1218 Process_Formals (Formals, Parent (T_Def)); 1219 1220 -- Kludge 2) End_Scope requires that the parent pointer be set to 1221 -- something reasonable, but Itypes don't have parent pointers. So 1222 -- we set it and then unset it ??? 1223 1224 Set_Parent (Desig_Type, T_Name); 1225 End_Scope; 1226 Set_Parent (Desig_Type, Empty); 1227 end if; 1228 1229 -- Check for premature usage of the type being defined 1230 1231 Check_For_Premature_Usage (T_Def); 1232 1233 -- The return type and/or any parameter type may be incomplete. Mark 1234 -- the subprogram_type as depending on the incomplete type, so that 1235 -- it can be updated when the full type declaration is seen. This 1236 -- only applies to incomplete types declared in some enclosing scope, 1237 -- not to limited views from other packages. 1238 1239 if Present (Formals) then 1240 Formal := First_Formal (Desig_Type); 1241 while Present (Formal) loop 1242 if Ekind (Formal) /= E_In_Parameter 1243 and then Nkind (T_Def) = N_Access_Function_Definition 1244 then 1245 Error_Msg_N ("functions can only have IN parameters", Formal); 1246 end if; 1247 1248 if Ekind (Etype (Formal)) = E_Incomplete_Type 1249 and then In_Open_Scopes (Scope (Etype (Formal))) 1250 then 1251 Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal))); 1252 Set_Has_Delayed_Freeze (Desig_Type); 1253 end if; 1254 1255 Next_Formal (Formal); 1256 end loop; 1257 end if; 1258 1259 -- If the return type is incomplete, this is legal as long as the 1260 -- type is declared in the current scope and will be completed in 1261 -- it (rather than being part of limited view). 1262 1263 if Ekind (Etype (Desig_Type)) = E_Incomplete_Type 1264 and then not Has_Delayed_Freeze (Desig_Type) 1265 and then In_Open_Scopes (Scope (Etype (Desig_Type))) 1266 then 1267 Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type))); 1268 Set_Has_Delayed_Freeze (Desig_Type); 1269 end if; 1270 1271 Check_Delayed_Subprogram (Desig_Type); 1272 1273 if Protected_Present (T_Def) then 1274 Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type); 1275 Set_Convention (Desig_Type, Convention_Protected); 1276 else 1277 Set_Ekind (T_Name, E_Access_Subprogram_Type); 1278 end if; 1279 1280 Set_Can_Use_Internal_Rep (T_Name, not Always_Compatible_Rep_On_Target); 1281 1282 Set_Etype (T_Name, T_Name); 1283 Init_Size_Align (T_Name); 1284 Set_Directly_Designated_Type (T_Name, Desig_Type); 1285 1286 -- Ada 2005 (AI-231): Propagate the null-excluding attribute 1287 1288 Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def)); 1289 1290 Check_Restriction (No_Access_Subprograms, T_Def); 1291 end Access_Subprogram_Declaration; 1292 1293 ---------------------------- 1294 -- Access_Type_Declaration -- 1295 ---------------------------- 1296 1297 procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is 1298 P : constant Node_Id := Parent (Def); 1299 S : constant Node_Id := Subtype_Indication (Def); 1300 1301 Full_Desig : Entity_Id; 1302 1303 begin 1304 Check_SPARK_Restriction ("access type is not allowed", Def); 1305 1306 -- Check for permissible use of incomplete type 1307 1308 if Nkind (S) /= N_Subtype_Indication then 1309 Analyze (S); 1310 1311 if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then 1312 Set_Directly_Designated_Type (T, Entity (S)); 1313 else 1314 Set_Directly_Designated_Type (T, 1315 Process_Subtype (S, P, T, 'P')); 1316 end if; 1317 1318 else 1319 Set_Directly_Designated_Type (T, 1320 Process_Subtype (S, P, T, 'P')); 1321 end if; 1322 1323 if All_Present (Def) or Constant_Present (Def) then 1324 Set_Ekind (T, E_General_Access_Type); 1325 else 1326 Set_Ekind (T, E_Access_Type); 1327 end if; 1328 1329 Full_Desig := Designated_Type (T); 1330 1331 if Base_Type (Full_Desig) = T then 1332 Error_Msg_N ("access type cannot designate itself", S); 1333 1334 -- In Ada 2005, the type may have a limited view through some unit 1335 -- in its own context, allowing the following circularity that cannot 1336 -- be detected earlier 1337 1338 elsif Is_Class_Wide_Type (Full_Desig) 1339 and then Etype (Full_Desig) = T 1340 then 1341 Error_Msg_N 1342 ("access type cannot designate its own classwide type", S); 1343 1344 -- Clean up indication of tagged status to prevent cascaded errors 1345 1346 Set_Is_Tagged_Type (T, False); 1347 end if; 1348 1349 Set_Etype (T, T); 1350 1351 -- If the type has appeared already in a with_type clause, it is 1352 -- frozen and the pointer size is already set. Else, initialize. 1353 1354 if not From_With_Type (T) then 1355 Init_Size_Align (T); 1356 end if; 1357 1358 -- Note that Has_Task is always false, since the access type itself 1359 -- is not a task type. See Einfo for more description on this point. 1360 -- Exactly the same consideration applies to Has_Controlled_Component. 1361 1362 Set_Has_Task (T, False); 1363 Set_Has_Controlled_Component (T, False); 1364 1365 -- Initialize field Finalization_Master explicitly to Empty, to avoid 1366 -- problems where an incomplete view of this entity has been previously 1367 -- established by a limited with and an overlaid version of this field 1368 -- (Stored_Constraint) was initialized for the incomplete view. 1369 1370 -- This reset is performed in most cases except where the access type 1371 -- has been created for the purposes of allocating or deallocating a 1372 -- build-in-place object. Such access types have explicitly set pools 1373 -- and finalization masters. 1374 1375 if No (Associated_Storage_Pool (T)) then 1376 Set_Finalization_Master (T, Empty); 1377 end if; 1378 1379 -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant 1380 -- attributes 1381 1382 Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def)); 1383 Set_Is_Access_Constant (T, Constant_Present (Def)); 1384 end Access_Type_Declaration; 1385 1386 ---------------------------------- 1387 -- Add_Interface_Tag_Components -- 1388 ---------------------------------- 1389 1390 procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is 1391 Loc : constant Source_Ptr := Sloc (N); 1392 L : List_Id; 1393 Last_Tag : Node_Id; 1394 1395 procedure Add_Tag (Iface : Entity_Id); 1396 -- Add tag for one of the progenitor interfaces 1397 1398 ------------- 1399 -- Add_Tag -- 1400 ------------- 1401 1402 procedure Add_Tag (Iface : Entity_Id) is 1403 Decl : Node_Id; 1404 Def : Node_Id; 1405 Tag : Entity_Id; 1406 Offset : Entity_Id; 1407 1408 begin 1409 pragma Assert (Is_Tagged_Type (Iface) and then Is_Interface (Iface)); 1410 1411 -- This is a reasonable place to propagate predicates 1412 1413 if Has_Predicates (Iface) then 1414 Set_Has_Predicates (Typ); 1415 end if; 1416 1417 Def := 1418 Make_Component_Definition (Loc, 1419 Aliased_Present => True, 1420 Subtype_Indication => 1421 New_Occurrence_Of (RTE (RE_Interface_Tag), Loc)); 1422 1423 Tag := Make_Temporary (Loc, 'V'); 1424 1425 Decl := 1426 Make_Component_Declaration (Loc, 1427 Defining_Identifier => Tag, 1428 Component_Definition => Def); 1429 1430 Analyze_Component_Declaration (Decl); 1431 1432 Set_Analyzed (Decl); 1433 Set_Ekind (Tag, E_Component); 1434 Set_Is_Tag (Tag); 1435 Set_Is_Aliased (Tag); 1436 Set_Related_Type (Tag, Iface); 1437 Init_Component_Location (Tag); 1438 1439 pragma Assert (Is_Frozen (Iface)); 1440 1441 Set_DT_Entry_Count (Tag, 1442 DT_Entry_Count (First_Entity (Iface))); 1443 1444 if No (Last_Tag) then 1445 Prepend (Decl, L); 1446 else 1447 Insert_After (Last_Tag, Decl); 1448 end if; 1449 1450 Last_Tag := Decl; 1451 1452 -- If the ancestor has discriminants we need to give special support 1453 -- to store the offset_to_top value of the secondary dispatch tables. 1454 -- For this purpose we add a supplementary component just after the 1455 -- field that contains the tag associated with each secondary DT. 1456 1457 if Typ /= Etype (Typ) and then Has_Discriminants (Etype (Typ)) then 1458 Def := 1459 Make_Component_Definition (Loc, 1460 Subtype_Indication => 1461 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); 1462 1463 Offset := Make_Temporary (Loc, 'V'); 1464 1465 Decl := 1466 Make_Component_Declaration (Loc, 1467 Defining_Identifier => Offset, 1468 Component_Definition => Def); 1469 1470 Analyze_Component_Declaration (Decl); 1471 1472 Set_Analyzed (Decl); 1473 Set_Ekind (Offset, E_Component); 1474 Set_Is_Aliased (Offset); 1475 Set_Related_Type (Offset, Iface); 1476 Init_Component_Location (Offset); 1477 Insert_After (Last_Tag, Decl); 1478 Last_Tag := Decl; 1479 end if; 1480 end Add_Tag; 1481 1482 -- Local variables 1483 1484 Elmt : Elmt_Id; 1485 Ext : Node_Id; 1486 Comp : Node_Id; 1487 1488 -- Start of processing for Add_Interface_Tag_Components 1489 1490 begin 1491 if not RTE_Available (RE_Interface_Tag) then 1492 Error_Msg 1493 ("(Ada 2005) interface types not supported by this run-time!", 1494 Sloc (N)); 1495 return; 1496 end if; 1497 1498 if Ekind (Typ) /= E_Record_Type 1499 or else (Is_Concurrent_Record_Type (Typ) 1500 and then Is_Empty_List (Abstract_Interface_List (Typ))) 1501 or else (not Is_Concurrent_Record_Type (Typ) 1502 and then No (Interfaces (Typ)) 1503 and then Is_Empty_Elmt_List (Interfaces (Typ))) 1504 then 1505 return; 1506 end if; 1507 1508 -- Find the current last tag 1509 1510 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 1511 Ext := Record_Extension_Part (Type_Definition (N)); 1512 else 1513 pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition); 1514 Ext := Type_Definition (N); 1515 end if; 1516 1517 Last_Tag := Empty; 1518 1519 if not (Present (Component_List (Ext))) then 1520 Set_Null_Present (Ext, False); 1521 L := New_List; 1522 Set_Component_List (Ext, 1523 Make_Component_List (Loc, 1524 Component_Items => L, 1525 Null_Present => False)); 1526 else 1527 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 1528 L := Component_Items 1529 (Component_List 1530 (Record_Extension_Part 1531 (Type_Definition (N)))); 1532 else 1533 L := Component_Items 1534 (Component_List 1535 (Type_Definition (N))); 1536 end if; 1537 1538 -- Find the last tag component 1539 1540 Comp := First (L); 1541 while Present (Comp) loop 1542 if Nkind (Comp) = N_Component_Declaration 1543 and then Is_Tag (Defining_Identifier (Comp)) 1544 then 1545 Last_Tag := Comp; 1546 end if; 1547 1548 Next (Comp); 1549 end loop; 1550 end if; 1551 1552 -- At this point L references the list of components and Last_Tag 1553 -- references the current last tag (if any). Now we add the tag 1554 -- corresponding with all the interfaces that are not implemented 1555 -- by the parent. 1556 1557 if Present (Interfaces (Typ)) then 1558 Elmt := First_Elmt (Interfaces (Typ)); 1559 while Present (Elmt) loop 1560 Add_Tag (Node (Elmt)); 1561 Next_Elmt (Elmt); 1562 end loop; 1563 end if; 1564 end Add_Interface_Tag_Components; 1565 1566 ------------------------------------- 1567 -- Add_Internal_Interface_Entities -- 1568 ------------------------------------- 1569 1570 procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is 1571 Elmt : Elmt_Id; 1572 Iface : Entity_Id; 1573 Iface_Elmt : Elmt_Id; 1574 Iface_Prim : Entity_Id; 1575 Ifaces_List : Elist_Id; 1576 New_Subp : Entity_Id := Empty; 1577 Prim : Entity_Id; 1578 Restore_Scope : Boolean := False; 1579 1580 begin 1581 pragma Assert (Ada_Version >= Ada_2005 1582 and then Is_Record_Type (Tagged_Type) 1583 and then Is_Tagged_Type (Tagged_Type) 1584 and then Has_Interfaces (Tagged_Type) 1585 and then not Is_Interface (Tagged_Type)); 1586 1587 -- Ensure that the internal entities are added to the scope of the type 1588 1589 if Scope (Tagged_Type) /= Current_Scope then 1590 Push_Scope (Scope (Tagged_Type)); 1591 Restore_Scope := True; 1592 end if; 1593 1594 Collect_Interfaces (Tagged_Type, Ifaces_List); 1595 1596 Iface_Elmt := First_Elmt (Ifaces_List); 1597 while Present (Iface_Elmt) loop 1598 Iface := Node (Iface_Elmt); 1599 1600 -- Originally we excluded here from this processing interfaces that 1601 -- are parents of Tagged_Type because their primitives are located 1602 -- in the primary dispatch table (and hence no auxiliary internal 1603 -- entities are required to handle secondary dispatch tables in such 1604 -- case). However, these auxiliary entities are also required to 1605 -- handle derivations of interfaces in formals of generics (see 1606 -- Derive_Subprograms). 1607 1608 Elmt := First_Elmt (Primitive_Operations (Iface)); 1609 while Present (Elmt) loop 1610 Iface_Prim := Node (Elmt); 1611 1612 if not Is_Predefined_Dispatching_Operation (Iface_Prim) then 1613 Prim := 1614 Find_Primitive_Covering_Interface 1615 (Tagged_Type => Tagged_Type, 1616 Iface_Prim => Iface_Prim); 1617 1618 if No (Prim) and then Serious_Errors_Detected > 0 then 1619 goto Continue; 1620 end if; 1621 1622 pragma Assert (Present (Prim)); 1623 1624 -- Ada 2012 (AI05-0197): If the name of the covering primitive 1625 -- differs from the name of the interface primitive then it is 1626 -- a private primitive inherited from a parent type. In such 1627 -- case, given that Tagged_Type covers the interface, the 1628 -- inherited private primitive becomes visible. For such 1629 -- purpose we add a new entity that renames the inherited 1630 -- private primitive. 1631 1632 if Chars (Prim) /= Chars (Iface_Prim) then 1633 pragma Assert (Has_Suffix (Prim, 'P')); 1634 Derive_Subprogram 1635 (New_Subp => New_Subp, 1636 Parent_Subp => Iface_Prim, 1637 Derived_Type => Tagged_Type, 1638 Parent_Type => Iface); 1639 Set_Alias (New_Subp, Prim); 1640 Set_Is_Abstract_Subprogram 1641 (New_Subp, Is_Abstract_Subprogram (Prim)); 1642 end if; 1643 1644 Derive_Subprogram 1645 (New_Subp => New_Subp, 1646 Parent_Subp => Iface_Prim, 1647 Derived_Type => Tagged_Type, 1648 Parent_Type => Iface); 1649 1650 -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp 1651 -- associated with interface types. These entities are 1652 -- only registered in the list of primitives of its 1653 -- corresponding tagged type because they are only used 1654 -- to fill the contents of the secondary dispatch tables. 1655 -- Therefore they are removed from the homonym chains. 1656 1657 Set_Is_Hidden (New_Subp); 1658 Set_Is_Internal (New_Subp); 1659 Set_Alias (New_Subp, Prim); 1660 Set_Is_Abstract_Subprogram 1661 (New_Subp, Is_Abstract_Subprogram (Prim)); 1662 Set_Interface_Alias (New_Subp, Iface_Prim); 1663 1664 -- Internal entities associated with interface types are 1665 -- only registered in the list of primitives of the tagged 1666 -- type. They are only used to fill the contents of the 1667 -- secondary dispatch tables. Therefore they are not needed 1668 -- in the homonym chains. 1669 1670 Remove_Homonym (New_Subp); 1671 1672 -- Hidden entities associated with interfaces must have set 1673 -- the Has_Delay_Freeze attribute to ensure that, in case of 1674 -- locally defined tagged types (or compiling with static 1675 -- dispatch tables generation disabled) the corresponding 1676 -- entry of the secondary dispatch table is filled when 1677 -- such an entity is frozen. 1678 1679 Set_Has_Delayed_Freeze (New_Subp); 1680 end if; 1681 1682 <<Continue>> 1683 Next_Elmt (Elmt); 1684 end loop; 1685 1686 Next_Elmt (Iface_Elmt); 1687 end loop; 1688 1689 if Restore_Scope then 1690 Pop_Scope; 1691 end if; 1692 end Add_Internal_Interface_Entities; 1693 1694 ----------------------------------- 1695 -- Analyze_Component_Declaration -- 1696 ----------------------------------- 1697 1698 procedure Analyze_Component_Declaration (N : Node_Id) is 1699 Id : constant Entity_Id := Defining_Identifier (N); 1700 E : constant Node_Id := Expression (N); 1701 Typ : constant Node_Id := 1702 Subtype_Indication (Component_Definition (N)); 1703 T : Entity_Id; 1704 P : Entity_Id; 1705 1706 function Contains_POC (Constr : Node_Id) return Boolean; 1707 -- Determines whether a constraint uses the discriminant of a record 1708 -- type thus becoming a per-object constraint (POC). 1709 1710 function Is_Known_Limited (Typ : Entity_Id) return Boolean; 1711 -- Typ is the type of the current component, check whether this type is 1712 -- a limited type. Used to validate declaration against that of 1713 -- enclosing record. 1714 1715 ------------------ 1716 -- Contains_POC -- 1717 ------------------ 1718 1719 function Contains_POC (Constr : Node_Id) return Boolean is 1720 begin 1721 -- Prevent cascaded errors 1722 1723 if Error_Posted (Constr) then 1724 return False; 1725 end if; 1726 1727 case Nkind (Constr) is 1728 when N_Attribute_Reference => 1729 return 1730 Attribute_Name (Constr) = Name_Access 1731 and then Prefix (Constr) = Scope (Entity (Prefix (Constr))); 1732 1733 when N_Discriminant_Association => 1734 return Denotes_Discriminant (Expression (Constr)); 1735 1736 when N_Identifier => 1737 return Denotes_Discriminant (Constr); 1738 1739 when N_Index_Or_Discriminant_Constraint => 1740 declare 1741 IDC : Node_Id; 1742 1743 begin 1744 IDC := First (Constraints (Constr)); 1745 while Present (IDC) loop 1746 1747 -- One per-object constraint is sufficient 1748 1749 if Contains_POC (IDC) then 1750 return True; 1751 end if; 1752 1753 Next (IDC); 1754 end loop; 1755 1756 return False; 1757 end; 1758 1759 when N_Range => 1760 return Denotes_Discriminant (Low_Bound (Constr)) 1761 or else 1762 Denotes_Discriminant (High_Bound (Constr)); 1763 1764 when N_Range_Constraint => 1765 return Denotes_Discriminant (Range_Expression (Constr)); 1766 1767 when others => 1768 return False; 1769 1770 end case; 1771 end Contains_POC; 1772 1773 ---------------------- 1774 -- Is_Known_Limited -- 1775 ---------------------- 1776 1777 function Is_Known_Limited (Typ : Entity_Id) return Boolean is 1778 P : constant Entity_Id := Etype (Typ); 1779 R : constant Entity_Id := Root_Type (Typ); 1780 1781 begin 1782 if Is_Limited_Record (Typ) then 1783 return True; 1784 1785 -- If the root type is limited (and not a limited interface) 1786 -- so is the current type 1787 1788 elsif Is_Limited_Record (R) 1789 and then (not Is_Interface (R) or else not Is_Limited_Interface (R)) 1790 then 1791 return True; 1792 1793 -- Else the type may have a limited interface progenitor, but a 1794 -- limited record parent. 1795 1796 elsif R /= P and then Is_Limited_Record (P) then 1797 return True; 1798 1799 else 1800 return False; 1801 end if; 1802 end Is_Known_Limited; 1803 1804 -- Start of processing for Analyze_Component_Declaration 1805 1806 begin 1807 Generate_Definition (Id); 1808 Enter_Name (Id); 1809 1810 if Present (Typ) then 1811 T := Find_Type_Of_Object 1812 (Subtype_Indication (Component_Definition (N)), N); 1813 1814 if not Nkind_In (Typ, N_Identifier, N_Expanded_Name) then 1815 Check_SPARK_Restriction ("subtype mark required", Typ); 1816 end if; 1817 1818 -- Ada 2005 (AI-230): Access Definition case 1819 1820 else 1821 pragma Assert (Present 1822 (Access_Definition (Component_Definition (N)))); 1823 1824 T := Access_Definition 1825 (Related_Nod => N, 1826 N => Access_Definition (Component_Definition (N))); 1827 Set_Is_Local_Anonymous_Access (T); 1828 1829 -- Ada 2005 (AI-254) 1830 1831 if Present (Access_To_Subprogram_Definition 1832 (Access_Definition (Component_Definition (N)))) 1833 and then Protected_Present (Access_To_Subprogram_Definition 1834 (Access_Definition 1835 (Component_Definition (N)))) 1836 then 1837 T := Replace_Anonymous_Access_To_Protected_Subprogram (N); 1838 end if; 1839 end if; 1840 1841 -- If the subtype is a constrained subtype of the enclosing record, 1842 -- (which must have a partial view) the back-end does not properly 1843 -- handle the recursion. Rewrite the component declaration with an 1844 -- explicit subtype indication, which is acceptable to Gigi. We can copy 1845 -- the tree directly because side effects have already been removed from 1846 -- discriminant constraints. 1847 1848 if Ekind (T) = E_Access_Subtype 1849 and then Is_Entity_Name (Subtype_Indication (Component_Definition (N))) 1850 and then Comes_From_Source (T) 1851 and then Nkind (Parent (T)) = N_Subtype_Declaration 1852 and then Etype (Directly_Designated_Type (T)) = Current_Scope 1853 then 1854 Rewrite 1855 (Subtype_Indication (Component_Definition (N)), 1856 New_Copy_Tree (Subtype_Indication (Parent (T)))); 1857 T := Find_Type_Of_Object 1858 (Subtype_Indication (Component_Definition (N)), N); 1859 end if; 1860 1861 -- If the component declaration includes a default expression, then we 1862 -- check that the component is not of a limited type (RM 3.7(5)), 1863 -- and do the special preanalysis of the expression (see section on 1864 -- "Handling of Default and Per-Object Expressions" in the spec of 1865 -- package Sem). 1866 1867 if Present (E) then 1868 Check_SPARK_Restriction ("default expression is not allowed", E); 1869 Preanalyze_Spec_Expression (E, T); 1870 Check_Initialization (T, E); 1871 1872 if Ada_Version >= Ada_2005 1873 and then Ekind (T) = E_Anonymous_Access_Type 1874 and then Etype (E) /= Any_Type 1875 then 1876 -- Check RM 3.9.2(9): "if the expected type for an expression is 1877 -- an anonymous access-to-specific tagged type, then the object 1878 -- designated by the expression shall not be dynamically tagged 1879 -- unless it is a controlling operand in a call on a dispatching 1880 -- operation" 1881 1882 if Is_Tagged_Type (Directly_Designated_Type (T)) 1883 and then 1884 Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type 1885 and then 1886 Ekind (Directly_Designated_Type (Etype (E))) = 1887 E_Class_Wide_Type 1888 then 1889 Error_Msg_N 1890 ("access to specific tagged type required (RM 3.9.2(9))", E); 1891 end if; 1892 1893 -- (Ada 2005: AI-230): Accessibility check for anonymous 1894 -- components 1895 1896 if Type_Access_Level (Etype (E)) > 1897 Deepest_Type_Access_Level (T) 1898 then 1899 Error_Msg_N 1900 ("expression has deeper access level than component " & 1901 "(RM 3.10.2 (12.2))", E); 1902 end if; 1903 1904 -- The initialization expression is a reference to an access 1905 -- discriminant. The type of the discriminant is always deeper 1906 -- than any access type. 1907 1908 if Ekind (Etype (E)) = E_Anonymous_Access_Type 1909 and then Is_Entity_Name (E) 1910 and then Ekind (Entity (E)) = E_In_Parameter 1911 and then Present (Discriminal_Link (Entity (E))) 1912 then 1913 Error_Msg_N 1914 ("discriminant has deeper accessibility level than target", 1915 E); 1916 end if; 1917 end if; 1918 end if; 1919 1920 -- The parent type may be a private view with unknown discriminants, 1921 -- and thus unconstrained. Regular components must be constrained. 1922 1923 if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then 1924 if Is_Class_Wide_Type (T) then 1925 Error_Msg_N 1926 ("class-wide subtype with unknown discriminants" & 1927 " in component declaration", 1928 Subtype_Indication (Component_Definition (N))); 1929 else 1930 Error_Msg_N 1931 ("unconstrained subtype in component declaration", 1932 Subtype_Indication (Component_Definition (N))); 1933 end if; 1934 1935 -- Components cannot be abstract, except for the special case of 1936 -- the _Parent field (case of extending an abstract tagged type) 1937 1938 elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then 1939 Error_Msg_N ("type of a component cannot be abstract", N); 1940 end if; 1941 1942 Set_Etype (Id, T); 1943 Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N))); 1944 1945 -- The component declaration may have a per-object constraint, set 1946 -- the appropriate flag in the defining identifier of the subtype. 1947 1948 if Present (Subtype_Indication (Component_Definition (N))) then 1949 declare 1950 Sindic : constant Node_Id := 1951 Subtype_Indication (Component_Definition (N)); 1952 begin 1953 if Nkind (Sindic) = N_Subtype_Indication 1954 and then Present (Constraint (Sindic)) 1955 and then Contains_POC (Constraint (Sindic)) 1956 then 1957 Set_Has_Per_Object_Constraint (Id); 1958 end if; 1959 end; 1960 end if; 1961 1962 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry 1963 -- out some static checks. 1964 1965 if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then 1966 Null_Exclusion_Static_Checks (N); 1967 end if; 1968 1969 -- If this component is private (or depends on a private type), flag the 1970 -- record type to indicate that some operations are not available. 1971 1972 P := Private_Component (T); 1973 1974 if Present (P) then 1975 1976 -- Check for circular definitions 1977 1978 if P = Any_Type then 1979 Set_Etype (Id, Any_Type); 1980 1981 -- There is a gap in the visibility of operations only if the 1982 -- component type is not defined in the scope of the record type. 1983 1984 elsif Scope (P) = Scope (Current_Scope) then 1985 null; 1986 1987 elsif Is_Limited_Type (P) then 1988 Set_Is_Limited_Composite (Current_Scope); 1989 1990 else 1991 Set_Is_Private_Composite (Current_Scope); 1992 end if; 1993 end if; 1994 1995 if P /= Any_Type 1996 and then Is_Limited_Type (T) 1997 and then Chars (Id) /= Name_uParent 1998 and then Is_Tagged_Type (Current_Scope) 1999 then 2000 if Is_Derived_Type (Current_Scope) 2001 and then not Is_Known_Limited (Current_Scope) 2002 then 2003 Error_Msg_N 2004 ("extension of nonlimited type cannot have limited components", 2005 N); 2006 2007 if Is_Interface (Root_Type (Current_Scope)) then 2008 Error_Msg_N 2009 ("\limitedness is not inherited from limited interface", N); 2010 Error_Msg_N ("\add LIMITED to type indication", N); 2011 end if; 2012 2013 Explain_Limited_Type (T, N); 2014 Set_Etype (Id, Any_Type); 2015 Set_Is_Limited_Composite (Current_Scope, False); 2016 2017 elsif not Is_Derived_Type (Current_Scope) 2018 and then not Is_Limited_Record (Current_Scope) 2019 and then not Is_Concurrent_Type (Current_Scope) 2020 then 2021 Error_Msg_N 2022 ("nonlimited tagged type cannot have limited components", N); 2023 Explain_Limited_Type (T, N); 2024 Set_Etype (Id, Any_Type); 2025 Set_Is_Limited_Composite (Current_Scope, False); 2026 end if; 2027 end if; 2028 2029 Set_Original_Record_Component (Id, Id); 2030 2031 if Has_Aspects (N) then 2032 Analyze_Aspect_Specifications (N, Id); 2033 end if; 2034 2035 Analyze_Dimension (N); 2036 end Analyze_Component_Declaration; 2037 2038 -------------------------- 2039 -- Analyze_Declarations -- 2040 -------------------------- 2041 2042 procedure Analyze_Declarations (L : List_Id) is 2043 D : Node_Id; 2044 Freeze_From : Entity_Id := Empty; 2045 Next_Node : Node_Id; 2046 2047 procedure Adjust_D; 2048 -- Adjust D not to include implicit label declarations, since these 2049 -- have strange Sloc values that result in elaboration check problems. 2050 -- (They have the sloc of the label as found in the source, and that 2051 -- is ahead of the current declarative part). 2052 2053 -------------- 2054 -- Adjust_D -- 2055 -------------- 2056 2057 procedure Adjust_D is 2058 begin 2059 while Present (Prev (D)) 2060 and then Nkind (D) = N_Implicit_Label_Declaration 2061 loop 2062 Prev (D); 2063 end loop; 2064 end Adjust_D; 2065 2066 -- Start of processing for Analyze_Declarations 2067 2068 begin 2069 if Restriction_Check_Required (SPARK) then 2070 Check_Later_Vs_Basic_Declarations (L, During_Parsing => False); 2071 end if; 2072 2073 D := First (L); 2074 while Present (D) loop 2075 2076 -- Package spec cannot contain a package declaration in SPARK 2077 2078 if Nkind (D) = N_Package_Declaration 2079 and then Nkind (Parent (L)) = N_Package_Specification 2080 then 2081 Check_SPARK_Restriction 2082 ("package specification cannot contain a package declaration", 2083 D); 2084 end if; 2085 2086 -- Complete analysis of declaration 2087 2088 Analyze (D); 2089 Next_Node := Next (D); 2090 2091 if No (Freeze_From) then 2092 Freeze_From := First_Entity (Current_Scope); 2093 end if; 2094 2095 -- At the end of a declarative part, freeze remaining entities 2096 -- declared in it. The end of the visible declarations of package 2097 -- specification is not the end of a declarative part if private 2098 -- declarations are present. The end of a package declaration is a 2099 -- freezing point only if it a library package. A task definition or 2100 -- protected type definition is not a freeze point either. Finally, 2101 -- we do not freeze entities in generic scopes, because there is no 2102 -- code generated for them and freeze nodes will be generated for 2103 -- the instance. 2104 2105 -- The end of a package instantiation is not a freeze point, but 2106 -- for now we make it one, because the generic body is inserted 2107 -- (currently) immediately after. Generic instantiations will not 2108 -- be a freeze point once delayed freezing of bodies is implemented. 2109 -- (This is needed in any case for early instantiations ???). 2110 2111 if No (Next_Node) then 2112 if Nkind_In (Parent (L), N_Component_List, 2113 N_Task_Definition, 2114 N_Protected_Definition) 2115 then 2116 null; 2117 2118 elsif Nkind (Parent (L)) /= N_Package_Specification then 2119 if Nkind (Parent (L)) = N_Package_Body then 2120 Freeze_From := First_Entity (Current_Scope); 2121 end if; 2122 2123 Adjust_D; 2124 Freeze_All (Freeze_From, D); 2125 Freeze_From := Last_Entity (Current_Scope); 2126 2127 elsif Scope (Current_Scope) /= Standard_Standard 2128 and then not Is_Child_Unit (Current_Scope) 2129 and then No (Generic_Parent (Parent (L))) 2130 then 2131 null; 2132 2133 elsif L /= Visible_Declarations (Parent (L)) 2134 or else No (Private_Declarations (Parent (L))) 2135 or else Is_Empty_List (Private_Declarations (Parent (L))) 2136 then 2137 Adjust_D; 2138 Freeze_All (Freeze_From, D); 2139 Freeze_From := Last_Entity (Current_Scope); 2140 end if; 2141 2142 -- If next node is a body then freeze all types before the body. 2143 -- An exception occurs for some expander-generated bodies. If these 2144 -- are generated at places where in general language rules would not 2145 -- allow a freeze point, then we assume that the expander has 2146 -- explicitly checked that all required types are properly frozen, 2147 -- and we do not cause general freezing here. This special circuit 2148 -- is used when the encountered body is marked as having already 2149 -- been analyzed. 2150 2151 -- In all other cases (bodies that come from source, and expander 2152 -- generated bodies that have not been analyzed yet), freeze all 2153 -- types now. Note that in the latter case, the expander must take 2154 -- care to attach the bodies at a proper place in the tree so as to 2155 -- not cause unwanted freezing at that point. 2156 2157 elsif not Analyzed (Next_Node) 2158 and then (Nkind_In (Next_Node, N_Subprogram_Body, 2159 N_Entry_Body, 2160 N_Package_Body, 2161 N_Protected_Body, 2162 N_Task_Body) 2163 or else 2164 Nkind (Next_Node) in N_Body_Stub) 2165 then 2166 Adjust_D; 2167 Freeze_All (Freeze_From, D); 2168 Freeze_From := Last_Entity (Current_Scope); 2169 end if; 2170 2171 D := Next_Node; 2172 end loop; 2173 2174 -- One more thing to do, we need to scan the declarations to check 2175 -- for any precondition/postcondition pragmas (Pre/Post aspects have 2176 -- by this stage been converted into corresponding pragmas). It is 2177 -- at this point that we analyze the expressions in such pragmas, 2178 -- to implement the delayed visibility requirement. 2179 2180 declare 2181 Decl : Node_Id; 2182 Spec : Node_Id; 2183 Sent : Entity_Id; 2184 Prag : Node_Id; 2185 2186 begin 2187 Decl := First (L); 2188 while Present (Decl) loop 2189 if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then 2190 Spec := Specification (Original_Node (Decl)); 2191 Sent := Defining_Unit_Name (Spec); 2192 2193 -- Analyze preconditions and postconditions 2194 2195 Prag := Spec_PPC_List (Contract (Sent)); 2196 while Present (Prag) loop 2197 Analyze_PPC_In_Decl_Part (Prag, Sent); 2198 Prag := Next_Pragma (Prag); 2199 end loop; 2200 2201 -- Analyze contract-cases and test-cases 2202 2203 Prag := Spec_CTC_List (Contract (Sent)); 2204 while Present (Prag) loop 2205 Analyze_CTC_In_Decl_Part (Prag, Sent); 2206 Prag := Next_Pragma (Prag); 2207 end loop; 2208 2209 -- At this point, entities have been attached to identifiers. 2210 -- This is required to be able to detect suspicious contracts. 2211 2212 Check_Subprogram_Contract (Sent); 2213 end if; 2214 2215 Next (Decl); 2216 end loop; 2217 end; 2218 end Analyze_Declarations; 2219 2220 ----------------------------------- 2221 -- Analyze_Full_Type_Declaration -- 2222 ----------------------------------- 2223 2224 procedure Analyze_Full_Type_Declaration (N : Node_Id) is 2225 Def : constant Node_Id := Type_Definition (N); 2226 Def_Id : constant Entity_Id := Defining_Identifier (N); 2227 T : Entity_Id; 2228 Prev : Entity_Id; 2229 2230 Is_Remote : constant Boolean := 2231 (Is_Remote_Types (Current_Scope) 2232 or else Is_Remote_Call_Interface (Current_Scope)) 2233 and then not (In_Private_Part (Current_Scope) 2234 or else In_Package_Body (Current_Scope)); 2235 2236 procedure Check_Ops_From_Incomplete_Type; 2237 -- If there is a tagged incomplete partial view of the type, traverse 2238 -- the primitives of the incomplete view and change the type of any 2239 -- controlling formals and result to indicate the full view. The 2240 -- primitives will be added to the full type's primitive operations 2241 -- list later in Sem_Disp.Check_Operation_From_Incomplete_Type (which 2242 -- is called from Process_Incomplete_Dependents). 2243 2244 ------------------------------------ 2245 -- Check_Ops_From_Incomplete_Type -- 2246 ------------------------------------ 2247 2248 procedure Check_Ops_From_Incomplete_Type is 2249 Elmt : Elmt_Id; 2250 Formal : Entity_Id; 2251 Op : Entity_Id; 2252 2253 begin 2254 if Prev /= T 2255 and then Ekind (Prev) = E_Incomplete_Type 2256 and then Is_Tagged_Type (Prev) 2257 and then Is_Tagged_Type (T) 2258 then 2259 Elmt := First_Elmt (Primitive_Operations (Prev)); 2260 while Present (Elmt) loop 2261 Op := Node (Elmt); 2262 2263 Formal := First_Formal (Op); 2264 while Present (Formal) loop 2265 if Etype (Formal) = Prev then 2266 Set_Etype (Formal, T); 2267 end if; 2268 2269 Next_Formal (Formal); 2270 end loop; 2271 2272 if Etype (Op) = Prev then 2273 Set_Etype (Op, T); 2274 end if; 2275 2276 Next_Elmt (Elmt); 2277 end loop; 2278 end if; 2279 end Check_Ops_From_Incomplete_Type; 2280 2281 -- Start of processing for Analyze_Full_Type_Declaration 2282 2283 begin 2284 Prev := Find_Type_Name (N); 2285 2286 -- The full view, if present, now points to the current type 2287 2288 -- Ada 2005 (AI-50217): If the type was previously decorated when 2289 -- imported through a LIMITED WITH clause, it appears as incomplete 2290 -- but has no full view. 2291 2292 if Ekind (Prev) = E_Incomplete_Type 2293 and then Present (Full_View (Prev)) 2294 then 2295 T := Full_View (Prev); 2296 else 2297 T := Prev; 2298 end if; 2299 2300 Set_Is_Pure (T, Is_Pure (Current_Scope)); 2301 2302 -- We set the flag Is_First_Subtype here. It is needed to set the 2303 -- corresponding flag for the Implicit class-wide-type created 2304 -- during tagged types processing. 2305 2306 Set_Is_First_Subtype (T, True); 2307 2308 -- Only composite types other than array types are allowed to have 2309 -- discriminants. 2310 2311 case Nkind (Def) is 2312 2313 -- For derived types, the rule will be checked once we've figured 2314 -- out the parent type. 2315 2316 when N_Derived_Type_Definition => 2317 null; 2318 2319 -- For record types, discriminants are allowed, unless we are in 2320 -- SPARK. 2321 2322 when N_Record_Definition => 2323 if Present (Discriminant_Specifications (N)) then 2324 Check_SPARK_Restriction 2325 ("discriminant type is not allowed", 2326 Defining_Identifier 2327 (First (Discriminant_Specifications (N)))); 2328 end if; 2329 2330 when others => 2331 if Present (Discriminant_Specifications (N)) then 2332 Error_Msg_N 2333 ("elementary or array type cannot have discriminants", 2334 Defining_Identifier 2335 (First (Discriminant_Specifications (N)))); 2336 end if; 2337 end case; 2338 2339 -- Elaborate the type definition according to kind, and generate 2340 -- subsidiary (implicit) subtypes where needed. We skip this if it was 2341 -- already done (this happens during the reanalysis that follows a call 2342 -- to the high level optimizer). 2343 2344 if not Analyzed (T) then 2345 Set_Analyzed (T); 2346 2347 case Nkind (Def) is 2348 2349 when N_Access_To_Subprogram_Definition => 2350 Access_Subprogram_Declaration (T, Def); 2351 2352 -- If this is a remote access to subprogram, we must create the 2353 -- equivalent fat pointer type, and related subprograms. 2354 2355 if Is_Remote then 2356 Process_Remote_AST_Declaration (N); 2357 end if; 2358 2359 -- Validate categorization rule against access type declaration 2360 -- usually a violation in Pure unit, Shared_Passive unit. 2361 2362 Validate_Access_Type_Declaration (T, N); 2363 2364 when N_Access_To_Object_Definition => 2365 Access_Type_Declaration (T, Def); 2366 2367 -- Validate categorization rule against access type declaration 2368 -- usually a violation in Pure unit, Shared_Passive unit. 2369 2370 Validate_Access_Type_Declaration (T, N); 2371 2372 -- If we are in a Remote_Call_Interface package and define a 2373 -- RACW, then calling stubs and specific stream attributes 2374 -- must be added. 2375 2376 if Is_Remote 2377 and then Is_Remote_Access_To_Class_Wide_Type (Def_Id) 2378 then 2379 Add_RACW_Features (Def_Id); 2380 end if; 2381 2382 -- Set no strict aliasing flag if config pragma seen 2383 2384 if Opt.No_Strict_Aliasing then 2385 Set_No_Strict_Aliasing (Base_Type (Def_Id)); 2386 end if; 2387 2388 when N_Array_Type_Definition => 2389 Array_Type_Declaration (T, Def); 2390 2391 when N_Derived_Type_Definition => 2392 Derived_Type_Declaration (T, N, T /= Def_Id); 2393 2394 when N_Enumeration_Type_Definition => 2395 Enumeration_Type_Declaration (T, Def); 2396 2397 when N_Floating_Point_Definition => 2398 Floating_Point_Type_Declaration (T, Def); 2399 2400 when N_Decimal_Fixed_Point_Definition => 2401 Decimal_Fixed_Point_Type_Declaration (T, Def); 2402 2403 when N_Ordinary_Fixed_Point_Definition => 2404 Ordinary_Fixed_Point_Type_Declaration (T, Def); 2405 2406 when N_Signed_Integer_Type_Definition => 2407 Signed_Integer_Type_Declaration (T, Def); 2408 2409 when N_Modular_Type_Definition => 2410 Modular_Type_Declaration (T, Def); 2411 2412 when N_Record_Definition => 2413 Record_Type_Declaration (T, N, Prev); 2414 2415 -- If declaration has a parse error, nothing to elaborate. 2416 2417 when N_Error => 2418 null; 2419 2420 when others => 2421 raise Program_Error; 2422 2423 end case; 2424 end if; 2425 2426 if Etype (T) = Any_Type then 2427 return; 2428 end if; 2429 2430 -- Controlled type is not allowed in SPARK 2431 2432 if Is_Visibly_Controlled (T) then 2433 Check_SPARK_Restriction ("controlled type is not allowed", N); 2434 end if; 2435 2436 -- Some common processing for all types 2437 2438 Set_Depends_On_Private (T, Has_Private_Component (T)); 2439 Check_Ops_From_Incomplete_Type; 2440 2441 -- Both the declared entity, and its anonymous base type if one 2442 -- was created, need freeze nodes allocated. 2443 2444 declare 2445 B : constant Entity_Id := Base_Type (T); 2446 2447 begin 2448 -- In the case where the base type differs from the first subtype, we 2449 -- pre-allocate a freeze node, and set the proper link to the first 2450 -- subtype. Freeze_Entity will use this preallocated freeze node when 2451 -- it freezes the entity. 2452 2453 -- This does not apply if the base type is a generic type, whose 2454 -- declaration is independent of the current derived definition. 2455 2456 if B /= T and then not Is_Generic_Type (B) then 2457 Ensure_Freeze_Node (B); 2458 Set_First_Subtype_Link (Freeze_Node (B), T); 2459 end if; 2460 2461 -- A type that is imported through a limited_with clause cannot 2462 -- generate any code, and thus need not be frozen. However, an access 2463 -- type with an imported designated type needs a finalization list, 2464 -- which may be referenced in some other package that has non-limited 2465 -- visibility on the designated type. Thus we must create the 2466 -- finalization list at the point the access type is frozen, to 2467 -- prevent unsatisfied references at link time. 2468 2469 if not From_With_Type (T) or else Is_Access_Type (T) then 2470 Set_Has_Delayed_Freeze (T); 2471 end if; 2472 end; 2473 2474 -- Case where T is the full declaration of some private type which has 2475 -- been swapped in Defining_Identifier (N). 2476 2477 if T /= Def_Id and then Is_Private_Type (Def_Id) then 2478 Process_Full_View (N, T, Def_Id); 2479 2480 -- Record the reference. The form of this is a little strange, since 2481 -- the full declaration has been swapped in. So the first parameter 2482 -- here represents the entity to which a reference is made which is 2483 -- the "real" entity, i.e. the one swapped in, and the second 2484 -- parameter provides the reference location. 2485 2486 -- Also, we want to kill Has_Pragma_Unreferenced temporarily here 2487 -- since we don't want a complaint about the full type being an 2488 -- unwanted reference to the private type 2489 2490 declare 2491 B : constant Boolean := Has_Pragma_Unreferenced (T); 2492 begin 2493 Set_Has_Pragma_Unreferenced (T, False); 2494 Generate_Reference (T, T, 'c'); 2495 Set_Has_Pragma_Unreferenced (T, B); 2496 end; 2497 2498 Set_Completion_Referenced (Def_Id); 2499 2500 -- For completion of incomplete type, process incomplete dependents 2501 -- and always mark the full type as referenced (it is the incomplete 2502 -- type that we get for any real reference). 2503 2504 elsif Ekind (Prev) = E_Incomplete_Type then 2505 Process_Incomplete_Dependents (N, T, Prev); 2506 Generate_Reference (Prev, Def_Id, 'c'); 2507 Set_Completion_Referenced (Def_Id); 2508 2509 -- If not private type or incomplete type completion, this is a real 2510 -- definition of a new entity, so record it. 2511 2512 else 2513 Generate_Definition (Def_Id); 2514 end if; 2515 2516 if Chars (Scope (Def_Id)) = Name_System 2517 and then Chars (Def_Id) = Name_Address 2518 and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N))) 2519 then 2520 Set_Is_Descendent_Of_Address (Def_Id); 2521 Set_Is_Descendent_Of_Address (Base_Type (Def_Id)); 2522 Set_Is_Descendent_Of_Address (Prev); 2523 end if; 2524 2525 Set_Optimize_Alignment_Flags (Def_Id); 2526 Check_Eliminated (Def_Id); 2527 2528 -- If the declaration is a completion and aspects are present, apply 2529 -- them to the entity for the type which is currently the partial 2530 -- view, but which is the one that will be frozen. 2531 2532 if Has_Aspects (N) then 2533 if Prev /= Def_Id then 2534 Analyze_Aspect_Specifications (N, Prev); 2535 else 2536 Analyze_Aspect_Specifications (N, Def_Id); 2537 end if; 2538 end if; 2539 end Analyze_Full_Type_Declaration; 2540 2541 ---------------------------------- 2542 -- Analyze_Incomplete_Type_Decl -- 2543 ---------------------------------- 2544 2545 procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is 2546 F : constant Boolean := Is_Pure (Current_Scope); 2547 T : Entity_Id; 2548 2549 begin 2550 Check_SPARK_Restriction ("incomplete type is not allowed", N); 2551 2552 Generate_Definition (Defining_Identifier (N)); 2553 2554 -- Process an incomplete declaration. The identifier must not have been 2555 -- declared already in the scope. However, an incomplete declaration may 2556 -- appear in the private part of a package, for a private type that has 2557 -- already been declared. 2558 2559 -- In this case, the discriminants (if any) must match 2560 2561 T := Find_Type_Name (N); 2562 2563 Set_Ekind (T, E_Incomplete_Type); 2564 Init_Size_Align (T); 2565 Set_Is_First_Subtype (T, True); 2566 Set_Etype (T, T); 2567 2568 -- Ada 2005 (AI-326): Minimum decoration to give support to tagged 2569 -- incomplete types. 2570 2571 if Tagged_Present (N) then 2572 Set_Is_Tagged_Type (T); 2573 Make_Class_Wide_Type (T); 2574 Set_Direct_Primitive_Operations (T, New_Elmt_List); 2575 end if; 2576 2577 Push_Scope (T); 2578 2579 Set_Stored_Constraint (T, No_Elist); 2580 2581 if Present (Discriminant_Specifications (N)) then 2582 Process_Discriminants (N); 2583 end if; 2584 2585 End_Scope; 2586 2587 -- If the type has discriminants, non-trivial subtypes may be 2588 -- declared before the full view of the type. The full views of those 2589 -- subtypes will be built after the full view of the type. 2590 2591 Set_Private_Dependents (T, New_Elmt_List); 2592 Set_Is_Pure (T, F); 2593 end Analyze_Incomplete_Type_Decl; 2594 2595 ----------------------------------- 2596 -- Analyze_Interface_Declaration -- 2597 ----------------------------------- 2598 2599 procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is 2600 CW : constant Entity_Id := Class_Wide_Type (T); 2601 2602 begin 2603 Set_Is_Tagged_Type (T); 2604 2605 Set_Is_Limited_Record (T, Limited_Present (Def) 2606 or else Task_Present (Def) 2607 or else Protected_Present (Def) 2608 or else Synchronized_Present (Def)); 2609 2610 -- Type is abstract if full declaration carries keyword, or if previous 2611 -- partial view did. 2612 2613 Set_Is_Abstract_Type (T); 2614 Set_Is_Interface (T); 2615 2616 -- Type is a limited interface if it includes the keyword limited, task, 2617 -- protected, or synchronized. 2618 2619 Set_Is_Limited_Interface 2620 (T, Limited_Present (Def) 2621 or else Protected_Present (Def) 2622 or else Synchronized_Present (Def) 2623 or else Task_Present (Def)); 2624 2625 Set_Interfaces (T, New_Elmt_List); 2626 Set_Direct_Primitive_Operations (T, New_Elmt_List); 2627 2628 -- Complete the decoration of the class-wide entity if it was already 2629 -- built (i.e. during the creation of the limited view) 2630 2631 if Present (CW) then 2632 Set_Is_Interface (CW); 2633 Set_Is_Limited_Interface (CW, Is_Limited_Interface (T)); 2634 end if; 2635 2636 -- Check runtime support for synchronized interfaces 2637 2638 if VM_Target = No_VM 2639 and then (Is_Task_Interface (T) 2640 or else Is_Protected_Interface (T) 2641 or else Is_Synchronized_Interface (T)) 2642 and then not RTE_Available (RE_Select_Specific_Data) 2643 then 2644 Error_Msg_CRT ("synchronized interfaces", T); 2645 end if; 2646 end Analyze_Interface_Declaration; 2647 2648 ----------------------------- 2649 -- Analyze_Itype_Reference -- 2650 ----------------------------- 2651 2652 -- Nothing to do. This node is placed in the tree only for the benefit of 2653 -- back end processing, and has no effect on the semantic processing. 2654 2655 procedure Analyze_Itype_Reference (N : Node_Id) is 2656 begin 2657 pragma Assert (Is_Itype (Itype (N))); 2658 null; 2659 end Analyze_Itype_Reference; 2660 2661 -------------------------------- 2662 -- Analyze_Number_Declaration -- 2663 -------------------------------- 2664 2665 procedure Analyze_Number_Declaration (N : Node_Id) is 2666 Id : constant Entity_Id := Defining_Identifier (N); 2667 E : constant Node_Id := Expression (N); 2668 T : Entity_Id; 2669 Index : Interp_Index; 2670 It : Interp; 2671 2672 begin 2673 Generate_Definition (Id); 2674 Enter_Name (Id); 2675 2676 -- This is an optimization of a common case of an integer literal 2677 2678 if Nkind (E) = N_Integer_Literal then 2679 Set_Is_Static_Expression (E, True); 2680 Set_Etype (E, Universal_Integer); 2681 2682 Set_Etype (Id, Universal_Integer); 2683 Set_Ekind (Id, E_Named_Integer); 2684 Set_Is_Frozen (Id, True); 2685 return; 2686 end if; 2687 2688 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 2689 2690 -- Process expression, replacing error by integer zero, to avoid 2691 -- cascaded errors or aborts further along in the processing 2692 2693 -- Replace Error by integer zero, which seems least likely to cause 2694 -- cascaded errors. 2695 2696 if E = Error then 2697 Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0)); 2698 Set_Error_Posted (E); 2699 end if; 2700 2701 Analyze (E); 2702 2703 -- Verify that the expression is static and numeric. If 2704 -- the expression is overloaded, we apply the preference 2705 -- rule that favors root numeric types. 2706 2707 if not Is_Overloaded (E) then 2708 T := Etype (E); 2709 2710 else 2711 T := Any_Type; 2712 2713 Get_First_Interp (E, Index, It); 2714 while Present (It.Typ) loop 2715 if (Is_Integer_Type (It.Typ) or else Is_Real_Type (It.Typ)) 2716 and then (Scope (Base_Type (It.Typ))) = Standard_Standard 2717 then 2718 if T = Any_Type then 2719 T := It.Typ; 2720 2721 elsif It.Typ = Universal_Real 2722 or else It.Typ = Universal_Integer 2723 then 2724 -- Choose universal interpretation over any other 2725 2726 T := It.Typ; 2727 exit; 2728 end if; 2729 end if; 2730 2731 Get_Next_Interp (Index, It); 2732 end loop; 2733 end if; 2734 2735 if Is_Integer_Type (T) then 2736 Resolve (E, T); 2737 Set_Etype (Id, Universal_Integer); 2738 Set_Ekind (Id, E_Named_Integer); 2739 2740 elsif Is_Real_Type (T) then 2741 2742 -- Because the real value is converted to universal_real, this is a 2743 -- legal context for a universal fixed expression. 2744 2745 if T = Universal_Fixed then 2746 declare 2747 Loc : constant Source_Ptr := Sloc (N); 2748 Conv : constant Node_Id := Make_Type_Conversion (Loc, 2749 Subtype_Mark => 2750 New_Occurrence_Of (Universal_Real, Loc), 2751 Expression => Relocate_Node (E)); 2752 2753 begin 2754 Rewrite (E, Conv); 2755 Analyze (E); 2756 end; 2757 2758 elsif T = Any_Fixed then 2759 Error_Msg_N ("illegal context for mixed mode operation", E); 2760 2761 -- Expression is of the form : universal_fixed * integer. Try to 2762 -- resolve as universal_real. 2763 2764 T := Universal_Real; 2765 Set_Etype (E, T); 2766 end if; 2767 2768 Resolve (E, T); 2769 Set_Etype (Id, Universal_Real); 2770 Set_Ekind (Id, E_Named_Real); 2771 2772 else 2773 Wrong_Type (E, Any_Numeric); 2774 Resolve (E, T); 2775 2776 Set_Etype (Id, T); 2777 Set_Ekind (Id, E_Constant); 2778 Set_Never_Set_In_Source (Id, True); 2779 Set_Is_True_Constant (Id, True); 2780 return; 2781 end if; 2782 2783 if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then 2784 Set_Etype (E, Etype (Id)); 2785 end if; 2786 2787 if not Is_OK_Static_Expression (E) then 2788 Flag_Non_Static_Expr 2789 ("non-static expression used in number declaration!", E); 2790 Rewrite (E, Make_Integer_Literal (Sloc (N), 1)); 2791 Set_Etype (E, Any_Type); 2792 end if; 2793 end Analyze_Number_Declaration; 2794 2795 -------------------------------- 2796 -- Analyze_Object_Declaration -- 2797 -------------------------------- 2798 2799 procedure Analyze_Object_Declaration (N : Node_Id) is 2800 Loc : constant Source_Ptr := Sloc (N); 2801 Id : constant Entity_Id := Defining_Identifier (N); 2802 T : Entity_Id; 2803 Act_T : Entity_Id; 2804 2805 E : Node_Id := Expression (N); 2806 -- E is set to Expression (N) throughout this routine. When 2807 -- Expression (N) is modified, E is changed accordingly. 2808 2809 Prev_Entity : Entity_Id := Empty; 2810 2811 function Count_Tasks (T : Entity_Id) return Uint; 2812 -- This function is called when a non-generic library level object of a 2813 -- task type is declared. Its function is to count the static number of 2814 -- tasks declared within the type (it is only called if Has_Tasks is set 2815 -- for T). As a side effect, if an array of tasks with non-static bounds 2816 -- or a variant record type is encountered, Check_Restrictions is called 2817 -- indicating the count is unknown. 2818 2819 ----------------- 2820 -- Count_Tasks -- 2821 ----------------- 2822 2823 function Count_Tasks (T : Entity_Id) return Uint is 2824 C : Entity_Id; 2825 X : Node_Id; 2826 V : Uint; 2827 2828 begin 2829 if Is_Task_Type (T) then 2830 return Uint_1; 2831 2832 elsif Is_Record_Type (T) then 2833 if Has_Discriminants (T) then 2834 Check_Restriction (Max_Tasks, N); 2835 return Uint_0; 2836 2837 else 2838 V := Uint_0; 2839 C := First_Component (T); 2840 while Present (C) loop 2841 V := V + Count_Tasks (Etype (C)); 2842 Next_Component (C); 2843 end loop; 2844 2845 return V; 2846 end if; 2847 2848 elsif Is_Array_Type (T) then 2849 X := First_Index (T); 2850 V := Count_Tasks (Component_Type (T)); 2851 while Present (X) loop 2852 C := Etype (X); 2853 2854 if not Is_Static_Subtype (C) then 2855 Check_Restriction (Max_Tasks, N); 2856 return Uint_0; 2857 else 2858 V := V * (UI_Max (Uint_0, 2859 Expr_Value (Type_High_Bound (C)) - 2860 Expr_Value (Type_Low_Bound (C)) + Uint_1)); 2861 end if; 2862 2863 Next_Index (X); 2864 end loop; 2865 2866 return V; 2867 2868 else 2869 return Uint_0; 2870 end if; 2871 end Count_Tasks; 2872 2873 -- Start of processing for Analyze_Object_Declaration 2874 2875 begin 2876 -- There are three kinds of implicit types generated by an 2877 -- object declaration: 2878 2879 -- 1. Those generated by the original Object Definition 2880 2881 -- 2. Those generated by the Expression 2882 2883 -- 3. Those used to constrain the Object Definition with the 2884 -- expression constraints when the definition is unconstrained. 2885 2886 -- They must be generated in this order to avoid order of elaboration 2887 -- issues. Thus the first step (after entering the name) is to analyze 2888 -- the object definition. 2889 2890 if Constant_Present (N) then 2891 Prev_Entity := Current_Entity_In_Scope (Id); 2892 2893 if Present (Prev_Entity) 2894 and then 2895 2896 -- If the homograph is an implicit subprogram, it is overridden 2897 -- by the current declaration. 2898 2899 ((Is_Overloadable (Prev_Entity) 2900 and then Is_Inherited_Operation (Prev_Entity)) 2901 2902 -- The current object is a discriminal generated for an entry 2903 -- family index. Even though the index is a constant, in this 2904 -- particular context there is no true constant redeclaration. 2905 -- Enter_Name will handle the visibility. 2906 2907 or else 2908 (Is_Discriminal (Id) 2909 and then Ekind (Discriminal_Link (Id)) = 2910 E_Entry_Index_Parameter) 2911 2912 -- The current object is the renaming for a generic declared 2913 -- within the instance. 2914 2915 or else 2916 (Ekind (Prev_Entity) = E_Package 2917 and then Nkind (Parent (Prev_Entity)) = 2918 N_Package_Renaming_Declaration 2919 and then not Comes_From_Source (Prev_Entity) 2920 and then Is_Generic_Instance (Renamed_Entity (Prev_Entity)))) 2921 then 2922 Prev_Entity := Empty; 2923 end if; 2924 end if; 2925 2926 if Present (Prev_Entity) then 2927 Constant_Redeclaration (Id, N, T); 2928 2929 Generate_Reference (Prev_Entity, Id, 'c'); 2930 Set_Completion_Referenced (Id); 2931 2932 if Error_Posted (N) then 2933 2934 -- Type mismatch or illegal redeclaration, Do not analyze 2935 -- expression to avoid cascaded errors. 2936 2937 T := Find_Type_Of_Object (Object_Definition (N), N); 2938 Set_Etype (Id, T); 2939 Set_Ekind (Id, E_Variable); 2940 goto Leave; 2941 end if; 2942 2943 -- In the normal case, enter identifier at the start to catch premature 2944 -- usage in the initialization expression. 2945 2946 else 2947 Generate_Definition (Id); 2948 Enter_Name (Id); 2949 2950 Mark_Coextensions (N, Object_Definition (N)); 2951 2952 T := Find_Type_Of_Object (Object_Definition (N), N); 2953 2954 if Nkind (Object_Definition (N)) = N_Access_Definition 2955 and then Present 2956 (Access_To_Subprogram_Definition (Object_Definition (N))) 2957 and then Protected_Present 2958 (Access_To_Subprogram_Definition (Object_Definition (N))) 2959 then 2960 T := Replace_Anonymous_Access_To_Protected_Subprogram (N); 2961 end if; 2962 2963 if Error_Posted (Id) then 2964 Set_Etype (Id, T); 2965 Set_Ekind (Id, E_Variable); 2966 goto Leave; 2967 end if; 2968 end if; 2969 2970 -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry 2971 -- out some static checks 2972 2973 if Ada_Version >= Ada_2005 2974 and then Can_Never_Be_Null (T) 2975 then 2976 -- In case of aggregates we must also take care of the correct 2977 -- initialization of nested aggregates bug this is done at the 2978 -- point of the analysis of the aggregate (see sem_aggr.adb) 2979 2980 if Present (Expression (N)) 2981 and then Nkind (Expression (N)) = N_Aggregate 2982 then 2983 null; 2984 2985 else 2986 declare 2987 Save_Typ : constant Entity_Id := Etype (Id); 2988 begin 2989 Set_Etype (Id, T); -- Temp. decoration for static checks 2990 Null_Exclusion_Static_Checks (N); 2991 Set_Etype (Id, Save_Typ); 2992 end; 2993 end if; 2994 end if; 2995 2996 -- Object is marked pure if it is in a pure scope 2997 2998 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 2999 3000 -- If deferred constant, make sure context is appropriate. We detect 3001 -- a deferred constant as a constant declaration with no expression. 3002 -- A deferred constant can appear in a package body if its completion 3003 -- is by means of an interface pragma. 3004 3005 if Constant_Present (N) and then No (E) then 3006 3007 -- A deferred constant may appear in the declarative part of the 3008 -- following constructs: 3009 3010 -- blocks 3011 -- entry bodies 3012 -- extended return statements 3013 -- package specs 3014 -- package bodies 3015 -- subprogram bodies 3016 -- task bodies 3017 3018 -- When declared inside a package spec, a deferred constant must be 3019 -- completed by a full constant declaration or pragma Import. In all 3020 -- other cases, the only proper completion is pragma Import. Extended 3021 -- return statements are flagged as invalid contexts because they do 3022 -- not have a declarative part and so cannot accommodate the pragma. 3023 3024 if Ekind (Current_Scope) = E_Return_Statement then 3025 Error_Msg_N 3026 ("invalid context for deferred constant declaration (RM 7.4)", 3027 N); 3028 Error_Msg_N 3029 ("\declaration requires an initialization expression", 3030 N); 3031 Set_Constant_Present (N, False); 3032 3033 -- In Ada 83, deferred constant must be of private type 3034 3035 elsif not Is_Private_Type (T) then 3036 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 3037 Error_Msg_N 3038 ("(Ada 83) deferred constant must be private type", N); 3039 end if; 3040 end if; 3041 3042 -- If not a deferred constant, then object declaration freezes its type 3043 3044 else 3045 Check_Fully_Declared (T, N); 3046 Freeze_Before (N, T); 3047 end if; 3048 3049 -- If the object was created by a constrained array definition, then 3050 -- set the link in both the anonymous base type and anonymous subtype 3051 -- that are built to represent the array type to point to the object. 3052 3053 if Nkind (Object_Definition (Declaration_Node (Id))) = 3054 N_Constrained_Array_Definition 3055 then 3056 Set_Related_Array_Object (T, Id); 3057 Set_Related_Array_Object (Base_Type (T), Id); 3058 end if; 3059 3060 -- Special checks for protected objects not at library level 3061 3062 if Is_Protected_Type (T) 3063 and then not Is_Library_Level_Entity (Id) 3064 then 3065 Check_Restriction (No_Local_Protected_Objects, Id); 3066 3067 -- Protected objects with interrupt handlers must be at library level 3068 3069 -- Ada 2005: this test is not needed (and the corresponding clause 3070 -- in the RM is removed) because accessibility checks are sufficient 3071 -- to make handlers not at the library level illegal. 3072 3073 -- AI05-0303: the AI is in fact a binding interpretation, and thus 3074 -- applies to the '95 version of the language as well. 3075 3076 if Has_Interrupt_Handler (T) and then Ada_Version < Ada_95 then 3077 Error_Msg_N 3078 ("interrupt object can only be declared at library level", Id); 3079 end if; 3080 end if; 3081 3082 -- The actual subtype of the object is the nominal subtype, unless 3083 -- the nominal one is unconstrained and obtained from the expression. 3084 3085 Act_T := T; 3086 3087 -- These checks should be performed before the initialization expression 3088 -- is considered, so that the Object_Definition node is still the same 3089 -- as in source code. 3090 3091 -- In SPARK, the nominal subtype shall be given by a subtype mark and 3092 -- shall not be unconstrained. (The only exception to this is the 3093 -- admission of declarations of constants of type String.) 3094 3095 if not 3096 Nkind_In (Object_Definition (N), N_Identifier, N_Expanded_Name) 3097 then 3098 Check_SPARK_Restriction 3099 ("subtype mark required", Object_Definition (N)); 3100 3101 elsif Is_Array_Type (T) 3102 and then not Is_Constrained (T) 3103 and then T /= Standard_String 3104 then 3105 Check_SPARK_Restriction 3106 ("subtype mark of constrained type expected", 3107 Object_Definition (N)); 3108 end if; 3109 3110 -- There are no aliased objects in SPARK 3111 3112 if Aliased_Present (N) then 3113 Check_SPARK_Restriction ("aliased object is not allowed", N); 3114 end if; 3115 3116 -- Process initialization expression if present and not in error 3117 3118 if Present (E) and then E /= Error then 3119 3120 -- Generate an error in case of CPP class-wide object initialization. 3121 -- Required because otherwise the expansion of the class-wide 3122 -- assignment would try to use 'size to initialize the object 3123 -- (primitive that is not available in CPP tagged types). 3124 3125 if Is_Class_Wide_Type (Act_T) 3126 and then 3127 (Is_CPP_Class (Root_Type (Etype (Act_T))) 3128 or else 3129 (Present (Full_View (Root_Type (Etype (Act_T)))) 3130 and then 3131 Is_CPP_Class (Full_View (Root_Type (Etype (Act_T)))))) 3132 then 3133 Error_Msg_N 3134 ("predefined assignment not available for 'C'P'P tagged types", 3135 E); 3136 end if; 3137 3138 Mark_Coextensions (N, E); 3139 Analyze (E); 3140 3141 -- In case of errors detected in the analysis of the expression, 3142 -- decorate it with the expected type to avoid cascaded errors 3143 3144 if No (Etype (E)) then 3145 Set_Etype (E, T); 3146 end if; 3147 3148 -- If an initialization expression is present, then we set the 3149 -- Is_True_Constant flag. It will be reset if this is a variable 3150 -- and it is indeed modified. 3151 3152 Set_Is_True_Constant (Id, True); 3153 3154 -- If we are analyzing a constant declaration, set its completion 3155 -- flag after analyzing and resolving the expression. 3156 3157 if Constant_Present (N) then 3158 Set_Has_Completion (Id); 3159 end if; 3160 3161 -- Set type and resolve (type may be overridden later on). Note: 3162 -- Ekind (Id) must still be E_Void at this point so that incorrect 3163 -- early usage within E is properly diagnosed. 3164 3165 Set_Etype (Id, T); 3166 Resolve (E, T); 3167 3168 -- No further action needed if E is a call to an inlined function 3169 -- which returns an unconstrained type and it has been expanded into 3170 -- a procedure call. In that case N has been replaced by an object 3171 -- declaration without initializing expression and it has been 3172 -- analyzed (see Expand_Inlined_Call). 3173 3174 if Debug_Flag_Dot_K 3175 and then Expander_Active 3176 and then Nkind (E) = N_Function_Call 3177 and then Nkind (Name (E)) in N_Has_Entity 3178 and then Is_Inlined (Entity (Name (E))) 3179 and then not Is_Constrained (Etype (E)) 3180 and then Analyzed (N) 3181 and then No (Expression (N)) 3182 then 3183 return; 3184 end if; 3185 3186 -- If E is null and has been replaced by an N_Raise_Constraint_Error 3187 -- node (which was marked already-analyzed), we need to set the type 3188 -- to something other than Any_Access in order to keep gigi happy. 3189 3190 if Etype (E) = Any_Access then 3191 Set_Etype (E, T); 3192 end if; 3193 3194 -- If the object is an access to variable, the initialization 3195 -- expression cannot be an access to constant. 3196 3197 if Is_Access_Type (T) 3198 and then not Is_Access_Constant (T) 3199 and then Is_Access_Type (Etype (E)) 3200 and then Is_Access_Constant (Etype (E)) 3201 then 3202 Error_Msg_N 3203 ("access to variable cannot be initialized " 3204 & "with an access-to-constant expression", E); 3205 end if; 3206 3207 if not Assignment_OK (N) then 3208 Check_Initialization (T, E); 3209 end if; 3210 3211 Check_Unset_Reference (E); 3212 3213 -- If this is a variable, then set current value. If this is a 3214 -- declared constant of a scalar type with a static expression, 3215 -- indicate that it is always valid. 3216 3217 if not Constant_Present (N) then 3218 if Compile_Time_Known_Value (E) then 3219 Set_Current_Value (Id, E); 3220 end if; 3221 3222 elsif Is_Scalar_Type (T) 3223 and then Is_OK_Static_Expression (E) 3224 then 3225 Set_Is_Known_Valid (Id); 3226 end if; 3227 3228 -- Deal with setting of null flags 3229 3230 if Is_Access_Type (T) then 3231 if Known_Non_Null (E) then 3232 Set_Is_Known_Non_Null (Id, True); 3233 elsif Known_Null (E) 3234 and then not Can_Never_Be_Null (Id) 3235 then 3236 Set_Is_Known_Null (Id, True); 3237 end if; 3238 end if; 3239 3240 -- Check incorrect use of dynamically tagged expressions. 3241 3242 if Is_Tagged_Type (T) then 3243 Check_Dynamically_Tagged_Expression 3244 (Expr => E, 3245 Typ => T, 3246 Related_Nod => N); 3247 end if; 3248 3249 Apply_Scalar_Range_Check (E, T); 3250 Apply_Static_Length_Check (E, T); 3251 3252 if Nkind (Original_Node (N)) = N_Object_Declaration 3253 and then Comes_From_Source (Original_Node (N)) 3254 3255 -- Only call test if needed 3256 3257 and then Restriction_Check_Required (SPARK) 3258 and then not Is_SPARK_Initialization_Expr (E) 3259 then 3260 Check_SPARK_Restriction 3261 ("initialization expression is not appropriate", E); 3262 end if; 3263 end if; 3264 3265 -- If the No_Streams restriction is set, check that the type of the 3266 -- object is not, and does not contain, any subtype derived from 3267 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to 3268 -- Has_Stream just for efficiency reasons. There is no point in 3269 -- spending time on a Has_Stream check if the restriction is not set. 3270 3271 if Restriction_Check_Required (No_Streams) then 3272 if Has_Stream (T) then 3273 Check_Restriction (No_Streams, N); 3274 end if; 3275 end if; 3276 3277 -- Deal with predicate check before we start to do major rewriting. 3278 -- it is OK to initialize and then check the initialized value, since 3279 -- the object goes out of scope if we get a predicate failure. Note 3280 -- that we do this in the analyzer and not the expander because the 3281 -- analyzer does some substantial rewriting in some cases. 3282 3283 -- We need a predicate check if the type has predicates, and if either 3284 -- there is an initializing expression, or for default initialization 3285 -- when we have at least one case of an explicit default initial value. 3286 3287 if not Suppress_Assignment_Checks (N) 3288 and then Present (Predicate_Function (T)) 3289 and then 3290 (Present (E) 3291 or else 3292 Is_Partially_Initialized_Type (T, Include_Implicit => False)) 3293 then 3294 Insert_After (N, 3295 Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc))); 3296 end if; 3297 3298 -- Case of unconstrained type 3299 3300 if Is_Indefinite_Subtype (T) then 3301 3302 -- In SPARK, a declaration of unconstrained type is allowed 3303 -- only for constants of type string. 3304 3305 if Is_String_Type (T) and then not Constant_Present (N) then 3306 Check_SPARK_Restriction 3307 ("declaration of object of unconstrained type not allowed", 3308 N); 3309 end if; 3310 3311 -- Nothing to do in deferred constant case 3312 3313 if Constant_Present (N) and then No (E) then 3314 null; 3315 3316 -- Case of no initialization present 3317 3318 elsif No (E) then 3319 if No_Initialization (N) then 3320 null; 3321 3322 elsif Is_Class_Wide_Type (T) then 3323 Error_Msg_N 3324 ("initialization required in class-wide declaration ", N); 3325 3326 else 3327 Error_Msg_N 3328 ("unconstrained subtype not allowed (need initialization)", 3329 Object_Definition (N)); 3330 3331 if Is_Record_Type (T) and then Has_Discriminants (T) then 3332 Error_Msg_N 3333 ("\provide initial value or explicit discriminant values", 3334 Object_Definition (N)); 3335 3336 Error_Msg_NE 3337 ("\or give default discriminant values for type&", 3338 Object_Definition (N), T); 3339 3340 elsif Is_Array_Type (T) then 3341 Error_Msg_N 3342 ("\provide initial value or explicit array bounds", 3343 Object_Definition (N)); 3344 end if; 3345 end if; 3346 3347 -- Case of initialization present but in error. Set initial 3348 -- expression as absent (but do not make above complaints) 3349 3350 elsif E = Error then 3351 Set_Expression (N, Empty); 3352 E := Empty; 3353 3354 -- Case of initialization present 3355 3356 else 3357 -- Check restrictions in Ada 83 3358 3359 if not Constant_Present (N) then 3360 3361 -- Unconstrained variables not allowed in Ada 83 mode 3362 3363 if Ada_Version = Ada_83 3364 and then Comes_From_Source (Object_Definition (N)) 3365 then 3366 Error_Msg_N 3367 ("(Ada 83) unconstrained variable not allowed", 3368 Object_Definition (N)); 3369 end if; 3370 end if; 3371 3372 -- Now we constrain the variable from the initializing expression 3373 3374 -- If the expression is an aggregate, it has been expanded into 3375 -- individual assignments. Retrieve the actual type from the 3376 -- expanded construct. 3377 3378 if Is_Array_Type (T) 3379 and then No_Initialization (N) 3380 and then Nkind (Original_Node (E)) = N_Aggregate 3381 then 3382 Act_T := Etype (E); 3383 3384 -- In case of class-wide interface object declarations we delay 3385 -- the generation of the equivalent record type declarations until 3386 -- its expansion because there are cases in they are not required. 3387 3388 elsif Is_Interface (T) then 3389 null; 3390 3391 else 3392 Expand_Subtype_From_Expr (N, T, Object_Definition (N), E); 3393 Act_T := Find_Type_Of_Object (Object_Definition (N), N); 3394 end if; 3395 3396 Set_Is_Constr_Subt_For_U_Nominal (Act_T); 3397 3398 if Aliased_Present (N) then 3399 Set_Is_Constr_Subt_For_UN_Aliased (Act_T); 3400 end if; 3401 3402 Freeze_Before (N, Act_T); 3403 Freeze_Before (N, T); 3404 end if; 3405 3406 elsif Is_Array_Type (T) 3407 and then No_Initialization (N) 3408 and then Nkind (Original_Node (E)) = N_Aggregate 3409 then 3410 if not Is_Entity_Name (Object_Definition (N)) then 3411 Act_T := Etype (E); 3412 Check_Compile_Time_Size (Act_T); 3413 3414 if Aliased_Present (N) then 3415 Set_Is_Constr_Subt_For_UN_Aliased (Act_T); 3416 end if; 3417 end if; 3418 3419 -- When the given object definition and the aggregate are specified 3420 -- independently, and their lengths might differ do a length check. 3421 -- This cannot happen if the aggregate is of the form (others =>...) 3422 3423 if not Is_Constrained (T) then 3424 null; 3425 3426 elsif Nkind (E) = N_Raise_Constraint_Error then 3427 3428 -- Aggregate is statically illegal. Place back in declaration 3429 3430 Set_Expression (N, E); 3431 Set_No_Initialization (N, False); 3432 3433 elsif T = Etype (E) then 3434 null; 3435 3436 elsif Nkind (E) = N_Aggregate 3437 and then Present (Component_Associations (E)) 3438 and then Present (Choices (First (Component_Associations (E)))) 3439 and then Nkind (First 3440 (Choices (First (Component_Associations (E))))) = N_Others_Choice 3441 then 3442 null; 3443 3444 else 3445 Apply_Length_Check (E, T); 3446 end if; 3447 3448 -- If the type is limited unconstrained with defaulted discriminants and 3449 -- there is no expression, then the object is constrained by the 3450 -- defaults, so it is worthwhile building the corresponding subtype. 3451 3452 elsif (Is_Limited_Record (T) or else Is_Concurrent_Type (T)) 3453 and then not Is_Constrained (T) 3454 and then Has_Discriminants (T) 3455 then 3456 if No (E) then 3457 Act_T := Build_Default_Subtype (T, N); 3458 else 3459 -- Ada 2005: a limited object may be initialized by means of an 3460 -- aggregate. If the type has default discriminants it has an 3461 -- unconstrained nominal type, Its actual subtype will be obtained 3462 -- from the aggregate, and not from the default discriminants. 3463 3464 Act_T := Etype (E); 3465 end if; 3466 3467 Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc)); 3468 3469 elsif Present (Underlying_Type (T)) 3470 and then not Is_Constrained (Underlying_Type (T)) 3471 and then Has_Discriminants (Underlying_Type (T)) 3472 and then Nkind (E) = N_Function_Call 3473 and then Constant_Present (N) 3474 then 3475 -- The back-end has problems with constants of a discriminated type 3476 -- with defaults, if the initial value is a function call. We 3477 -- generate an intermediate temporary for the result of the call. 3478 -- It is unclear why this should make it acceptable to gcc. ??? 3479 3480 Remove_Side_Effects (E); 3481 3482 -- If this is a constant declaration of an unconstrained type and 3483 -- the initialization is an aggregate, we can use the subtype of the 3484 -- aggregate for the declared entity because it is immutable. 3485 3486 elsif not Is_Constrained (T) 3487 and then Has_Discriminants (T) 3488 and then Constant_Present (N) 3489 and then not Has_Unchecked_Union (T) 3490 and then Nkind (E) = N_Aggregate 3491 then 3492 Act_T := Etype (E); 3493 end if; 3494 3495 -- Check No_Wide_Characters restriction 3496 3497 Check_Wide_Character_Restriction (T, Object_Definition (N)); 3498 3499 -- Indicate this is not set in source. Certainly true for constants, and 3500 -- true for variables so far (will be reset for a variable if and when 3501 -- we encounter a modification in the source). 3502 3503 Set_Never_Set_In_Source (Id, True); 3504 3505 -- Now establish the proper kind and type of the object 3506 3507 if Constant_Present (N) then 3508 Set_Ekind (Id, E_Constant); 3509 Set_Is_True_Constant (Id, True); 3510 3511 else 3512 Set_Ekind (Id, E_Variable); 3513 3514 -- A variable is set as shared passive if it appears in a shared 3515 -- passive package, and is at the outer level. This is not done for 3516 -- entities generated during expansion, because those are always 3517 -- manipulated locally. 3518 3519 if Is_Shared_Passive (Current_Scope) 3520 and then Is_Library_Level_Entity (Id) 3521 and then Comes_From_Source (Id) 3522 then 3523 Set_Is_Shared_Passive (Id); 3524 Check_Shared_Var (Id, T, N); 3525 end if; 3526 3527 -- Set Has_Initial_Value if initializing expression present. Note 3528 -- that if there is no initializing expression, we leave the state 3529 -- of this flag unchanged (usually it will be False, but notably in 3530 -- the case of exception choice variables, it will already be true). 3531 3532 if Present (E) then 3533 Set_Has_Initial_Value (Id, True); 3534 end if; 3535 end if; 3536 3537 -- Initialize alignment and size and capture alignment setting 3538 3539 Init_Alignment (Id); 3540 Init_Esize (Id); 3541 Set_Optimize_Alignment_Flags (Id); 3542 3543 -- Deal with aliased case 3544 3545 if Aliased_Present (N) then 3546 Set_Is_Aliased (Id); 3547 3548 -- If the object is aliased and the type is unconstrained with 3549 -- defaulted discriminants and there is no expression, then the 3550 -- object is constrained by the defaults, so it is worthwhile 3551 -- building the corresponding subtype. 3552 3553 -- Ada 2005 (AI-363): If the aliased object is discriminated and 3554 -- unconstrained, then only establish an actual subtype if the 3555 -- nominal subtype is indefinite. In definite cases the object is 3556 -- unconstrained in Ada 2005. 3557 3558 if No (E) 3559 and then Is_Record_Type (T) 3560 and then not Is_Constrained (T) 3561 and then Has_Discriminants (T) 3562 and then (Ada_Version < Ada_2005 or else Is_Indefinite_Subtype (T)) 3563 then 3564 Set_Actual_Subtype (Id, Build_Default_Subtype (T, N)); 3565 end if; 3566 end if; 3567 3568 -- Now we can set the type of the object 3569 3570 Set_Etype (Id, Act_T); 3571 3572 -- Object is marked to be treated as volatile if type is volatile and 3573 -- we clear the Current_Value setting that may have been set above. 3574 3575 if Treat_As_Volatile (Etype (Id)) then 3576 Set_Treat_As_Volatile (Id); 3577 Set_Current_Value (Id, Empty); 3578 end if; 3579 3580 -- Deal with controlled types 3581 3582 if Has_Controlled_Component (Etype (Id)) 3583 or else Is_Controlled (Etype (Id)) 3584 then 3585 if not Is_Library_Level_Entity (Id) then 3586 Check_Restriction (No_Nested_Finalization, N); 3587 else 3588 Validate_Controlled_Object (Id); 3589 end if; 3590 end if; 3591 3592 if Has_Task (Etype (Id)) then 3593 Check_Restriction (No_Tasking, N); 3594 3595 -- Deal with counting max tasks 3596 3597 -- Nothing to do if inside a generic 3598 3599 if Inside_A_Generic then 3600 null; 3601 3602 -- If library level entity, then count tasks 3603 3604 elsif Is_Library_Level_Entity (Id) then 3605 Check_Restriction (Max_Tasks, N, Count_Tasks (Etype (Id))); 3606 3607 -- If not library level entity, then indicate we don't know max 3608 -- tasks and also check task hierarchy restriction and blocking 3609 -- operation (since starting a task is definitely blocking!) 3610 3611 else 3612 Check_Restriction (Max_Tasks, N); 3613 Check_Restriction (No_Task_Hierarchy, N); 3614 Check_Potentially_Blocking_Operation (N); 3615 end if; 3616 3617 -- A rather specialized test. If we see two tasks being declared 3618 -- of the same type in the same object declaration, and the task 3619 -- has an entry with an address clause, we know that program error 3620 -- will be raised at run time since we can't have two tasks with 3621 -- entries at the same address. 3622 3623 if Is_Task_Type (Etype (Id)) and then More_Ids (N) then 3624 declare 3625 E : Entity_Id; 3626 3627 begin 3628 E := First_Entity (Etype (Id)); 3629 while Present (E) loop 3630 if Ekind (E) = E_Entry 3631 and then Present (Get_Attribute_Definition_Clause 3632 (E, Attribute_Address)) 3633 then 3634 Error_Msg_N 3635 ("??more than one task with same entry address", N); 3636 Error_Msg_N 3637 ("\??Program_Error will be raised at run time", N); 3638 Insert_Action (N, 3639 Make_Raise_Program_Error (Loc, 3640 Reason => PE_Duplicated_Entry_Address)); 3641 exit; 3642 end if; 3643 3644 Next_Entity (E); 3645 end loop; 3646 end; 3647 end if; 3648 end if; 3649 3650 -- Some simple constant-propagation: if the expression is a constant 3651 -- string initialized with a literal, share the literal. This avoids 3652 -- a run-time copy. 3653 3654 if Present (E) 3655 and then Is_Entity_Name (E) 3656 and then Ekind (Entity (E)) = E_Constant 3657 and then Base_Type (Etype (E)) = Standard_String 3658 then 3659 declare 3660 Val : constant Node_Id := Constant_Value (Entity (E)); 3661 begin 3662 if Present (Val) 3663 and then Nkind (Val) = N_String_Literal 3664 then 3665 Rewrite (E, New_Copy (Val)); 3666 end if; 3667 end; 3668 end if; 3669 3670 -- Another optimization: if the nominal subtype is unconstrained and 3671 -- the expression is a function call that returns an unconstrained 3672 -- type, rewrite the declaration as a renaming of the result of the 3673 -- call. The exceptions below are cases where the copy is expected, 3674 -- either by the back end (Aliased case) or by the semantics, as for 3675 -- initializing controlled types or copying tags for classwide types. 3676 3677 if Present (E) 3678 and then Nkind (E) = N_Explicit_Dereference 3679 and then Nkind (Original_Node (E)) = N_Function_Call 3680 and then not Is_Library_Level_Entity (Id) 3681 and then not Is_Constrained (Underlying_Type (T)) 3682 and then not Is_Aliased (Id) 3683 and then not Is_Class_Wide_Type (T) 3684 and then not Is_Controlled (T) 3685 and then not Has_Controlled_Component (Base_Type (T)) 3686 and then Expander_Active 3687 then 3688 Rewrite (N, 3689 Make_Object_Renaming_Declaration (Loc, 3690 Defining_Identifier => Id, 3691 Access_Definition => Empty, 3692 Subtype_Mark => New_Occurrence_Of 3693 (Base_Type (Etype (Id)), Loc), 3694 Name => E)); 3695 3696 Set_Renamed_Object (Id, E); 3697 3698 -- Force generation of debugging information for the constant and for 3699 -- the renamed function call. 3700 3701 Set_Debug_Info_Needed (Id); 3702 Set_Debug_Info_Needed (Entity (Prefix (E))); 3703 end if; 3704 3705 if Present (Prev_Entity) 3706 and then Is_Frozen (Prev_Entity) 3707 and then not Error_Posted (Id) 3708 then 3709 Error_Msg_N ("full constant declaration appears too late", N); 3710 end if; 3711 3712 Check_Eliminated (Id); 3713 3714 -- Deal with setting In_Private_Part flag if in private part 3715 3716 if Ekind (Scope (Id)) = E_Package 3717 and then In_Private_Part (Scope (Id)) 3718 then 3719 Set_In_Private_Part (Id); 3720 end if; 3721 3722 -- Check for violation of No_Local_Timing_Events 3723 3724 if Restriction_Check_Required (No_Local_Timing_Events) 3725 and then not Is_Library_Level_Entity (Id) 3726 and then Is_RTE (Etype (Id), RE_Timing_Event) 3727 then 3728 Check_Restriction (No_Local_Timing_Events, N); 3729 end if; 3730 3731 <<Leave>> 3732 if Has_Aspects (N) then 3733 Analyze_Aspect_Specifications (N, Id); 3734 end if; 3735 3736 Analyze_Dimension (N); 3737 end Analyze_Object_Declaration; 3738 3739 --------------------------- 3740 -- Analyze_Others_Choice -- 3741 --------------------------- 3742 3743 -- Nothing to do for the others choice node itself, the semantic analysis 3744 -- of the others choice will occur as part of the processing of the parent 3745 3746 procedure Analyze_Others_Choice (N : Node_Id) is 3747 pragma Warnings (Off, N); 3748 begin 3749 null; 3750 end Analyze_Others_Choice; 3751 3752 ------------------------------------------- 3753 -- Analyze_Private_Extension_Declaration -- 3754 ------------------------------------------- 3755 3756 procedure Analyze_Private_Extension_Declaration (N : Node_Id) is 3757 T : constant Entity_Id := Defining_Identifier (N); 3758 Indic : constant Node_Id := Subtype_Indication (N); 3759 Parent_Type : Entity_Id; 3760 Parent_Base : Entity_Id; 3761 3762 begin 3763 -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces 3764 3765 if Is_Non_Empty_List (Interface_List (N)) then 3766 declare 3767 Intf : Node_Id; 3768 T : Entity_Id; 3769 3770 begin 3771 Intf := First (Interface_List (N)); 3772 while Present (Intf) loop 3773 T := Find_Type_Of_Subtype_Indic (Intf); 3774 3775 Diagnose_Interface (Intf, T); 3776 Next (Intf); 3777 end loop; 3778 end; 3779 end if; 3780 3781 Generate_Definition (T); 3782 3783 -- For other than Ada 2012, just enter the name in the current scope 3784 3785 if Ada_Version < Ada_2012 then 3786 Enter_Name (T); 3787 3788 -- Ada 2012 (AI05-0162): Enter the name in the current scope handling 3789 -- case of private type that completes an incomplete type. 3790 3791 else 3792 declare 3793 Prev : Entity_Id; 3794 3795 begin 3796 Prev := Find_Type_Name (N); 3797 3798 pragma Assert (Prev = T 3799 or else (Ekind (Prev) = E_Incomplete_Type 3800 and then Present (Full_View (Prev)) 3801 and then Full_View (Prev) = T)); 3802 end; 3803 end if; 3804 3805 Parent_Type := Find_Type_Of_Subtype_Indic (Indic); 3806 Parent_Base := Base_Type (Parent_Type); 3807 3808 if Parent_Type = Any_Type 3809 or else Etype (Parent_Type) = Any_Type 3810 then 3811 Set_Ekind (T, Ekind (Parent_Type)); 3812 Set_Etype (T, Any_Type); 3813 goto Leave; 3814 3815 elsif not Is_Tagged_Type (Parent_Type) then 3816 Error_Msg_N 3817 ("parent of type extension must be a tagged type ", Indic); 3818 goto Leave; 3819 3820 elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then 3821 Error_Msg_N ("premature derivation of incomplete type", Indic); 3822 goto Leave; 3823 3824 elsif Is_Concurrent_Type (Parent_Type) then 3825 Error_Msg_N 3826 ("parent type of a private extension cannot be " 3827 & "a synchronized tagged type (RM 3.9.1 (3/1))", N); 3828 3829 Set_Etype (T, Any_Type); 3830 Set_Ekind (T, E_Limited_Private_Type); 3831 Set_Private_Dependents (T, New_Elmt_List); 3832 Set_Error_Posted (T); 3833 goto Leave; 3834 end if; 3835 3836 -- Perhaps the parent type should be changed to the class-wide type's 3837 -- specific type in this case to prevent cascading errors ??? 3838 3839 if Is_Class_Wide_Type (Parent_Type) then 3840 Error_Msg_N 3841 ("parent of type extension must not be a class-wide type", Indic); 3842 goto Leave; 3843 end if; 3844 3845 if (not Is_Package_Or_Generic_Package (Current_Scope) 3846 and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration) 3847 or else In_Private_Part (Current_Scope) 3848 3849 then 3850 Error_Msg_N ("invalid context for private extension", N); 3851 end if; 3852 3853 -- Set common attributes 3854 3855 Set_Is_Pure (T, Is_Pure (Current_Scope)); 3856 Set_Scope (T, Current_Scope); 3857 Set_Ekind (T, E_Record_Type_With_Private); 3858 Init_Size_Align (T); 3859 3860 Set_Etype (T, Parent_Base); 3861 Set_Has_Task (T, Has_Task (Parent_Base)); 3862 3863 Set_Convention (T, Convention (Parent_Type)); 3864 Set_First_Rep_Item (T, First_Rep_Item (Parent_Type)); 3865 Set_Is_First_Subtype (T); 3866 Make_Class_Wide_Type (T); 3867 3868 if Unknown_Discriminants_Present (N) then 3869 Set_Discriminant_Constraint (T, No_Elist); 3870 end if; 3871 3872 Build_Derived_Record_Type (N, Parent_Type, T); 3873 3874 -- Propagate inherited invariant information. The new type has 3875 -- invariants, if the parent type has inheritable invariants, 3876 -- and these invariants can in turn be inherited. 3877 3878 if Has_Inheritable_Invariants (Parent_Type) then 3879 Set_Has_Inheritable_Invariants (T); 3880 Set_Has_Invariants (T); 3881 end if; 3882 3883 -- Ada 2005 (AI-443): Synchronized private extension or a rewritten 3884 -- synchronized formal derived type. 3885 3886 if Ada_Version >= Ada_2005 3887 and then Synchronized_Present (N) 3888 then 3889 Set_Is_Limited_Record (T); 3890 3891 -- Formal derived type case 3892 3893 if Is_Generic_Type (T) then 3894 3895 -- The parent must be a tagged limited type or a synchronized 3896 -- interface. 3897 3898 if (not Is_Tagged_Type (Parent_Type) 3899 or else not Is_Limited_Type (Parent_Type)) 3900 and then 3901 (not Is_Interface (Parent_Type) 3902 or else not Is_Synchronized_Interface (Parent_Type)) 3903 then 3904 Error_Msg_NE ("parent type of & must be tagged limited " & 3905 "or synchronized", N, T); 3906 end if; 3907 3908 -- The progenitors (if any) must be limited or synchronized 3909 -- interfaces. 3910 3911 if Present (Interfaces (T)) then 3912 declare 3913 Iface : Entity_Id; 3914 Iface_Elmt : Elmt_Id; 3915 3916 begin 3917 Iface_Elmt := First_Elmt (Interfaces (T)); 3918 while Present (Iface_Elmt) loop 3919 Iface := Node (Iface_Elmt); 3920 3921 if not Is_Limited_Interface (Iface) 3922 and then not Is_Synchronized_Interface (Iface) 3923 then 3924 Error_Msg_NE ("progenitor & must be limited " & 3925 "or synchronized", N, Iface); 3926 end if; 3927 3928 Next_Elmt (Iface_Elmt); 3929 end loop; 3930 end; 3931 end if; 3932 3933 -- Regular derived extension, the parent must be a limited or 3934 -- synchronized interface. 3935 3936 else 3937 if not Is_Interface (Parent_Type) 3938 or else (not Is_Limited_Interface (Parent_Type) 3939 and then 3940 not Is_Synchronized_Interface (Parent_Type)) 3941 then 3942 Error_Msg_NE 3943 ("parent type of & must be limited interface", N, T); 3944 end if; 3945 end if; 3946 3947 -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private 3948 -- extension with a synchronized parent must be explicitly declared 3949 -- synchronized, because the full view will be a synchronized type. 3950 -- This must be checked before the check for limited types below, 3951 -- to ensure that types declared limited are not allowed to extend 3952 -- synchronized interfaces. 3953 3954 elsif Is_Interface (Parent_Type) 3955 and then Is_Synchronized_Interface (Parent_Type) 3956 and then not Synchronized_Present (N) 3957 then 3958 Error_Msg_NE 3959 ("private extension of& must be explicitly synchronized", 3960 N, Parent_Type); 3961 3962 elsif Limited_Present (N) then 3963 Set_Is_Limited_Record (T); 3964 3965 if not Is_Limited_Type (Parent_Type) 3966 and then 3967 (not Is_Interface (Parent_Type) 3968 or else not Is_Limited_Interface (Parent_Type)) 3969 then 3970 Error_Msg_NE ("parent type& of limited extension must be limited", 3971 N, Parent_Type); 3972 end if; 3973 end if; 3974 3975 <<Leave>> 3976 if Has_Aspects (N) then 3977 Analyze_Aspect_Specifications (N, T); 3978 end if; 3979 end Analyze_Private_Extension_Declaration; 3980 3981 --------------------------------- 3982 -- Analyze_Subtype_Declaration -- 3983 --------------------------------- 3984 3985 procedure Analyze_Subtype_Declaration 3986 (N : Node_Id; 3987 Skip : Boolean := False) 3988 is 3989 Id : constant Entity_Id := Defining_Identifier (N); 3990 T : Entity_Id; 3991 R_Checks : Check_Result; 3992 3993 begin 3994 Generate_Definition (Id); 3995 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3996 Init_Size_Align (Id); 3997 3998 -- The following guard condition on Enter_Name is to handle cases where 3999 -- the defining identifier has already been entered into the scope but 4000 -- the declaration as a whole needs to be analyzed. 4001 4002 -- This case in particular happens for derived enumeration types. The 4003 -- derived enumeration type is processed as an inserted enumeration type 4004 -- declaration followed by a rewritten subtype declaration. The defining 4005 -- identifier, however, is entered into the name scope very early in the 4006 -- processing of the original type declaration and therefore needs to be 4007 -- avoided here, when the created subtype declaration is analyzed. (See 4008 -- Build_Derived_Types) 4009 4010 -- This also happens when the full view of a private type is derived 4011 -- type with constraints. In this case the entity has been introduced 4012 -- in the private declaration. 4013 4014 if Skip 4015 or else (Present (Etype (Id)) 4016 and then (Is_Private_Type (Etype (Id)) 4017 or else Is_Task_Type (Etype (Id)) 4018 or else Is_Rewrite_Substitution (N))) 4019 then 4020 null; 4021 4022 else 4023 Enter_Name (Id); 4024 end if; 4025 4026 T := Process_Subtype (Subtype_Indication (N), N, Id, 'P'); 4027 4028 -- Class-wide equivalent types of records with unknown discriminants 4029 -- involve the generation of an itype which serves as the private view 4030 -- of a constrained record subtype. In such cases the base type of the 4031 -- current subtype we are processing is the private itype. Use the full 4032 -- of the private itype when decorating various attributes. 4033 4034 if Is_Itype (T) 4035 and then Is_Private_Type (T) 4036 and then Present (Full_View (T)) 4037 then 4038 T := Full_View (T); 4039 end if; 4040 4041 -- Inherit common attributes 4042 4043 Set_Is_Volatile (Id, Is_Volatile (T)); 4044 Set_Treat_As_Volatile (Id, Treat_As_Volatile (T)); 4045 Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T))); 4046 Set_Convention (Id, Convention (T)); 4047 4048 -- If ancestor has predicates then so does the subtype, and in addition 4049 -- we must delay the freeze to properly arrange predicate inheritance. 4050 4051 -- The Ancestor_Type test is a big kludge, there seem to be cases in 4052 -- which T = ID, so the above tests and assignments do nothing??? 4053 4054 if Has_Predicates (T) 4055 or else (Present (Ancestor_Subtype (T)) 4056 and then Has_Predicates (Ancestor_Subtype (T))) 4057 then 4058 Set_Has_Predicates (Id); 4059 Set_Has_Delayed_Freeze (Id); 4060 end if; 4061 4062 -- Subtype of Boolean cannot have a constraint in SPARK 4063 4064 if Is_Boolean_Type (T) 4065 and then Nkind (Subtype_Indication (N)) = N_Subtype_Indication 4066 then 4067 Check_SPARK_Restriction 4068 ("subtype of Boolean cannot have constraint", N); 4069 end if; 4070 4071 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then 4072 declare 4073 Cstr : constant Node_Id := Constraint (Subtype_Indication (N)); 4074 One_Cstr : Node_Id; 4075 Low : Node_Id; 4076 High : Node_Id; 4077 4078 begin 4079 if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint then 4080 One_Cstr := First (Constraints (Cstr)); 4081 while Present (One_Cstr) loop 4082 4083 -- Index or discriminant constraint in SPARK must be a 4084 -- subtype mark. 4085 4086 if not 4087 Nkind_In (One_Cstr, N_Identifier, N_Expanded_Name) 4088 then 4089 Check_SPARK_Restriction 4090 ("subtype mark required", One_Cstr); 4091 4092 -- String subtype must have a lower bound of 1 in SPARK. 4093 -- Note that we do not need to test for the non-static case 4094 -- here, since that was already taken care of in 4095 -- Process_Range_Expr_In_Decl. 4096 4097 elsif Base_Type (T) = Standard_String then 4098 Get_Index_Bounds (One_Cstr, Low, High); 4099 4100 if Is_OK_Static_Expression (Low) 4101 and then Expr_Value (Low) /= 1 4102 then 4103 Check_SPARK_Restriction 4104 ("String subtype must have lower bound of 1", N); 4105 end if; 4106 end if; 4107 4108 Next (One_Cstr); 4109 end loop; 4110 end if; 4111 end; 4112 end if; 4113 4114 -- In the case where there is no constraint given in the subtype 4115 -- indication, Process_Subtype just returns the Subtype_Mark, so its 4116 -- semantic attributes must be established here. 4117 4118 if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then 4119 Set_Etype (Id, Base_Type (T)); 4120 4121 -- Subtype of unconstrained array without constraint is not allowed 4122 -- in SPARK. 4123 4124 if Is_Array_Type (T) 4125 and then not Is_Constrained (T) 4126 then 4127 Check_SPARK_Restriction 4128 ("subtype of unconstrained array must have constraint", N); 4129 end if; 4130 4131 case Ekind (T) is 4132 when Array_Kind => 4133 Set_Ekind (Id, E_Array_Subtype); 4134 Copy_Array_Subtype_Attributes (Id, T); 4135 4136 when Decimal_Fixed_Point_Kind => 4137 Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype); 4138 Set_Digits_Value (Id, Digits_Value (T)); 4139 Set_Delta_Value (Id, Delta_Value (T)); 4140 Set_Scale_Value (Id, Scale_Value (T)); 4141 Set_Small_Value (Id, Small_Value (T)); 4142 Set_Scalar_Range (Id, Scalar_Range (T)); 4143 Set_Machine_Radix_10 (Id, Machine_Radix_10 (T)); 4144 Set_Is_Constrained (Id, Is_Constrained (T)); 4145 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 4146 Set_RM_Size (Id, RM_Size (T)); 4147 4148 when Enumeration_Kind => 4149 Set_Ekind (Id, E_Enumeration_Subtype); 4150 Set_First_Literal (Id, First_Literal (Base_Type (T))); 4151 Set_Scalar_Range (Id, Scalar_Range (T)); 4152 Set_Is_Character_Type (Id, Is_Character_Type (T)); 4153 Set_Is_Constrained (Id, Is_Constrained (T)); 4154 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 4155 Set_RM_Size (Id, RM_Size (T)); 4156 4157 when Ordinary_Fixed_Point_Kind => 4158 Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype); 4159 Set_Scalar_Range (Id, Scalar_Range (T)); 4160 Set_Small_Value (Id, Small_Value (T)); 4161 Set_Delta_Value (Id, Delta_Value (T)); 4162 Set_Is_Constrained (Id, Is_Constrained (T)); 4163 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 4164 Set_RM_Size (Id, RM_Size (T)); 4165 4166 when Float_Kind => 4167 Set_Ekind (Id, E_Floating_Point_Subtype); 4168 Set_Scalar_Range (Id, Scalar_Range (T)); 4169 Set_Digits_Value (Id, Digits_Value (T)); 4170 Set_Is_Constrained (Id, Is_Constrained (T)); 4171 4172 when Signed_Integer_Kind => 4173 Set_Ekind (Id, E_Signed_Integer_Subtype); 4174 Set_Scalar_Range (Id, Scalar_Range (T)); 4175 Set_Is_Constrained (Id, Is_Constrained (T)); 4176 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 4177 Set_RM_Size (Id, RM_Size (T)); 4178 4179 when Modular_Integer_Kind => 4180 Set_Ekind (Id, E_Modular_Integer_Subtype); 4181 Set_Scalar_Range (Id, Scalar_Range (T)); 4182 Set_Is_Constrained (Id, Is_Constrained (T)); 4183 Set_Is_Known_Valid (Id, Is_Known_Valid (T)); 4184 Set_RM_Size (Id, RM_Size (T)); 4185 4186 when Class_Wide_Kind => 4187 Set_Ekind (Id, E_Class_Wide_Subtype); 4188 Set_First_Entity (Id, First_Entity (T)); 4189 Set_Last_Entity (Id, Last_Entity (T)); 4190 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 4191 Set_Cloned_Subtype (Id, T); 4192 Set_Is_Tagged_Type (Id, True); 4193 Set_Has_Unknown_Discriminants 4194 (Id, True); 4195 4196 if Ekind (T) = E_Class_Wide_Subtype then 4197 Set_Equivalent_Type (Id, Equivalent_Type (T)); 4198 end if; 4199 4200 when E_Record_Type | E_Record_Subtype => 4201 Set_Ekind (Id, E_Record_Subtype); 4202 4203 if Ekind (T) = E_Record_Subtype 4204 and then Present (Cloned_Subtype (T)) 4205 then 4206 Set_Cloned_Subtype (Id, Cloned_Subtype (T)); 4207 else 4208 Set_Cloned_Subtype (Id, T); 4209 end if; 4210 4211 Set_First_Entity (Id, First_Entity (T)); 4212 Set_Last_Entity (Id, Last_Entity (T)); 4213 Set_Has_Discriminants (Id, Has_Discriminants (T)); 4214 Set_Is_Constrained (Id, Is_Constrained (T)); 4215 Set_Is_Limited_Record (Id, Is_Limited_Record (T)); 4216 Set_Has_Implicit_Dereference 4217 (Id, Has_Implicit_Dereference (T)); 4218 Set_Has_Unknown_Discriminants 4219 (Id, Has_Unknown_Discriminants (T)); 4220 4221 if Has_Discriminants (T) then 4222 Set_Discriminant_Constraint 4223 (Id, Discriminant_Constraint (T)); 4224 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 4225 4226 elsif Has_Unknown_Discriminants (Id) then 4227 Set_Discriminant_Constraint (Id, No_Elist); 4228 end if; 4229 4230 if Is_Tagged_Type (T) then 4231 Set_Is_Tagged_Type (Id); 4232 Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); 4233 Set_Direct_Primitive_Operations 4234 (Id, Direct_Primitive_Operations (T)); 4235 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 4236 4237 if Is_Interface (T) then 4238 Set_Is_Interface (Id); 4239 Set_Is_Limited_Interface (Id, Is_Limited_Interface (T)); 4240 end if; 4241 end if; 4242 4243 when Private_Kind => 4244 Set_Ekind (Id, Subtype_Kind (Ekind (T))); 4245 Set_Has_Discriminants (Id, Has_Discriminants (T)); 4246 Set_Is_Constrained (Id, Is_Constrained (T)); 4247 Set_First_Entity (Id, First_Entity (T)); 4248 Set_Last_Entity (Id, Last_Entity (T)); 4249 Set_Private_Dependents (Id, New_Elmt_List); 4250 Set_Is_Limited_Record (Id, Is_Limited_Record (T)); 4251 Set_Has_Implicit_Dereference 4252 (Id, Has_Implicit_Dereference (T)); 4253 Set_Has_Unknown_Discriminants 4254 (Id, Has_Unknown_Discriminants (T)); 4255 Set_Known_To_Have_Preelab_Init 4256 (Id, Known_To_Have_Preelab_Init (T)); 4257 4258 if Is_Tagged_Type (T) then 4259 Set_Is_Tagged_Type (Id); 4260 Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); 4261 Set_Class_Wide_Type (Id, Class_Wide_Type (T)); 4262 Set_Direct_Primitive_Operations (Id, 4263 Direct_Primitive_Operations (T)); 4264 end if; 4265 4266 -- In general the attributes of the subtype of a private type 4267 -- are the attributes of the partial view of parent. However, 4268 -- the full view may be a discriminated type, and the subtype 4269 -- must share the discriminant constraint to generate correct 4270 -- calls to initialization procedures. 4271 4272 if Has_Discriminants (T) then 4273 Set_Discriminant_Constraint 4274 (Id, Discriminant_Constraint (T)); 4275 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 4276 4277 elsif Present (Full_View (T)) 4278 and then Has_Discriminants (Full_View (T)) 4279 then 4280 Set_Discriminant_Constraint 4281 (Id, Discriminant_Constraint (Full_View (T))); 4282 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 4283 4284 -- This would seem semantically correct, but apparently 4285 -- generates spurious errors about missing components ??? 4286 4287 -- Set_Has_Discriminants (Id); 4288 end if; 4289 4290 Prepare_Private_Subtype_Completion (Id, N); 4291 4292 -- If this is the subtype of a constrained private type with 4293 -- discriminants that has got a full view and we also have 4294 -- built a completion just above, show that the completion 4295 -- is a clone of the full view to the back-end. 4296 4297 if Has_Discriminants (T) 4298 and then not Has_Unknown_Discriminants (T) 4299 and then not Is_Empty_Elmt_List (Discriminant_Constraint (T)) 4300 and then Present (Full_View (T)) 4301 and then Present (Full_View (Id)) 4302 then 4303 Set_Cloned_Subtype (Full_View (Id), Full_View (T)); 4304 end if; 4305 4306 when Access_Kind => 4307 Set_Ekind (Id, E_Access_Subtype); 4308 Set_Is_Constrained (Id, Is_Constrained (T)); 4309 Set_Is_Access_Constant 4310 (Id, Is_Access_Constant (T)); 4311 Set_Directly_Designated_Type 4312 (Id, Designated_Type (T)); 4313 Set_Can_Never_Be_Null (Id, Can_Never_Be_Null (T)); 4314 4315 -- A Pure library_item must not contain the declaration of a 4316 -- named access type, except within a subprogram, generic 4317 -- subprogram, task unit, or protected unit, or if it has 4318 -- a specified Storage_Size of zero (RM05-10.2.1(15.4-15.5)). 4319 4320 if Comes_From_Source (Id) 4321 and then In_Pure_Unit 4322 and then not In_Subprogram_Task_Protected_Unit 4323 and then not No_Pool_Assigned (Id) 4324 then 4325 Error_Msg_N 4326 ("named access types not allowed in pure unit", N); 4327 end if; 4328 4329 when Concurrent_Kind => 4330 Set_Ekind (Id, Subtype_Kind (Ekind (T))); 4331 Set_Corresponding_Record_Type (Id, 4332 Corresponding_Record_Type (T)); 4333 Set_First_Entity (Id, First_Entity (T)); 4334 Set_First_Private_Entity (Id, First_Private_Entity (T)); 4335 Set_Has_Discriminants (Id, Has_Discriminants (T)); 4336 Set_Is_Constrained (Id, Is_Constrained (T)); 4337 Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); 4338 Set_Last_Entity (Id, Last_Entity (T)); 4339 4340 if Has_Discriminants (T) then 4341 Set_Discriminant_Constraint (Id, 4342 Discriminant_Constraint (T)); 4343 Set_Stored_Constraint_From_Discriminant_Constraint (Id); 4344 end if; 4345 4346 when E_Incomplete_Type => 4347 if Ada_Version >= Ada_2005 then 4348 4349 -- In Ada 2005 an incomplete type can be explicitly tagged: 4350 -- propagate indication. 4351 4352 Set_Ekind (Id, E_Incomplete_Subtype); 4353 Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); 4354 Set_Private_Dependents (Id, New_Elmt_List); 4355 4356 -- Ada 2005 (AI-412): Decorate an incomplete subtype of an 4357 -- incomplete type visible through a limited with clause. 4358 4359 if From_With_Type (T) 4360 and then Present (Non_Limited_View (T)) 4361 then 4362 Set_From_With_Type (Id); 4363 Set_Non_Limited_View (Id, Non_Limited_View (T)); 4364 4365 -- Ada 2005 (AI-412): Add the regular incomplete subtype 4366 -- to the private dependents of the original incomplete 4367 -- type for future transformation. 4368 4369 else 4370 Append_Elmt (Id, Private_Dependents (T)); 4371 end if; 4372 4373 -- If the subtype name denotes an incomplete type an error 4374 -- was already reported by Process_Subtype. 4375 4376 else 4377 Set_Etype (Id, Any_Type); 4378 end if; 4379 4380 when others => 4381 raise Program_Error; 4382 end case; 4383 end if; 4384 4385 if Etype (Id) = Any_Type then 4386 goto Leave; 4387 end if; 4388 4389 -- Some common processing on all types 4390 4391 Set_Size_Info (Id, T); 4392 Set_First_Rep_Item (Id, First_Rep_Item (T)); 4393 4394 -- If the parent type is a generic actual, so is the subtype. This may 4395 -- happen in a nested instance. Why Comes_From_Source test??? 4396 4397 if not Comes_From_Source (N) then 4398 Set_Is_Generic_Actual_Type (Id, Is_Generic_Actual_Type (T)); 4399 end if; 4400 4401 T := Etype (Id); 4402 4403 Set_Is_Immediately_Visible (Id, True); 4404 Set_Depends_On_Private (Id, Has_Private_Component (T)); 4405 Set_Is_Descendent_Of_Address (Id, Is_Descendent_Of_Address (T)); 4406 4407 if Is_Interface (T) then 4408 Set_Is_Interface (Id); 4409 end if; 4410 4411 if Present (Generic_Parent_Type (N)) 4412 and then 4413 (Nkind 4414 (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration 4415 or else Nkind 4416 (Formal_Type_Definition (Parent (Generic_Parent_Type (N)))) 4417 /= N_Formal_Private_Type_Definition) 4418 then 4419 if Is_Tagged_Type (Id) then 4420 4421 -- If this is a generic actual subtype for a synchronized type, 4422 -- the primitive operations are those of the corresponding record 4423 -- for which there is a separate subtype declaration. 4424 4425 if Is_Concurrent_Type (Id) then 4426 null; 4427 elsif Is_Class_Wide_Type (Id) then 4428 Derive_Subprograms (Generic_Parent_Type (N), Id, Etype (T)); 4429 else 4430 Derive_Subprograms (Generic_Parent_Type (N), Id, T); 4431 end if; 4432 4433 elsif Scope (Etype (Id)) /= Standard_Standard then 4434 Derive_Subprograms (Generic_Parent_Type (N), Id); 4435 end if; 4436 end if; 4437 4438 if Is_Private_Type (T) 4439 and then Present (Full_View (T)) 4440 then 4441 Conditional_Delay (Id, Full_View (T)); 4442 4443 -- The subtypes of components or subcomponents of protected types 4444 -- do not need freeze nodes, which would otherwise appear in the 4445 -- wrong scope (before the freeze node for the protected type). The 4446 -- proper subtypes are those of the subcomponents of the corresponding 4447 -- record. 4448 4449 elsif Ekind (Scope (Id)) /= E_Protected_Type 4450 and then Present (Scope (Scope (Id))) -- error defense! 4451 and then Ekind (Scope (Scope (Id))) /= E_Protected_Type 4452 then 4453 Conditional_Delay (Id, T); 4454 end if; 4455 4456 -- Check that Constraint_Error is raised for a scalar subtype indication 4457 -- when the lower or upper bound of a non-null range lies outside the 4458 -- range of the type mark. 4459 4460 if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then 4461 if Is_Scalar_Type (Etype (Id)) 4462 and then Scalar_Range (Id) /= 4463 Scalar_Range (Etype (Subtype_Mark 4464 (Subtype_Indication (N)))) 4465 then 4466 Apply_Range_Check 4467 (Scalar_Range (Id), 4468 Etype (Subtype_Mark (Subtype_Indication (N)))); 4469 4470 -- In the array case, check compatibility for each index 4471 4472 elsif Is_Array_Type (Etype (Id)) 4473 and then Present (First_Index (Id)) 4474 then 4475 -- This really should be a subprogram that finds the indications 4476 -- to check??? 4477 4478 declare 4479 Subt_Index : Node_Id := First_Index (Id); 4480 Target_Index : Node_Id := 4481 First_Index (Etype 4482 (Subtype_Mark (Subtype_Indication (N)))); 4483 Has_Dyn_Chk : Boolean := Has_Dynamic_Range_Check (N); 4484 4485 begin 4486 while Present (Subt_Index) loop 4487 if ((Nkind (Subt_Index) = N_Identifier 4488 and then Ekind (Entity (Subt_Index)) in Scalar_Kind) 4489 or else Nkind (Subt_Index) = N_Subtype_Indication) 4490 and then 4491 Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range 4492 then 4493 declare 4494 Target_Typ : constant Entity_Id := 4495 Etype (Target_Index); 4496 begin 4497 R_Checks := 4498 Get_Range_Checks 4499 (Scalar_Range (Etype (Subt_Index)), 4500 Target_Typ, 4501 Etype (Subt_Index), 4502 Defining_Identifier (N)); 4503 4504 -- Reset Has_Dynamic_Range_Check on the subtype to 4505 -- prevent elision of the index check due to a dynamic 4506 -- check generated for a preceding index (needed since 4507 -- Insert_Range_Checks tries to avoid generating 4508 -- redundant checks on a given declaration). 4509 4510 Set_Has_Dynamic_Range_Check (N, False); 4511 4512 Insert_Range_Checks 4513 (R_Checks, 4514 N, 4515 Target_Typ, 4516 Sloc (Defining_Identifier (N))); 4517 4518 -- Record whether this index involved a dynamic check 4519 4520 Has_Dyn_Chk := 4521 Has_Dyn_Chk or else Has_Dynamic_Range_Check (N); 4522 end; 4523 end if; 4524 4525 Next_Index (Subt_Index); 4526 Next_Index (Target_Index); 4527 end loop; 4528 4529 -- Finally, mark whether the subtype involves dynamic checks 4530 4531 Set_Has_Dynamic_Range_Check (N, Has_Dyn_Chk); 4532 end; 4533 end if; 4534 end if; 4535 4536 -- Make sure that generic actual types are properly frozen. The subtype 4537 -- is marked as a generic actual type when the enclosing instance is 4538 -- analyzed, so here we identify the subtype from the tree structure. 4539 4540 if Expander_Active 4541 and then Is_Generic_Actual_Type (Id) 4542 and then In_Instance 4543 and then not Comes_From_Source (N) 4544 and then Nkind (Subtype_Indication (N)) /= N_Subtype_Indication 4545 and then Is_Frozen (T) 4546 then 4547 Freeze_Before (N, Id); 4548 end if; 4549 4550 Set_Optimize_Alignment_Flags (Id); 4551 Check_Eliminated (Id); 4552 4553 <<Leave>> 4554 if Has_Aspects (N) then 4555 Analyze_Aspect_Specifications (N, Id); 4556 end if; 4557 4558 Analyze_Dimension (N); 4559 end Analyze_Subtype_Declaration; 4560 4561 -------------------------------- 4562 -- Analyze_Subtype_Indication -- 4563 -------------------------------- 4564 4565 procedure Analyze_Subtype_Indication (N : Node_Id) is 4566 T : constant Entity_Id := Subtype_Mark (N); 4567 R : constant Node_Id := Range_Expression (Constraint (N)); 4568 4569 begin 4570 Analyze (T); 4571 4572 if R /= Error then 4573 Analyze (R); 4574 Set_Etype (N, Etype (R)); 4575 Resolve (R, Entity (T)); 4576 else 4577 Set_Error_Posted (R); 4578 Set_Error_Posted (T); 4579 end if; 4580 end Analyze_Subtype_Indication; 4581 4582 -------------------------- 4583 -- Analyze_Variant_Part -- 4584 -------------------------- 4585 4586 procedure Analyze_Variant_Part (N : Node_Id) is 4587 4588 procedure Non_Static_Choice_Error (Choice : Node_Id); 4589 -- Error routine invoked by the generic instantiation below when the 4590 -- variant part has a non static choice. 4591 4592 procedure Process_Declarations (Variant : Node_Id); 4593 -- Analyzes all the declarations associated with a Variant. Needed by 4594 -- the generic instantiation below. 4595 4596 package Variant_Choices_Processing is new 4597 Generic_Choices_Processing 4598 (Get_Alternatives => Variants, 4599 Get_Choices => Discrete_Choices, 4600 Process_Empty_Choice => No_OP, 4601 Process_Non_Static_Choice => Non_Static_Choice_Error, 4602 Process_Associated_Node => Process_Declarations); 4603 use Variant_Choices_Processing; 4604 -- Instantiation of the generic choice processing package 4605 4606 ----------------------------- 4607 -- Non_Static_Choice_Error -- 4608 ----------------------------- 4609 4610 procedure Non_Static_Choice_Error (Choice : Node_Id) is 4611 begin 4612 Flag_Non_Static_Expr 4613 ("choice given in variant part is not static!", Choice); 4614 end Non_Static_Choice_Error; 4615 4616 -------------------------- 4617 -- Process_Declarations -- 4618 -------------------------- 4619 4620 procedure Process_Declarations (Variant : Node_Id) is 4621 begin 4622 if not Null_Present (Component_List (Variant)) then 4623 Analyze_Declarations (Component_Items (Component_List (Variant))); 4624 4625 if Present (Variant_Part (Component_List (Variant))) then 4626 Analyze (Variant_Part (Component_List (Variant))); 4627 end if; 4628 end if; 4629 end Process_Declarations; 4630 4631 -- Local Variables 4632 4633 Discr_Name : Node_Id; 4634 Discr_Type : Entity_Id; 4635 4636 Dont_Care : Boolean; 4637 Others_Present : Boolean := False; 4638 4639 pragma Warnings (Off, Dont_Care); 4640 pragma Warnings (Off, Others_Present); 4641 -- We don't care about the assigned values of any of these 4642 4643 -- Start of processing for Analyze_Variant_Part 4644 4645 begin 4646 Discr_Name := Name (N); 4647 Analyze (Discr_Name); 4648 4649 -- If Discr_Name bad, get out (prevent cascaded errors) 4650 4651 if Etype (Discr_Name) = Any_Type then 4652 return; 4653 end if; 4654 4655 -- Check invalid discriminant in variant part 4656 4657 if Ekind (Entity (Discr_Name)) /= E_Discriminant then 4658 Error_Msg_N ("invalid discriminant name in variant part", Discr_Name); 4659 end if; 4660 4661 Discr_Type := Etype (Entity (Discr_Name)); 4662 4663 if not Is_Discrete_Type (Discr_Type) then 4664 Error_Msg_N 4665 ("discriminant in a variant part must be of a discrete type", 4666 Name (N)); 4667 return; 4668 end if; 4669 4670 -- Call the instantiated Analyze_Choices which does the rest of the work 4671 4672 Analyze_Choices (N, Discr_Type, Dont_Care, Others_Present); 4673 end Analyze_Variant_Part; 4674 4675 ---------------------------- 4676 -- Array_Type_Declaration -- 4677 ---------------------------- 4678 4679 procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is 4680 Component_Def : constant Node_Id := Component_Definition (Def); 4681 Component_Typ : constant Node_Id := Subtype_Indication (Component_Def); 4682 Element_Type : Entity_Id; 4683 Implicit_Base : Entity_Id; 4684 Index : Node_Id; 4685 Related_Id : Entity_Id := Empty; 4686 Nb_Index : Nat; 4687 P : constant Node_Id := Parent (Def); 4688 Priv : Entity_Id; 4689 4690 begin 4691 if Nkind (Def) = N_Constrained_Array_Definition then 4692 Index := First (Discrete_Subtype_Definitions (Def)); 4693 else 4694 Index := First (Subtype_Marks (Def)); 4695 end if; 4696 4697 -- Find proper names for the implicit types which may be public. In case 4698 -- of anonymous arrays we use the name of the first object of that type 4699 -- as prefix. 4700 4701 if No (T) then 4702 Related_Id := Defining_Identifier (P); 4703 else 4704 Related_Id := T; 4705 end if; 4706 4707 Nb_Index := 1; 4708 while Present (Index) loop 4709 Analyze (Index); 4710 4711 if not Nkind_In (Index, N_Identifier, N_Expanded_Name) then 4712 Check_SPARK_Restriction ("subtype mark required", Index); 4713 end if; 4714 4715 -- Add a subtype declaration for each index of private array type 4716 -- declaration whose etype is also private. For example: 4717 4718 -- package Pkg is 4719 -- type Index is private; 4720 -- private 4721 -- type Table is array (Index) of ... 4722 -- end; 4723 4724 -- This is currently required by the expander for the internally 4725 -- generated equality subprogram of records with variant parts in 4726 -- which the etype of some component is such private type. 4727 4728 if Ekind (Current_Scope) = E_Package 4729 and then In_Private_Part (Current_Scope) 4730 and then Has_Private_Declaration (Etype (Index)) 4731 then 4732 declare 4733 Loc : constant Source_Ptr := Sloc (Def); 4734 New_E : Entity_Id; 4735 Decl : Entity_Id; 4736 4737 begin 4738 New_E := Make_Temporary (Loc, 'T'); 4739 Set_Is_Internal (New_E); 4740 4741 Decl := 4742 Make_Subtype_Declaration (Loc, 4743 Defining_Identifier => New_E, 4744 Subtype_Indication => 4745 New_Occurrence_Of (Etype (Index), Loc)); 4746 4747 Insert_Before (Parent (Def), Decl); 4748 Analyze (Decl); 4749 Set_Etype (Index, New_E); 4750 4751 -- If the index is a range the Entity attribute is not 4752 -- available. Example: 4753 4754 -- package Pkg is 4755 -- type T is private; 4756 -- private 4757 -- type T is new Natural; 4758 -- Table : array (T(1) .. T(10)) of Boolean; 4759 -- end Pkg; 4760 4761 if Nkind (Index) /= N_Range then 4762 Set_Entity (Index, New_E); 4763 end if; 4764 end; 4765 end if; 4766 4767 Make_Index (Index, P, Related_Id, Nb_Index); 4768 4769 -- Check error of subtype with predicate for index type 4770 4771 Bad_Predicated_Subtype_Use 4772 ("subtype& has predicate, not allowed as index subtype", 4773 Index, Etype (Index)); 4774 4775 -- Move to next index 4776 4777 Next_Index (Index); 4778 Nb_Index := Nb_Index + 1; 4779 end loop; 4780 4781 -- Process subtype indication if one is present 4782 4783 if Present (Component_Typ) then 4784 Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C'); 4785 4786 Set_Etype (Component_Typ, Element_Type); 4787 4788 if not Nkind_In (Component_Typ, N_Identifier, N_Expanded_Name) then 4789 Check_SPARK_Restriction ("subtype mark required", Component_Typ); 4790 end if; 4791 4792 -- Ada 2005 (AI-230): Access Definition case 4793 4794 else pragma Assert (Present (Access_Definition (Component_Def))); 4795 4796 -- Indicate that the anonymous access type is created by the 4797 -- array type declaration. 4798 4799 Element_Type := Access_Definition 4800 (Related_Nod => P, 4801 N => Access_Definition (Component_Def)); 4802 Set_Is_Local_Anonymous_Access (Element_Type); 4803 4804 -- Propagate the parent. This field is needed if we have to generate 4805 -- the master_id associated with an anonymous access to task type 4806 -- component (see Expand_N_Full_Type_Declaration.Build_Master) 4807 4808 Set_Parent (Element_Type, Parent (T)); 4809 4810 -- Ada 2005 (AI-230): In case of components that are anonymous access 4811 -- types the level of accessibility depends on the enclosing type 4812 -- declaration 4813 4814 Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230) 4815 4816 -- Ada 2005 (AI-254) 4817 4818 declare 4819 CD : constant Node_Id := 4820 Access_To_Subprogram_Definition 4821 (Access_Definition (Component_Def)); 4822 begin 4823 if Present (CD) and then Protected_Present (CD) then 4824 Element_Type := 4825 Replace_Anonymous_Access_To_Protected_Subprogram (Def); 4826 end if; 4827 end; 4828 end if; 4829 4830 -- Constrained array case 4831 4832 if No (T) then 4833 T := Create_Itype (E_Void, P, Related_Id, 'T'); 4834 end if; 4835 4836 if Nkind (Def) = N_Constrained_Array_Definition then 4837 4838 -- Establish Implicit_Base as unconstrained base type 4839 4840 Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B'); 4841 4842 Set_Etype (Implicit_Base, Implicit_Base); 4843 Set_Scope (Implicit_Base, Current_Scope); 4844 Set_Has_Delayed_Freeze (Implicit_Base); 4845 4846 -- The constrained array type is a subtype of the unconstrained one 4847 4848 Set_Ekind (T, E_Array_Subtype); 4849 Init_Size_Align (T); 4850 Set_Etype (T, Implicit_Base); 4851 Set_Scope (T, Current_Scope); 4852 Set_Is_Constrained (T, True); 4853 Set_First_Index (T, First (Discrete_Subtype_Definitions (Def))); 4854 Set_Has_Delayed_Freeze (T); 4855 4856 -- Complete setup of implicit base type 4857 4858 Set_First_Index (Implicit_Base, First_Index (T)); 4859 Set_Component_Type (Implicit_Base, Element_Type); 4860 Set_Has_Task (Implicit_Base, Has_Task (Element_Type)); 4861 Set_Component_Size (Implicit_Base, Uint_0); 4862 Set_Packed_Array_Type (Implicit_Base, Empty); 4863 Set_Has_Controlled_Component 4864 (Implicit_Base, Has_Controlled_Component 4865 (Element_Type) 4866 or else Is_Controlled 4867 (Element_Type)); 4868 Set_Finalize_Storage_Only 4869 (Implicit_Base, Finalize_Storage_Only 4870 (Element_Type)); 4871 4872 -- Unconstrained array case 4873 4874 else 4875 Set_Ekind (T, E_Array_Type); 4876 Init_Size_Align (T); 4877 Set_Etype (T, T); 4878 Set_Scope (T, Current_Scope); 4879 Set_Component_Size (T, Uint_0); 4880 Set_Is_Constrained (T, False); 4881 Set_First_Index (T, First (Subtype_Marks (Def))); 4882 Set_Has_Delayed_Freeze (T, True); 4883 Set_Has_Task (T, Has_Task (Element_Type)); 4884 Set_Has_Controlled_Component (T, Has_Controlled_Component 4885 (Element_Type) 4886 or else 4887 Is_Controlled (Element_Type)); 4888 Set_Finalize_Storage_Only (T, Finalize_Storage_Only 4889 (Element_Type)); 4890 end if; 4891 4892 -- Common attributes for both cases 4893 4894 Set_Component_Type (Base_Type (T), Element_Type); 4895 Set_Packed_Array_Type (T, Empty); 4896 4897 if Aliased_Present (Component_Definition (Def)) then 4898 Check_SPARK_Restriction 4899 ("aliased is not allowed", Component_Definition (Def)); 4900 Set_Has_Aliased_Components (Etype (T)); 4901 end if; 4902 4903 -- Ada 2005 (AI-231): Propagate the null-excluding attribute to the 4904 -- array type to ensure that objects of this type are initialized. 4905 4906 if Ada_Version >= Ada_2005 4907 and then Can_Never_Be_Null (Element_Type) 4908 then 4909 Set_Can_Never_Be_Null (T); 4910 4911 if Null_Exclusion_Present (Component_Definition (Def)) 4912 4913 -- No need to check itypes because in their case this check was 4914 -- done at their point of creation 4915 4916 and then not Is_Itype (Element_Type) 4917 then 4918 Error_Msg_N 4919 ("`NOT NULL` not allowed (null already excluded)", 4920 Subtype_Indication (Component_Definition (Def))); 4921 end if; 4922 end if; 4923 4924 Priv := Private_Component (Element_Type); 4925 4926 if Present (Priv) then 4927 4928 -- Check for circular definitions 4929 4930 if Priv = Any_Type then 4931 Set_Component_Type (Etype (T), Any_Type); 4932 4933 -- There is a gap in the visibility of operations on the composite 4934 -- type only if the component type is defined in a different scope. 4935 4936 elsif Scope (Priv) = Current_Scope then 4937 null; 4938 4939 elsif Is_Limited_Type (Priv) then 4940 Set_Is_Limited_Composite (Etype (T)); 4941 Set_Is_Limited_Composite (T); 4942 else 4943 Set_Is_Private_Composite (Etype (T)); 4944 Set_Is_Private_Composite (T); 4945 end if; 4946 end if; 4947 4948 -- A syntax error in the declaration itself may lead to an empty index 4949 -- list, in which case do a minimal patch. 4950 4951 if No (First_Index (T)) then 4952 Error_Msg_N ("missing index definition in array type declaration", T); 4953 4954 declare 4955 Indexes : constant List_Id := 4956 New_List (New_Occurrence_Of (Any_Id, Sloc (T))); 4957 begin 4958 Set_Discrete_Subtype_Definitions (Def, Indexes); 4959 Set_First_Index (T, First (Indexes)); 4960 return; 4961 end; 4962 end if; 4963 4964 -- Create a concatenation operator for the new type. Internal array 4965 -- types created for packed entities do not need such, they are 4966 -- compatible with the user-defined type. 4967 4968 if Number_Dimensions (T) = 1 4969 and then not Is_Packed_Array_Type (T) 4970 then 4971 New_Concatenation_Op (T); 4972 end if; 4973 4974 -- In the case of an unconstrained array the parser has already verified 4975 -- that all the indexes are unconstrained but we still need to make sure 4976 -- that the element type is constrained. 4977 4978 if Is_Indefinite_Subtype (Element_Type) then 4979 Error_Msg_N 4980 ("unconstrained element type in array declaration", 4981 Subtype_Indication (Component_Def)); 4982 4983 elsif Is_Abstract_Type (Element_Type) then 4984 Error_Msg_N 4985 ("the type of a component cannot be abstract", 4986 Subtype_Indication (Component_Def)); 4987 end if; 4988 4989 -- There may be an invariant declared for the component type, but 4990 -- the construction of the component invariant checking procedure 4991 -- takes place during expansion. 4992 end Array_Type_Declaration; 4993 4994 ------------------------------------------------------ 4995 -- Replace_Anonymous_Access_To_Protected_Subprogram -- 4996 ------------------------------------------------------ 4997 4998 function Replace_Anonymous_Access_To_Protected_Subprogram 4999 (N : Node_Id) return Entity_Id 5000 is 5001 Loc : constant Source_Ptr := Sloc (N); 5002 5003 Curr_Scope : constant Scope_Stack_Entry := 5004 Scope_Stack.Table (Scope_Stack.Last); 5005 5006 Anon : constant Entity_Id := Make_Temporary (Loc, 'S'); 5007 5008 Acc : Node_Id; 5009 -- Access definition in declaration 5010 5011 Comp : Node_Id; 5012 -- Object definition or formal definition with an access definition 5013 5014 Decl : Node_Id; 5015 -- Declaration of anonymous access to subprogram type 5016 5017 Spec : Node_Id; 5018 -- Original specification in access to subprogram 5019 5020 P : Node_Id; 5021 5022 begin 5023 Set_Is_Internal (Anon); 5024 5025 case Nkind (N) is 5026 when N_Component_Declaration | 5027 N_Unconstrained_Array_Definition | 5028 N_Constrained_Array_Definition => 5029 Comp := Component_Definition (N); 5030 Acc := Access_Definition (Comp); 5031 5032 when N_Discriminant_Specification => 5033 Comp := Discriminant_Type (N); 5034 Acc := Comp; 5035 5036 when N_Parameter_Specification => 5037 Comp := Parameter_Type (N); 5038 Acc := Comp; 5039 5040 when N_Access_Function_Definition => 5041 Comp := Result_Definition (N); 5042 Acc := Comp; 5043 5044 when N_Object_Declaration => 5045 Comp := Object_Definition (N); 5046 Acc := Comp; 5047 5048 when N_Function_Specification => 5049 Comp := Result_Definition (N); 5050 Acc := Comp; 5051 5052 when others => 5053 raise Program_Error; 5054 end case; 5055 5056 Spec := Access_To_Subprogram_Definition (Acc); 5057 5058 Decl := 5059 Make_Full_Type_Declaration (Loc, 5060 Defining_Identifier => Anon, 5061 Type_Definition => Copy_Separate_Tree (Spec)); 5062 5063 Mark_Rewrite_Insertion (Decl); 5064 5065 -- In ASIS mode, analyze the profile on the original node, because 5066 -- the separate copy does not provide enough links to recover the 5067 -- original tree. Analysis is limited to type annotations, within 5068 -- a temporary scope that serves as an anonymous subprogram to collect 5069 -- otherwise useless temporaries and itypes. 5070 5071 if ASIS_Mode then 5072 declare 5073 Typ : constant Entity_Id := Make_Temporary (Loc, 'S'); 5074 5075 begin 5076 if Nkind (Spec) = N_Access_Function_Definition then 5077 Set_Ekind (Typ, E_Function); 5078 else 5079 Set_Ekind (Typ, E_Procedure); 5080 end if; 5081 5082 Set_Parent (Typ, N); 5083 Set_Scope (Typ, Current_Scope); 5084 Push_Scope (Typ); 5085 5086 Process_Formals (Parameter_Specifications (Spec), Spec); 5087 5088 if Nkind (Spec) = N_Access_Function_Definition then 5089 if Nkind (Result_Definition (Spec)) = N_Access_Definition then 5090 Find_Type (Subtype_Mark (Result_Definition (Spec))); 5091 else 5092 Find_Type (Result_Definition (Spec)); 5093 end if; 5094 end if; 5095 5096 End_Scope; 5097 end; 5098 end if; 5099 5100 -- Insert the new declaration in the nearest enclosing scope. If the 5101 -- node is a body and N is its return type, the declaration belongs in 5102 -- the enclosing scope. 5103 5104 P := Parent (N); 5105 5106 if Nkind (P) = N_Subprogram_Body 5107 and then Nkind (N) = N_Function_Specification 5108 then 5109 P := Parent (P); 5110 end if; 5111 5112 while Present (P) and then not Has_Declarations (P) loop 5113 P := Parent (P); 5114 end loop; 5115 5116 pragma Assert (Present (P)); 5117 5118 if Nkind (P) = N_Package_Specification then 5119 Prepend (Decl, Visible_Declarations (P)); 5120 else 5121 Prepend (Decl, Declarations (P)); 5122 end if; 5123 5124 -- Replace the anonymous type with an occurrence of the new declaration. 5125 -- In all cases the rewritten node does not have the null-exclusion 5126 -- attribute because (if present) it was already inherited by the 5127 -- anonymous entity (Anon). Thus, in case of components we do not 5128 -- inherit this attribute. 5129 5130 if Nkind (N) = N_Parameter_Specification then 5131 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 5132 Set_Etype (Defining_Identifier (N), Anon); 5133 Set_Null_Exclusion_Present (N, False); 5134 5135 elsif Nkind (N) = N_Object_Declaration then 5136 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 5137 Set_Etype (Defining_Identifier (N), Anon); 5138 5139 elsif Nkind (N) = N_Access_Function_Definition then 5140 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 5141 5142 elsif Nkind (N) = N_Function_Specification then 5143 Rewrite (Comp, New_Occurrence_Of (Anon, Loc)); 5144 Set_Etype (Defining_Unit_Name (N), Anon); 5145 5146 else 5147 Rewrite (Comp, 5148 Make_Component_Definition (Loc, 5149 Subtype_Indication => New_Occurrence_Of (Anon, Loc))); 5150 end if; 5151 5152 Mark_Rewrite_Insertion (Comp); 5153 5154 if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then 5155 Analyze (Decl); 5156 5157 else 5158 -- Temporarily remove the current scope (record or subprogram) from 5159 -- the stack to add the new declarations to the enclosing scope. 5160 5161 Scope_Stack.Decrement_Last; 5162 Analyze (Decl); 5163 Set_Is_Itype (Anon); 5164 Scope_Stack.Append (Curr_Scope); 5165 end if; 5166 5167 Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type); 5168 Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target); 5169 return Anon; 5170 end Replace_Anonymous_Access_To_Protected_Subprogram; 5171 5172 ------------------------------- 5173 -- Build_Derived_Access_Type -- 5174 ------------------------------- 5175 5176 procedure Build_Derived_Access_Type 5177 (N : Node_Id; 5178 Parent_Type : Entity_Id; 5179 Derived_Type : Entity_Id) 5180 is 5181 S : constant Node_Id := Subtype_Indication (Type_Definition (N)); 5182 5183 Desig_Type : Entity_Id; 5184 Discr : Entity_Id; 5185 Discr_Con_Elist : Elist_Id; 5186 Discr_Con_El : Elmt_Id; 5187 Subt : Entity_Id; 5188 5189 begin 5190 -- Set the designated type so it is available in case this is an access 5191 -- to a self-referential type, e.g. a standard list type with a next 5192 -- pointer. Will be reset after subtype is built. 5193 5194 Set_Directly_Designated_Type 5195 (Derived_Type, Designated_Type (Parent_Type)); 5196 5197 Subt := Process_Subtype (S, N); 5198 5199 if Nkind (S) /= N_Subtype_Indication 5200 and then Subt /= Base_Type (Subt) 5201 then 5202 Set_Ekind (Derived_Type, E_Access_Subtype); 5203 end if; 5204 5205 if Ekind (Derived_Type) = E_Access_Subtype then 5206 declare 5207 Pbase : constant Entity_Id := Base_Type (Parent_Type); 5208 Ibase : constant Entity_Id := 5209 Create_Itype (Ekind (Pbase), N, Derived_Type, 'B'); 5210 Svg_Chars : constant Name_Id := Chars (Ibase); 5211 Svg_Next_E : constant Entity_Id := Next_Entity (Ibase); 5212 5213 begin 5214 Copy_Node (Pbase, Ibase); 5215 5216 Set_Chars (Ibase, Svg_Chars); 5217 Set_Next_Entity (Ibase, Svg_Next_E); 5218 Set_Sloc (Ibase, Sloc (Derived_Type)); 5219 Set_Scope (Ibase, Scope (Derived_Type)); 5220 Set_Freeze_Node (Ibase, Empty); 5221 Set_Is_Frozen (Ibase, False); 5222 Set_Comes_From_Source (Ibase, False); 5223 Set_Is_First_Subtype (Ibase, False); 5224 5225 Set_Etype (Ibase, Pbase); 5226 Set_Etype (Derived_Type, Ibase); 5227 end; 5228 end if; 5229 5230 Set_Directly_Designated_Type 5231 (Derived_Type, Designated_Type (Subt)); 5232 5233 Set_Is_Constrained (Derived_Type, Is_Constrained (Subt)); 5234 Set_Is_Access_Constant (Derived_Type, Is_Access_Constant (Parent_Type)); 5235 Set_Size_Info (Derived_Type, Parent_Type); 5236 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 5237 Set_Depends_On_Private (Derived_Type, 5238 Has_Private_Component (Derived_Type)); 5239 Conditional_Delay (Derived_Type, Subt); 5240 5241 -- Ada 2005 (AI-231): Set the null-exclusion attribute, and verify 5242 -- that it is not redundant. 5243 5244 if Null_Exclusion_Present (Type_Definition (N)) then 5245 Set_Can_Never_Be_Null (Derived_Type); 5246 5247 if Can_Never_Be_Null (Parent_Type) 5248 and then False 5249 then 5250 Error_Msg_NE 5251 ("`NOT NULL` not allowed (& already excludes null)", 5252 N, Parent_Type); 5253 end if; 5254 5255 elsif Can_Never_Be_Null (Parent_Type) then 5256 Set_Can_Never_Be_Null (Derived_Type); 5257 end if; 5258 5259 -- Note: we do not copy the Storage_Size_Variable, since we always go to 5260 -- the root type for this information. 5261 5262 -- Apply range checks to discriminants for derived record case 5263 -- ??? THIS CODE SHOULD NOT BE HERE REALLY. 5264 5265 Desig_Type := Designated_Type (Derived_Type); 5266 if Is_Composite_Type (Desig_Type) 5267 and then (not Is_Array_Type (Desig_Type)) 5268 and then Has_Discriminants (Desig_Type) 5269 and then Base_Type (Desig_Type) /= Desig_Type 5270 then 5271 Discr_Con_Elist := Discriminant_Constraint (Desig_Type); 5272 Discr_Con_El := First_Elmt (Discr_Con_Elist); 5273 5274 Discr := First_Discriminant (Base_Type (Desig_Type)); 5275 while Present (Discr_Con_El) loop 5276 Apply_Range_Check (Node (Discr_Con_El), Etype (Discr)); 5277 Next_Elmt (Discr_Con_El); 5278 Next_Discriminant (Discr); 5279 end loop; 5280 end if; 5281 end Build_Derived_Access_Type; 5282 5283 ------------------------------ 5284 -- Build_Derived_Array_Type -- 5285 ------------------------------ 5286 5287 procedure Build_Derived_Array_Type 5288 (N : Node_Id; 5289 Parent_Type : Entity_Id; 5290 Derived_Type : Entity_Id) 5291 is 5292 Loc : constant Source_Ptr := Sloc (N); 5293 Tdef : constant Node_Id := Type_Definition (N); 5294 Indic : constant Node_Id := Subtype_Indication (Tdef); 5295 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 5296 Implicit_Base : Entity_Id; 5297 New_Indic : Node_Id; 5298 5299 procedure Make_Implicit_Base; 5300 -- If the parent subtype is constrained, the derived type is a subtype 5301 -- of an implicit base type derived from the parent base. 5302 5303 ------------------------ 5304 -- Make_Implicit_Base -- 5305 ------------------------ 5306 5307 procedure Make_Implicit_Base is 5308 begin 5309 Implicit_Base := 5310 Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); 5311 5312 Set_Ekind (Implicit_Base, Ekind (Parent_Base)); 5313 Set_Etype (Implicit_Base, Parent_Base); 5314 5315 Copy_Array_Subtype_Attributes (Implicit_Base, Parent_Base); 5316 Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base); 5317 5318 Set_Has_Delayed_Freeze (Implicit_Base, True); 5319 end Make_Implicit_Base; 5320 5321 -- Start of processing for Build_Derived_Array_Type 5322 5323 begin 5324 if not Is_Constrained (Parent_Type) then 5325 if Nkind (Indic) /= N_Subtype_Indication then 5326 Set_Ekind (Derived_Type, E_Array_Type); 5327 5328 Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); 5329 Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type); 5330 5331 Set_Has_Delayed_Freeze (Derived_Type, True); 5332 5333 else 5334 Make_Implicit_Base; 5335 Set_Etype (Derived_Type, Implicit_Base); 5336 5337 New_Indic := 5338 Make_Subtype_Declaration (Loc, 5339 Defining_Identifier => Derived_Type, 5340 Subtype_Indication => 5341 Make_Subtype_Indication (Loc, 5342 Subtype_Mark => New_Reference_To (Implicit_Base, Loc), 5343 Constraint => Constraint (Indic))); 5344 5345 Rewrite (N, New_Indic); 5346 Analyze (N); 5347 end if; 5348 5349 else 5350 if Nkind (Indic) /= N_Subtype_Indication then 5351 Make_Implicit_Base; 5352 5353 Set_Ekind (Derived_Type, Ekind (Parent_Type)); 5354 Set_Etype (Derived_Type, Implicit_Base); 5355 Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); 5356 5357 else 5358 Error_Msg_N ("illegal constraint on constrained type", Indic); 5359 end if; 5360 end if; 5361 5362 -- If parent type is not a derived type itself, and is declared in 5363 -- closed scope (e.g. a subprogram), then we must explicitly introduce 5364 -- the new type's concatenation operator since Derive_Subprograms 5365 -- will not inherit the parent's operator. If the parent type is 5366 -- unconstrained, the operator is of the unconstrained base type. 5367 5368 if Number_Dimensions (Parent_Type) = 1 5369 and then not Is_Limited_Type (Parent_Type) 5370 and then not Is_Derived_Type (Parent_Type) 5371 and then not Is_Package_Or_Generic_Package 5372 (Scope (Base_Type (Parent_Type))) 5373 then 5374 if not Is_Constrained (Parent_Type) 5375 and then Is_Constrained (Derived_Type) 5376 then 5377 New_Concatenation_Op (Implicit_Base); 5378 else 5379 New_Concatenation_Op (Derived_Type); 5380 end if; 5381 end if; 5382 end Build_Derived_Array_Type; 5383 5384 ----------------------------------- 5385 -- Build_Derived_Concurrent_Type -- 5386 ----------------------------------- 5387 5388 procedure Build_Derived_Concurrent_Type 5389 (N : Node_Id; 5390 Parent_Type : Entity_Id; 5391 Derived_Type : Entity_Id) 5392 is 5393 Loc : constant Source_Ptr := Sloc (N); 5394 5395 Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C'); 5396 Corr_Decl : Node_Id; 5397 Corr_Decl_Needed : Boolean; 5398 -- If the derived type has fewer discriminants than its parent, the 5399 -- corresponding record is also a derived type, in order to account for 5400 -- the bound discriminants. We create a full type declaration for it in 5401 -- this case. 5402 5403 Constraint_Present : constant Boolean := 5404 Nkind (Subtype_Indication (Type_Definition (N))) = 5405 N_Subtype_Indication; 5406 5407 D_Constraint : Node_Id; 5408 New_Constraint : Elist_Id; 5409 Old_Disc : Entity_Id; 5410 New_Disc : Entity_Id; 5411 New_N : Node_Id; 5412 5413 begin 5414 Set_Stored_Constraint (Derived_Type, No_Elist); 5415 Corr_Decl_Needed := False; 5416 Old_Disc := Empty; 5417 5418 if Present (Discriminant_Specifications (N)) 5419 and then Constraint_Present 5420 then 5421 Old_Disc := First_Discriminant (Parent_Type); 5422 New_Disc := First (Discriminant_Specifications (N)); 5423 while Present (New_Disc) and then Present (Old_Disc) loop 5424 Next_Discriminant (Old_Disc); 5425 Next (New_Disc); 5426 end loop; 5427 end if; 5428 5429 if Present (Old_Disc) and then Expander_Active then 5430 5431 -- The new type has fewer discriminants, so we need to create a new 5432 -- corresponding record, which is derived from the corresponding 5433 -- record of the parent, and has a stored constraint that captures 5434 -- the values of the discriminant constraints. The corresponding 5435 -- record is needed only if expander is active and code generation is 5436 -- enabled. 5437 5438 -- The type declaration for the derived corresponding record has the 5439 -- same discriminant part and constraints as the current declaration. 5440 -- Copy the unanalyzed tree to build declaration. 5441 5442 Corr_Decl_Needed := True; 5443 New_N := Copy_Separate_Tree (N); 5444 5445 Corr_Decl := 5446 Make_Full_Type_Declaration (Loc, 5447 Defining_Identifier => Corr_Record, 5448 Discriminant_Specifications => 5449 Discriminant_Specifications (New_N), 5450 Type_Definition => 5451 Make_Derived_Type_Definition (Loc, 5452 Subtype_Indication => 5453 Make_Subtype_Indication (Loc, 5454 Subtype_Mark => 5455 New_Occurrence_Of 5456 (Corresponding_Record_Type (Parent_Type), Loc), 5457 Constraint => 5458 Constraint 5459 (Subtype_Indication (Type_Definition (New_N)))))); 5460 end if; 5461 5462 -- Copy Storage_Size and Relative_Deadline variables if task case 5463 5464 if Is_Task_Type (Parent_Type) then 5465 Set_Storage_Size_Variable (Derived_Type, 5466 Storage_Size_Variable (Parent_Type)); 5467 Set_Relative_Deadline_Variable (Derived_Type, 5468 Relative_Deadline_Variable (Parent_Type)); 5469 end if; 5470 5471 if Present (Discriminant_Specifications (N)) then 5472 Push_Scope (Derived_Type); 5473 Check_Or_Process_Discriminants (N, Derived_Type); 5474 5475 if Constraint_Present then 5476 New_Constraint := 5477 Expand_To_Stored_Constraint 5478 (Parent_Type, 5479 Build_Discriminant_Constraints 5480 (Parent_Type, 5481 Subtype_Indication (Type_Definition (N)), True)); 5482 end if; 5483 5484 End_Scope; 5485 5486 elsif Constraint_Present then 5487 5488 -- Build constrained subtype, copying the constraint, and derive 5489 -- from it to create a derived constrained type. 5490 5491 declare 5492 Loc : constant Source_Ptr := Sloc (N); 5493 Anon : constant Entity_Id := 5494 Make_Defining_Identifier (Loc, 5495 Chars => New_External_Name (Chars (Derived_Type), 'T')); 5496 Decl : Node_Id; 5497 5498 begin 5499 Decl := 5500 Make_Subtype_Declaration (Loc, 5501 Defining_Identifier => Anon, 5502 Subtype_Indication => 5503 New_Copy_Tree (Subtype_Indication (Type_Definition (N)))); 5504 Insert_Before (N, Decl); 5505 Analyze (Decl); 5506 5507 Rewrite (Subtype_Indication (Type_Definition (N)), 5508 New_Occurrence_Of (Anon, Loc)); 5509 Set_Analyzed (Derived_Type, False); 5510 Analyze (N); 5511 return; 5512 end; 5513 end if; 5514 5515 -- By default, operations and private data are inherited from parent. 5516 -- However, in the presence of bound discriminants, a new corresponding 5517 -- record will be created, see below. 5518 5519 Set_Has_Discriminants 5520 (Derived_Type, Has_Discriminants (Parent_Type)); 5521 Set_Corresponding_Record_Type 5522 (Derived_Type, Corresponding_Record_Type (Parent_Type)); 5523 5524 -- Is_Constrained is set according the parent subtype, but is set to 5525 -- False if the derived type is declared with new discriminants. 5526 5527 Set_Is_Constrained 5528 (Derived_Type, 5529 (Is_Constrained (Parent_Type) or else Constraint_Present) 5530 and then not Present (Discriminant_Specifications (N))); 5531 5532 if Constraint_Present then 5533 if not Has_Discriminants (Parent_Type) then 5534 Error_Msg_N ("untagged parent must have discriminants", N); 5535 5536 elsif Present (Discriminant_Specifications (N)) then 5537 5538 -- Verify that new discriminants are used to constrain old ones 5539 5540 D_Constraint := 5541 First 5542 (Constraints 5543 (Constraint (Subtype_Indication (Type_Definition (N))))); 5544 5545 Old_Disc := First_Discriminant (Parent_Type); 5546 5547 while Present (D_Constraint) loop 5548 if Nkind (D_Constraint) /= N_Discriminant_Association then 5549 5550 -- Positional constraint. If it is a reference to a new 5551 -- discriminant, it constrains the corresponding old one. 5552 5553 if Nkind (D_Constraint) = N_Identifier then 5554 New_Disc := First_Discriminant (Derived_Type); 5555 while Present (New_Disc) loop 5556 exit when Chars (New_Disc) = Chars (D_Constraint); 5557 Next_Discriminant (New_Disc); 5558 end loop; 5559 5560 if Present (New_Disc) then 5561 Set_Corresponding_Discriminant (New_Disc, Old_Disc); 5562 end if; 5563 end if; 5564 5565 Next_Discriminant (Old_Disc); 5566 5567 -- if this is a named constraint, search by name for the old 5568 -- discriminants constrained by the new one. 5569 5570 elsif Nkind (Expression (D_Constraint)) = N_Identifier then 5571 5572 -- Find new discriminant with that name 5573 5574 New_Disc := First_Discriminant (Derived_Type); 5575 while Present (New_Disc) loop 5576 exit when 5577 Chars (New_Disc) = Chars (Expression (D_Constraint)); 5578 Next_Discriminant (New_Disc); 5579 end loop; 5580 5581 if Present (New_Disc) then 5582 5583 -- Verify that new discriminant renames some discriminant 5584 -- of the parent type, and associate the new discriminant 5585 -- with one or more old ones that it renames. 5586 5587 declare 5588 Selector : Node_Id; 5589 5590 begin 5591 Selector := First (Selector_Names (D_Constraint)); 5592 while Present (Selector) loop 5593 Old_Disc := First_Discriminant (Parent_Type); 5594 while Present (Old_Disc) loop 5595 exit when Chars (Old_Disc) = Chars (Selector); 5596 Next_Discriminant (Old_Disc); 5597 end loop; 5598 5599 if Present (Old_Disc) then 5600 Set_Corresponding_Discriminant 5601 (New_Disc, Old_Disc); 5602 end if; 5603 5604 Next (Selector); 5605 end loop; 5606 end; 5607 end if; 5608 end if; 5609 5610 Next (D_Constraint); 5611 end loop; 5612 5613 New_Disc := First_Discriminant (Derived_Type); 5614 while Present (New_Disc) loop 5615 if No (Corresponding_Discriminant (New_Disc)) then 5616 Error_Msg_NE 5617 ("new discriminant& must constrain old one", N, New_Disc); 5618 5619 elsif not 5620 Subtypes_Statically_Compatible 5621 (Etype (New_Disc), 5622 Etype (Corresponding_Discriminant (New_Disc))) 5623 then 5624 Error_Msg_NE 5625 ("& not statically compatible with parent discriminant", 5626 N, New_Disc); 5627 end if; 5628 5629 Next_Discriminant (New_Disc); 5630 end loop; 5631 end if; 5632 5633 elsif Present (Discriminant_Specifications (N)) then 5634 Error_Msg_N 5635 ("missing discriminant constraint in untagged derivation", N); 5636 end if; 5637 5638 -- The entity chain of the derived type includes the new discriminants 5639 -- but shares operations with the parent. 5640 5641 if Present (Discriminant_Specifications (N)) then 5642 Old_Disc := First_Discriminant (Parent_Type); 5643 while Present (Old_Disc) loop 5644 if No (Next_Entity (Old_Disc)) 5645 or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant 5646 then 5647 Set_Next_Entity 5648 (Last_Entity (Derived_Type), Next_Entity (Old_Disc)); 5649 exit; 5650 end if; 5651 5652 Next_Discriminant (Old_Disc); 5653 end loop; 5654 5655 else 5656 Set_First_Entity (Derived_Type, First_Entity (Parent_Type)); 5657 if Has_Discriminants (Parent_Type) then 5658 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 5659 Set_Discriminant_Constraint ( 5660 Derived_Type, Discriminant_Constraint (Parent_Type)); 5661 end if; 5662 end if; 5663 5664 Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type)); 5665 5666 Set_Has_Completion (Derived_Type); 5667 5668 if Corr_Decl_Needed then 5669 Set_Stored_Constraint (Derived_Type, New_Constraint); 5670 Insert_After (N, Corr_Decl); 5671 Analyze (Corr_Decl); 5672 Set_Corresponding_Record_Type (Derived_Type, Corr_Record); 5673 end if; 5674 end Build_Derived_Concurrent_Type; 5675 5676 ------------------------------------ 5677 -- Build_Derived_Enumeration_Type -- 5678 ------------------------------------ 5679 5680 procedure Build_Derived_Enumeration_Type 5681 (N : Node_Id; 5682 Parent_Type : Entity_Id; 5683 Derived_Type : Entity_Id) 5684 is 5685 Loc : constant Source_Ptr := Sloc (N); 5686 Def : constant Node_Id := Type_Definition (N); 5687 Indic : constant Node_Id := Subtype_Indication (Def); 5688 Implicit_Base : Entity_Id; 5689 Literal : Entity_Id; 5690 New_Lit : Entity_Id; 5691 Literals_List : List_Id; 5692 Type_Decl : Node_Id; 5693 Hi, Lo : Node_Id; 5694 Rang_Expr : Node_Id; 5695 5696 begin 5697 -- Since types Standard.Character and Standard.[Wide_]Wide_Character do 5698 -- not have explicit literals lists we need to process types derived 5699 -- from them specially. This is handled by Derived_Standard_Character. 5700 -- If the parent type is a generic type, there are no literals either, 5701 -- and we construct the same skeletal representation as for the generic 5702 -- parent type. 5703 5704 if Is_Standard_Character_Type (Parent_Type) then 5705 Derived_Standard_Character (N, Parent_Type, Derived_Type); 5706 5707 elsif Is_Generic_Type (Root_Type (Parent_Type)) then 5708 declare 5709 Lo : Node_Id; 5710 Hi : Node_Id; 5711 5712 begin 5713 if Nkind (Indic) /= N_Subtype_Indication then 5714 Lo := 5715 Make_Attribute_Reference (Loc, 5716 Attribute_Name => Name_First, 5717 Prefix => New_Reference_To (Derived_Type, Loc)); 5718 Set_Etype (Lo, Derived_Type); 5719 5720 Hi := 5721 Make_Attribute_Reference (Loc, 5722 Attribute_Name => Name_Last, 5723 Prefix => New_Reference_To (Derived_Type, Loc)); 5724 Set_Etype (Hi, Derived_Type); 5725 5726 Set_Scalar_Range (Derived_Type, 5727 Make_Range (Loc, 5728 Low_Bound => Lo, 5729 High_Bound => Hi)); 5730 else 5731 5732 -- Analyze subtype indication and verify compatibility 5733 -- with parent type. 5734 5735 if Base_Type (Process_Subtype (Indic, N)) /= 5736 Base_Type (Parent_Type) 5737 then 5738 Error_Msg_N 5739 ("illegal constraint for formal discrete type", N); 5740 end if; 5741 end if; 5742 end; 5743 5744 else 5745 -- If a constraint is present, analyze the bounds to catch 5746 -- premature usage of the derived literals. 5747 5748 if Nkind (Indic) = N_Subtype_Indication 5749 and then Nkind (Range_Expression (Constraint (Indic))) = N_Range 5750 then 5751 Analyze (Low_Bound (Range_Expression (Constraint (Indic)))); 5752 Analyze (High_Bound (Range_Expression (Constraint (Indic)))); 5753 end if; 5754 5755 -- Introduce an implicit base type for the derived type even if there 5756 -- is no constraint attached to it, since this seems closer to the 5757 -- Ada semantics. Build a full type declaration tree for the derived 5758 -- type using the implicit base type as the defining identifier. The 5759 -- build a subtype declaration tree which applies the constraint (if 5760 -- any) have it replace the derived type declaration. 5761 5762 Literal := First_Literal (Parent_Type); 5763 Literals_List := New_List; 5764 while Present (Literal) 5765 and then Ekind (Literal) = E_Enumeration_Literal 5766 loop 5767 -- Literals of the derived type have the same representation as 5768 -- those of the parent type, but this representation can be 5769 -- overridden by an explicit representation clause. Indicate 5770 -- that there is no explicit representation given yet. These 5771 -- derived literals are implicit operations of the new type, 5772 -- and can be overridden by explicit ones. 5773 5774 if Nkind (Literal) = N_Defining_Character_Literal then 5775 New_Lit := 5776 Make_Defining_Character_Literal (Loc, Chars (Literal)); 5777 else 5778 New_Lit := Make_Defining_Identifier (Loc, Chars (Literal)); 5779 end if; 5780 5781 Set_Ekind (New_Lit, E_Enumeration_Literal); 5782 Set_Enumeration_Pos (New_Lit, Enumeration_Pos (Literal)); 5783 Set_Enumeration_Rep (New_Lit, Enumeration_Rep (Literal)); 5784 Set_Enumeration_Rep_Expr (New_Lit, Empty); 5785 Set_Alias (New_Lit, Literal); 5786 Set_Is_Known_Valid (New_Lit, True); 5787 5788 Append (New_Lit, Literals_List); 5789 Next_Literal (Literal); 5790 end loop; 5791 5792 Implicit_Base := 5793 Make_Defining_Identifier (Sloc (Derived_Type), 5794 Chars => New_External_Name (Chars (Derived_Type), 'B')); 5795 5796 -- Indicate the proper nature of the derived type. This must be done 5797 -- before analysis of the literals, to recognize cases when a literal 5798 -- may be hidden by a previous explicit function definition (cf. 5799 -- c83031a). 5800 5801 Set_Ekind (Derived_Type, E_Enumeration_Subtype); 5802 Set_Etype (Derived_Type, Implicit_Base); 5803 5804 Type_Decl := 5805 Make_Full_Type_Declaration (Loc, 5806 Defining_Identifier => Implicit_Base, 5807 Discriminant_Specifications => No_List, 5808 Type_Definition => 5809 Make_Enumeration_Type_Definition (Loc, Literals_List)); 5810 5811 Mark_Rewrite_Insertion (Type_Decl); 5812 Insert_Before (N, Type_Decl); 5813 Analyze (Type_Decl); 5814 5815 -- After the implicit base is analyzed its Etype needs to be changed 5816 -- to reflect the fact that it is derived from the parent type which 5817 -- was ignored during analysis. We also set the size at this point. 5818 5819 Set_Etype (Implicit_Base, Parent_Type); 5820 5821 Set_Size_Info (Implicit_Base, Parent_Type); 5822 Set_RM_Size (Implicit_Base, RM_Size (Parent_Type)); 5823 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type)); 5824 5825 -- Copy other flags from parent type 5826 5827 Set_Has_Non_Standard_Rep 5828 (Implicit_Base, Has_Non_Standard_Rep 5829 (Parent_Type)); 5830 Set_Has_Pragma_Ordered 5831 (Implicit_Base, Has_Pragma_Ordered 5832 (Parent_Type)); 5833 Set_Has_Delayed_Freeze (Implicit_Base); 5834 5835 -- Process the subtype indication including a validation check on the 5836 -- constraint, if any. If a constraint is given, its bounds must be 5837 -- implicitly converted to the new type. 5838 5839 if Nkind (Indic) = N_Subtype_Indication then 5840 declare 5841 R : constant Node_Id := 5842 Range_Expression (Constraint (Indic)); 5843 5844 begin 5845 if Nkind (R) = N_Range then 5846 Hi := Build_Scalar_Bound 5847 (High_Bound (R), Parent_Type, Implicit_Base); 5848 Lo := Build_Scalar_Bound 5849 (Low_Bound (R), Parent_Type, Implicit_Base); 5850 5851 else 5852 -- Constraint is a Range attribute. Replace with explicit 5853 -- mention of the bounds of the prefix, which must be a 5854 -- subtype. 5855 5856 Analyze (Prefix (R)); 5857 Hi := 5858 Convert_To (Implicit_Base, 5859 Make_Attribute_Reference (Loc, 5860 Attribute_Name => Name_Last, 5861 Prefix => 5862 New_Occurrence_Of (Entity (Prefix (R)), Loc))); 5863 5864 Lo := 5865 Convert_To (Implicit_Base, 5866 Make_Attribute_Reference (Loc, 5867 Attribute_Name => Name_First, 5868 Prefix => 5869 New_Occurrence_Of (Entity (Prefix (R)), Loc))); 5870 end if; 5871 end; 5872 5873 else 5874 Hi := 5875 Build_Scalar_Bound 5876 (Type_High_Bound (Parent_Type), 5877 Parent_Type, Implicit_Base); 5878 Lo := 5879 Build_Scalar_Bound 5880 (Type_Low_Bound (Parent_Type), 5881 Parent_Type, Implicit_Base); 5882 end if; 5883 5884 Rang_Expr := 5885 Make_Range (Loc, 5886 Low_Bound => Lo, 5887 High_Bound => Hi); 5888 5889 -- If we constructed a default range for the case where no range 5890 -- was given, then the expressions in the range must not freeze 5891 -- since they do not correspond to expressions in the source. 5892 5893 if Nkind (Indic) /= N_Subtype_Indication then 5894 Set_Must_Not_Freeze (Lo); 5895 Set_Must_Not_Freeze (Hi); 5896 Set_Must_Not_Freeze (Rang_Expr); 5897 end if; 5898 5899 Rewrite (N, 5900 Make_Subtype_Declaration (Loc, 5901 Defining_Identifier => Derived_Type, 5902 Subtype_Indication => 5903 Make_Subtype_Indication (Loc, 5904 Subtype_Mark => New_Occurrence_Of (Implicit_Base, Loc), 5905 Constraint => 5906 Make_Range_Constraint (Loc, 5907 Range_Expression => Rang_Expr)))); 5908 5909 Analyze (N); 5910 5911 -- Apply a range check. Since this range expression doesn't have an 5912 -- Etype, we have to specifically pass the Source_Typ parameter. Is 5913 -- this right??? 5914 5915 if Nkind (Indic) = N_Subtype_Indication then 5916 Apply_Range_Check (Range_Expression (Constraint (Indic)), 5917 Parent_Type, 5918 Source_Typ => Entity (Subtype_Mark (Indic))); 5919 end if; 5920 end if; 5921 end Build_Derived_Enumeration_Type; 5922 5923 -------------------------------- 5924 -- Build_Derived_Numeric_Type -- 5925 -------------------------------- 5926 5927 procedure Build_Derived_Numeric_Type 5928 (N : Node_Id; 5929 Parent_Type : Entity_Id; 5930 Derived_Type : Entity_Id) 5931 is 5932 Loc : constant Source_Ptr := Sloc (N); 5933 Tdef : constant Node_Id := Type_Definition (N); 5934 Indic : constant Node_Id := Subtype_Indication (Tdef); 5935 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 5936 No_Constraint : constant Boolean := Nkind (Indic) /= 5937 N_Subtype_Indication; 5938 Implicit_Base : Entity_Id; 5939 5940 Lo : Node_Id; 5941 Hi : Node_Id; 5942 5943 begin 5944 -- Process the subtype indication including a validation check on 5945 -- the constraint if any. 5946 5947 Discard_Node (Process_Subtype (Indic, N)); 5948 5949 -- Introduce an implicit base type for the derived type even if there 5950 -- is no constraint attached to it, since this seems closer to the Ada 5951 -- semantics. 5952 5953 Implicit_Base := 5954 Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); 5955 5956 Set_Etype (Implicit_Base, Parent_Base); 5957 Set_Ekind (Implicit_Base, Ekind (Parent_Base)); 5958 Set_Size_Info (Implicit_Base, Parent_Base); 5959 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base)); 5960 Set_Parent (Implicit_Base, Parent (Derived_Type)); 5961 Set_Is_Known_Valid (Implicit_Base, Is_Known_Valid (Parent_Base)); 5962 5963 -- Set RM Size for discrete type or decimal fixed-point type 5964 -- Ordinary fixed-point is excluded, why??? 5965 5966 if Is_Discrete_Type (Parent_Base) 5967 or else Is_Decimal_Fixed_Point_Type (Parent_Base) 5968 then 5969 Set_RM_Size (Implicit_Base, RM_Size (Parent_Base)); 5970 end if; 5971 5972 Set_Has_Delayed_Freeze (Implicit_Base); 5973 5974 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); 5975 Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); 5976 5977 Set_Scalar_Range (Implicit_Base, 5978 Make_Range (Loc, 5979 Low_Bound => Lo, 5980 High_Bound => Hi)); 5981 5982 if Has_Infinities (Parent_Base) then 5983 Set_Includes_Infinities (Scalar_Range (Implicit_Base)); 5984 end if; 5985 5986 -- The Derived_Type, which is the entity of the declaration, is a 5987 -- subtype of the implicit base. Its Ekind is a subtype, even in the 5988 -- absence of an explicit constraint. 5989 5990 Set_Etype (Derived_Type, Implicit_Base); 5991 5992 -- If we did not have a constraint, then the Ekind is set from the 5993 -- parent type (otherwise Process_Subtype has set the bounds) 5994 5995 if No_Constraint then 5996 Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type))); 5997 end if; 5998 5999 -- If we did not have a range constraint, then set the range from the 6000 -- parent type. Otherwise, the Process_Subtype call has set the bounds. 6001 6002 if No_Constraint 6003 or else not Has_Range_Constraint (Indic) 6004 then 6005 Set_Scalar_Range (Derived_Type, 6006 Make_Range (Loc, 6007 Low_Bound => New_Copy_Tree (Type_Low_Bound (Parent_Type)), 6008 High_Bound => New_Copy_Tree (Type_High_Bound (Parent_Type)))); 6009 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 6010 6011 if Has_Infinities (Parent_Type) then 6012 Set_Includes_Infinities (Scalar_Range (Derived_Type)); 6013 end if; 6014 6015 Set_Is_Known_Valid (Derived_Type, Is_Known_Valid (Parent_Type)); 6016 end if; 6017 6018 Set_Is_Descendent_Of_Address (Derived_Type, 6019 Is_Descendent_Of_Address (Parent_Type)); 6020 Set_Is_Descendent_Of_Address (Implicit_Base, 6021 Is_Descendent_Of_Address (Parent_Type)); 6022 6023 -- Set remaining type-specific fields, depending on numeric type 6024 6025 if Is_Modular_Integer_Type (Parent_Type) then 6026 Set_Modulus (Implicit_Base, Modulus (Parent_Base)); 6027 6028 Set_Non_Binary_Modulus 6029 (Implicit_Base, Non_Binary_Modulus (Parent_Base)); 6030 6031 Set_Is_Known_Valid 6032 (Implicit_Base, Is_Known_Valid (Parent_Base)); 6033 6034 elsif Is_Floating_Point_Type (Parent_Type) then 6035 6036 -- Digits of base type is always copied from the digits value of 6037 -- the parent base type, but the digits of the derived type will 6038 -- already have been set if there was a constraint present. 6039 6040 Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); 6041 Set_Float_Rep (Implicit_Base, Float_Rep (Parent_Base)); 6042 6043 if No_Constraint then 6044 Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type)); 6045 end if; 6046 6047 elsif Is_Fixed_Point_Type (Parent_Type) then 6048 6049 -- Small of base type and derived type are always copied from the 6050 -- parent base type, since smalls never change. The delta of the 6051 -- base type is also copied from the parent base type. However the 6052 -- delta of the derived type will have been set already if a 6053 -- constraint was present. 6054 6055 Set_Small_Value (Derived_Type, Small_Value (Parent_Base)); 6056 Set_Small_Value (Implicit_Base, Small_Value (Parent_Base)); 6057 Set_Delta_Value (Implicit_Base, Delta_Value (Parent_Base)); 6058 6059 if No_Constraint then 6060 Set_Delta_Value (Derived_Type, Delta_Value (Parent_Type)); 6061 end if; 6062 6063 -- The scale and machine radix in the decimal case are always 6064 -- copied from the parent base type. 6065 6066 if Is_Decimal_Fixed_Point_Type (Parent_Type) then 6067 Set_Scale_Value (Derived_Type, Scale_Value (Parent_Base)); 6068 Set_Scale_Value (Implicit_Base, Scale_Value (Parent_Base)); 6069 6070 Set_Machine_Radix_10 6071 (Derived_Type, Machine_Radix_10 (Parent_Base)); 6072 Set_Machine_Radix_10 6073 (Implicit_Base, Machine_Radix_10 (Parent_Base)); 6074 6075 Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base)); 6076 6077 if No_Constraint then 6078 Set_Digits_Value (Derived_Type, Digits_Value (Parent_Base)); 6079 6080 else 6081 -- the analysis of the subtype_indication sets the 6082 -- digits value of the derived type. 6083 6084 null; 6085 end if; 6086 end if; 6087 end if; 6088 6089 -- The type of the bounds is that of the parent type, and they 6090 -- must be converted to the derived type. 6091 6092 Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); 6093 6094 -- The implicit_base should be frozen when the derived type is frozen, 6095 -- but note that it is used in the conversions of the bounds. For fixed 6096 -- types we delay the determination of the bounds until the proper 6097 -- freezing point. For other numeric types this is rejected by GCC, for 6098 -- reasons that are currently unclear (???), so we choose to freeze the 6099 -- implicit base now. In the case of integers and floating point types 6100 -- this is harmless because subsequent representation clauses cannot 6101 -- affect anything, but it is still baffling that we cannot use the 6102 -- same mechanism for all derived numeric types. 6103 6104 -- There is a further complication: actually *some* representation 6105 -- clauses can affect the implicit base type. Namely, attribute 6106 -- definition clauses for stream-oriented attributes need to set the 6107 -- corresponding TSS entries on the base type, and this normally cannot 6108 -- be done after the base type is frozen, so the circuitry in 6109 -- Sem_Ch13.New_Stream_Subprogram must account for this possibility and 6110 -- not use Set_TSS in this case. 6111 6112 if Is_Fixed_Point_Type (Parent_Type) then 6113 Conditional_Delay (Implicit_Base, Parent_Type); 6114 else 6115 Freeze_Before (N, Implicit_Base); 6116 end if; 6117 end Build_Derived_Numeric_Type; 6118 6119 -------------------------------- 6120 -- Build_Derived_Private_Type -- 6121 -------------------------------- 6122 6123 procedure Build_Derived_Private_Type 6124 (N : Node_Id; 6125 Parent_Type : Entity_Id; 6126 Derived_Type : Entity_Id; 6127 Is_Completion : Boolean; 6128 Derive_Subps : Boolean := True) 6129 is 6130 Loc : constant Source_Ptr := Sloc (N); 6131 Der_Base : Entity_Id; 6132 Discr : Entity_Id; 6133 Full_Decl : Node_Id := Empty; 6134 Full_Der : Entity_Id; 6135 Full_P : Entity_Id; 6136 Last_Discr : Entity_Id; 6137 Par_Scope : constant Entity_Id := Scope (Base_Type (Parent_Type)); 6138 Swapped : Boolean := False; 6139 6140 procedure Copy_And_Build; 6141 -- Copy derived type declaration, replace parent with its full view, 6142 -- and analyze new declaration. 6143 6144 -------------------- 6145 -- Copy_And_Build -- 6146 -------------------- 6147 6148 procedure Copy_And_Build is 6149 Full_N : Node_Id; 6150 6151 begin 6152 if Ekind (Parent_Type) in Record_Kind 6153 or else 6154 (Ekind (Parent_Type) in Enumeration_Kind 6155 and then not Is_Standard_Character_Type (Parent_Type) 6156 and then not Is_Generic_Type (Root_Type (Parent_Type))) 6157 then 6158 Full_N := New_Copy_Tree (N); 6159 Insert_After (N, Full_N); 6160 Build_Derived_Type ( 6161 Full_N, Parent_Type, Full_Der, True, Derive_Subps => False); 6162 6163 else 6164 Build_Derived_Type ( 6165 N, Parent_Type, Full_Der, True, Derive_Subps => False); 6166 end if; 6167 end Copy_And_Build; 6168 6169 -- Start of processing for Build_Derived_Private_Type 6170 6171 begin 6172 if Is_Tagged_Type (Parent_Type) then 6173 Full_P := Full_View (Parent_Type); 6174 6175 -- A type extension of a type with unknown discriminants is an 6176 -- indefinite type that the back-end cannot handle directly. 6177 -- We treat it as a private type, and build a completion that is 6178 -- derived from the full view of the parent, and hopefully has 6179 -- known discriminants. 6180 6181 -- If the full view of the parent type has an underlying record view, 6182 -- use it to generate the underlying record view of this derived type 6183 -- (required for chains of derivations with unknown discriminants). 6184 6185 -- Minor optimization: we avoid the generation of useless underlying 6186 -- record view entities if the private type declaration has unknown 6187 -- discriminants but its corresponding full view has no 6188 -- discriminants. 6189 6190 if Has_Unknown_Discriminants (Parent_Type) 6191 and then Present (Full_P) 6192 and then (Has_Discriminants (Full_P) 6193 or else Present (Underlying_Record_View (Full_P))) 6194 and then not In_Open_Scopes (Par_Scope) 6195 and then Expander_Active 6196 then 6197 declare 6198 Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T'); 6199 New_Ext : constant Node_Id := 6200 Copy_Separate_Tree 6201 (Record_Extension_Part (Type_Definition (N))); 6202 Decl : Node_Id; 6203 6204 begin 6205 Build_Derived_Record_Type 6206 (N, Parent_Type, Derived_Type, Derive_Subps); 6207 6208 -- Build anonymous completion, as a derivation from the full 6209 -- view of the parent. This is not a completion in the usual 6210 -- sense, because the current type is not private. 6211 6212 Decl := 6213 Make_Full_Type_Declaration (Loc, 6214 Defining_Identifier => Full_Der, 6215 Type_Definition => 6216 Make_Derived_Type_Definition (Loc, 6217 Subtype_Indication => 6218 New_Copy_Tree 6219 (Subtype_Indication (Type_Definition (N))), 6220 Record_Extension_Part => New_Ext)); 6221 6222 -- If the parent type has an underlying record view, use it 6223 -- here to build the new underlying record view. 6224 6225 if Present (Underlying_Record_View (Full_P)) then 6226 pragma Assert 6227 (Nkind (Subtype_Indication (Type_Definition (Decl))) 6228 = N_Identifier); 6229 Set_Entity (Subtype_Indication (Type_Definition (Decl)), 6230 Underlying_Record_View (Full_P)); 6231 end if; 6232 6233 Install_Private_Declarations (Par_Scope); 6234 Install_Visible_Declarations (Par_Scope); 6235 Insert_Before (N, Decl); 6236 6237 -- Mark entity as an underlying record view before analysis, 6238 -- to avoid generating the list of its primitive operations 6239 -- (which is not really required for this entity) and thus 6240 -- prevent spurious errors associated with missing overriding 6241 -- of abstract primitives (overridden only for Derived_Type). 6242 6243 Set_Ekind (Full_Der, E_Record_Type); 6244 Set_Is_Underlying_Record_View (Full_Der); 6245 6246 Analyze (Decl); 6247 6248 pragma Assert (Has_Discriminants (Full_Der) 6249 and then not Has_Unknown_Discriminants (Full_Der)); 6250 6251 Uninstall_Declarations (Par_Scope); 6252 6253 -- Freeze the underlying record view, to prevent generation of 6254 -- useless dispatching information, which is simply shared with 6255 -- the real derived type. 6256 6257 Set_Is_Frozen (Full_Der); 6258 6259 -- Set up links between real entity and underlying record view 6260 6261 Set_Underlying_Record_View (Derived_Type, Base_Type (Full_Der)); 6262 Set_Underlying_Record_View (Base_Type (Full_Der), Derived_Type); 6263 end; 6264 6265 -- If discriminants are known, build derived record 6266 6267 else 6268 Build_Derived_Record_Type 6269 (N, Parent_Type, Derived_Type, Derive_Subps); 6270 end if; 6271 6272 return; 6273 6274 elsif Has_Discriminants (Parent_Type) then 6275 if Present (Full_View (Parent_Type)) then 6276 if not Is_Completion then 6277 6278 -- Copy declaration for subsequent analysis, to provide a 6279 -- completion for what is a private declaration. Indicate that 6280 -- the full type is internally generated. 6281 6282 Full_Decl := New_Copy_Tree (N); 6283 Full_Der := New_Copy (Derived_Type); 6284 Set_Comes_From_Source (Full_Decl, False); 6285 Set_Comes_From_Source (Full_Der, False); 6286 Set_Parent (Full_Der, Full_Decl); 6287 6288 Insert_After (N, Full_Decl); 6289 6290 else 6291 -- If this is a completion, the full view being built is itself 6292 -- private. We build a subtype of the parent with the same 6293 -- constraints as this full view, to convey to the back end the 6294 -- constrained components and the size of this subtype. If the 6295 -- parent is constrained, its full view can serve as the 6296 -- underlying full view of the derived type. 6297 6298 if No (Discriminant_Specifications (N)) then 6299 if Nkind (Subtype_Indication (Type_Definition (N))) = 6300 N_Subtype_Indication 6301 then 6302 Build_Underlying_Full_View (N, Derived_Type, Parent_Type); 6303 6304 elsif Is_Constrained (Full_View (Parent_Type)) then 6305 Set_Underlying_Full_View 6306 (Derived_Type, Full_View (Parent_Type)); 6307 end if; 6308 6309 else 6310 -- If there are new discriminants, the parent subtype is 6311 -- constrained by them, but it is not clear how to build 6312 -- the Underlying_Full_View in this case??? 6313 6314 null; 6315 end if; 6316 end if; 6317 end if; 6318 6319 -- Build partial view of derived type from partial view of parent 6320 6321 Build_Derived_Record_Type 6322 (N, Parent_Type, Derived_Type, Derive_Subps); 6323 6324 if Present (Full_View (Parent_Type)) and then not Is_Completion then 6325 if not In_Open_Scopes (Par_Scope) 6326 or else not In_Same_Source_Unit (N, Parent_Type) 6327 then 6328 -- Swap partial and full views temporarily 6329 6330 Install_Private_Declarations (Par_Scope); 6331 Install_Visible_Declarations (Par_Scope); 6332 Swapped := True; 6333 end if; 6334 6335 -- Build full view of derived type from full view of parent which 6336 -- is now installed. Subprograms have been derived on the partial 6337 -- view, the completion does not derive them anew. 6338 6339 if not Is_Tagged_Type (Parent_Type) then 6340 6341 -- If the parent is itself derived from another private type, 6342 -- installing the private declarations has not affected its 6343 -- privacy status, so use its own full view explicitly. 6344 6345 if Is_Private_Type (Parent_Type) then 6346 Build_Derived_Record_Type 6347 (Full_Decl, Full_View (Parent_Type), Full_Der, False); 6348 else 6349 Build_Derived_Record_Type 6350 (Full_Decl, Parent_Type, Full_Der, False); 6351 end if; 6352 6353 else 6354 -- If full view of parent is tagged, the completion inherits 6355 -- the proper primitive operations. 6356 6357 Set_Defining_Identifier (Full_Decl, Full_Der); 6358 Build_Derived_Record_Type 6359 (Full_Decl, Parent_Type, Full_Der, Derive_Subps); 6360 end if; 6361 6362 -- The full declaration has been introduced into the tree and 6363 -- processed in the step above. It should not be analyzed again 6364 -- (when encountered later in the current list of declarations) 6365 -- to prevent spurious name conflicts. The full entity remains 6366 -- invisible. 6367 6368 Set_Analyzed (Full_Decl); 6369 6370 if Swapped then 6371 Uninstall_Declarations (Par_Scope); 6372 6373 if In_Open_Scopes (Par_Scope) then 6374 Install_Visible_Declarations (Par_Scope); 6375 end if; 6376 end if; 6377 6378 Der_Base := Base_Type (Derived_Type); 6379 Set_Full_View (Derived_Type, Full_Der); 6380 Set_Full_View (Der_Base, Base_Type (Full_Der)); 6381 6382 -- Copy the discriminant list from full view to the partial views 6383 -- (base type and its subtype). Gigi requires that the partial and 6384 -- full views have the same discriminants. 6385 6386 -- Note that since the partial view is pointing to discriminants 6387 -- in the full view, their scope will be that of the full view. 6388 -- This might cause some front end problems and need adjustment??? 6389 6390 Discr := First_Discriminant (Base_Type (Full_Der)); 6391 Set_First_Entity (Der_Base, Discr); 6392 6393 loop 6394 Last_Discr := Discr; 6395 Next_Discriminant (Discr); 6396 exit when No (Discr); 6397 end loop; 6398 6399 Set_Last_Entity (Der_Base, Last_Discr); 6400 6401 Set_First_Entity (Derived_Type, First_Entity (Der_Base)); 6402 Set_Last_Entity (Derived_Type, Last_Entity (Der_Base)); 6403 Set_Stored_Constraint (Full_Der, Stored_Constraint (Derived_Type)); 6404 6405 else 6406 -- If this is a completion, the derived type stays private and 6407 -- there is no need to create a further full view, except in the 6408 -- unusual case when the derivation is nested within a child unit, 6409 -- see below. 6410 6411 null; 6412 end if; 6413 6414 elsif Present (Full_View (Parent_Type)) 6415 and then Has_Discriminants (Full_View (Parent_Type)) 6416 then 6417 if Has_Unknown_Discriminants (Parent_Type) 6418 and then Nkind (Subtype_Indication (Type_Definition (N))) = 6419 N_Subtype_Indication 6420 then 6421 Error_Msg_N 6422 ("cannot constrain type with unknown discriminants", 6423 Subtype_Indication (Type_Definition (N))); 6424 return; 6425 end if; 6426 6427 -- If full view of parent is a record type, build full view as a 6428 -- derivation from the parent's full view. Partial view remains 6429 -- private. For code generation and linking, the full view must have 6430 -- the same public status as the partial one. This full view is only 6431 -- needed if the parent type is in an enclosing scope, so that the 6432 -- full view may actually become visible, e.g. in a child unit. This 6433 -- is both more efficient, and avoids order of freezing problems with 6434 -- the added entities. 6435 6436 if not Is_Private_Type (Full_View (Parent_Type)) 6437 and then (In_Open_Scopes (Scope (Parent_Type))) 6438 then 6439 Full_Der := 6440 Make_Defining_Identifier (Sloc (Derived_Type), 6441 Chars => Chars (Derived_Type)); 6442 6443 Set_Is_Itype (Full_Der); 6444 Set_Has_Private_Declaration (Full_Der); 6445 Set_Has_Private_Declaration (Derived_Type); 6446 Set_Associated_Node_For_Itype (Full_Der, N); 6447 Set_Parent (Full_Der, Parent (Derived_Type)); 6448 Set_Full_View (Derived_Type, Full_Der); 6449 Set_Is_Public (Full_Der, Is_Public (Derived_Type)); 6450 Full_P := Full_View (Parent_Type); 6451 Exchange_Declarations (Parent_Type); 6452 Copy_And_Build; 6453 Exchange_Declarations (Full_P); 6454 6455 else 6456 Build_Derived_Record_Type 6457 (N, Full_View (Parent_Type), Derived_Type, 6458 Derive_Subps => False); 6459 6460 -- Except in the context of the full view of the parent, there 6461 -- are no non-extension aggregates for the derived type. 6462 6463 Set_Has_Private_Ancestor (Derived_Type); 6464 end if; 6465 6466 -- In any case, the primitive operations are inherited from the 6467 -- parent type, not from the internal full view. 6468 6469 Set_Etype (Base_Type (Derived_Type), Base_Type (Parent_Type)); 6470 6471 if Derive_Subps then 6472 Derive_Subprograms (Parent_Type, Derived_Type); 6473 end if; 6474 6475 else 6476 -- Untagged type, No discriminants on either view 6477 6478 if Nkind (Subtype_Indication (Type_Definition (N))) = 6479 N_Subtype_Indication 6480 then 6481 Error_Msg_N 6482 ("illegal constraint on type without discriminants", N); 6483 end if; 6484 6485 if Present (Discriminant_Specifications (N)) 6486 and then Present (Full_View (Parent_Type)) 6487 and then not Is_Tagged_Type (Full_View (Parent_Type)) 6488 then 6489 Error_Msg_N ("cannot add discriminants to untagged type", N); 6490 end if; 6491 6492 Set_Stored_Constraint (Derived_Type, No_Elist); 6493 Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); 6494 Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); 6495 Set_Has_Controlled_Component 6496 (Derived_Type, Has_Controlled_Component 6497 (Parent_Type)); 6498 6499 -- Direct controlled types do not inherit Finalize_Storage_Only flag 6500 6501 if not Is_Controlled (Parent_Type) then 6502 Set_Finalize_Storage_Only 6503 (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type)); 6504 end if; 6505 6506 -- Construct the implicit full view by deriving from full view of the 6507 -- parent type. In order to get proper visibility, we install the 6508 -- parent scope and its declarations. 6509 6510 -- ??? If the parent is untagged private and its completion is 6511 -- tagged, this mechanism will not work because we cannot derive from 6512 -- the tagged full view unless we have an extension. 6513 6514 if Present (Full_View (Parent_Type)) 6515 and then not Is_Tagged_Type (Full_View (Parent_Type)) 6516 and then not Is_Completion 6517 then 6518 Full_Der := 6519 Make_Defining_Identifier 6520 (Sloc (Derived_Type), Chars (Derived_Type)); 6521 Set_Is_Itype (Full_Der); 6522 Set_Has_Private_Declaration (Full_Der); 6523 Set_Has_Private_Declaration (Derived_Type); 6524 Set_Associated_Node_For_Itype (Full_Der, N); 6525 Set_Parent (Full_Der, Parent (Derived_Type)); 6526 Set_Full_View (Derived_Type, Full_Der); 6527 6528 if not In_Open_Scopes (Par_Scope) then 6529 Install_Private_Declarations (Par_Scope); 6530 Install_Visible_Declarations (Par_Scope); 6531 Copy_And_Build; 6532 Uninstall_Declarations (Par_Scope); 6533 6534 -- If parent scope is open and in another unit, and parent has a 6535 -- completion, then the derivation is taking place in the visible 6536 -- part of a child unit. In that case retrieve the full view of 6537 -- the parent momentarily. 6538 6539 elsif not In_Same_Source_Unit (N, Parent_Type) then 6540 Full_P := Full_View (Parent_Type); 6541 Exchange_Declarations (Parent_Type); 6542 Copy_And_Build; 6543 Exchange_Declarations (Full_P); 6544 6545 -- Otherwise it is a local derivation 6546 6547 else 6548 Copy_And_Build; 6549 end if; 6550 6551 Set_Scope (Full_Der, Current_Scope); 6552 Set_Is_First_Subtype (Full_Der, 6553 Is_First_Subtype (Derived_Type)); 6554 Set_Has_Size_Clause (Full_Der, False); 6555 Set_Has_Alignment_Clause (Full_Der, False); 6556 Set_Next_Entity (Full_Der, Empty); 6557 Set_Has_Delayed_Freeze (Full_Der); 6558 Set_Is_Frozen (Full_Der, False); 6559 Set_Freeze_Node (Full_Der, Empty); 6560 Set_Depends_On_Private (Full_Der, 6561 Has_Private_Component (Full_Der)); 6562 Set_Public_Status (Full_Der); 6563 end if; 6564 end if; 6565 6566 Set_Has_Unknown_Discriminants (Derived_Type, 6567 Has_Unknown_Discriminants (Parent_Type)); 6568 6569 if Is_Private_Type (Derived_Type) then 6570 Set_Private_Dependents (Derived_Type, New_Elmt_List); 6571 end if; 6572 6573 if Is_Private_Type (Parent_Type) 6574 and then Base_Type (Parent_Type) = Parent_Type 6575 and then In_Open_Scopes (Scope (Parent_Type)) 6576 then 6577 Append_Elmt (Derived_Type, Private_Dependents (Parent_Type)); 6578 6579 -- Check for unusual case where a type completed by a private 6580 -- derivation occurs within a package nested in a child unit, and 6581 -- the parent is declared in an ancestor. 6582 6583 if Is_Child_Unit (Scope (Current_Scope)) 6584 and then Is_Completion 6585 and then In_Private_Part (Current_Scope) 6586 and then Scope (Parent_Type) /= Current_Scope 6587 6588 -- Note that if the parent has a completion in the private part, 6589 -- (which is itself a derivation from some other private type) 6590 -- it is that completion that is visible, there is no full view 6591 -- available, and no special processing is needed. 6592 6593 and then Present (Full_View (Parent_Type)) 6594 then 6595 -- In this case, the full view of the parent type will become 6596 -- visible in the body of the enclosing child, and only then will 6597 -- the current type be possibly non-private. We build an 6598 -- underlying full view that will be installed when the enclosing 6599 -- child body is compiled. 6600 6601 Full_Der := 6602 Make_Defining_Identifier 6603 (Sloc (Derived_Type), Chars (Derived_Type)); 6604 Set_Is_Itype (Full_Der); 6605 Build_Itype_Reference (Full_Der, N); 6606 6607 -- The full view will be used to swap entities on entry/exit to 6608 -- the body, and must appear in the entity list for the package. 6609 6610 Append_Entity (Full_Der, Scope (Derived_Type)); 6611 Set_Has_Private_Declaration (Full_Der); 6612 Set_Has_Private_Declaration (Derived_Type); 6613 Set_Associated_Node_For_Itype (Full_Der, N); 6614 Set_Parent (Full_Der, Parent (Derived_Type)); 6615 Full_P := Full_View (Parent_Type); 6616 Exchange_Declarations (Parent_Type); 6617 Copy_And_Build; 6618 Exchange_Declarations (Full_P); 6619 Set_Underlying_Full_View (Derived_Type, Full_Der); 6620 end if; 6621 end if; 6622 end Build_Derived_Private_Type; 6623 6624 ------------------------------- 6625 -- Build_Derived_Record_Type -- 6626 ------------------------------- 6627 6628 -- 1. INTRODUCTION 6629 6630 -- Ideally we would like to use the same model of type derivation for 6631 -- tagged and untagged record types. Unfortunately this is not quite 6632 -- possible because the semantics of representation clauses is different 6633 -- for tagged and untagged records under inheritance. Consider the 6634 -- following: 6635 6636 -- type R (...) is [tagged] record ... end record; 6637 -- type T (...) is new R (...) [with ...]; 6638 6639 -- The representation clauses for T can specify a completely different 6640 -- record layout from R's. Hence the same component can be placed in two 6641 -- very different positions in objects of type T and R. If R and T are 6642 -- tagged types, representation clauses for T can only specify the layout 6643 -- of non inherited components, thus components that are common in R and T 6644 -- have the same position in objects of type R and T. 6645 6646 -- This has two implications. The first is that the entire tree for R's 6647 -- declaration needs to be copied for T in the untagged case, so that T 6648 -- can be viewed as a record type of its own with its own representation 6649 -- clauses. The second implication is the way we handle discriminants. 6650 -- Specifically, in the untagged case we need a way to communicate to Gigi 6651 -- what are the real discriminants in the record, while for the semantics 6652 -- we need to consider those introduced by the user to rename the 6653 -- discriminants in the parent type. This is handled by introducing the 6654 -- notion of stored discriminants. See below for more. 6655 6656 -- Fortunately the way regular components are inherited can be handled in 6657 -- the same way in tagged and untagged types. 6658 6659 -- To complicate things a bit more the private view of a private extension 6660 -- cannot be handled in the same way as the full view (for one thing the 6661 -- semantic rules are somewhat different). We will explain what differs 6662 -- below. 6663 6664 -- 2. DISCRIMINANTS UNDER INHERITANCE 6665 6666 -- The semantic rules governing the discriminants of derived types are 6667 -- quite subtle. 6668 6669 -- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new 6670 -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART] 6671 6672 -- If parent type has discriminants, then the discriminants that are 6673 -- declared in the derived type are [3.4 (11)]: 6674 6675 -- o The discriminants specified by a new KNOWN_DISCRIMINANT_PART, if 6676 -- there is one; 6677 6678 -- o Otherwise, each discriminant of the parent type (implicitly declared 6679 -- in the same order with the same specifications). In this case, the 6680 -- discriminants are said to be "inherited", or if unknown in the parent 6681 -- are also unknown in the derived type. 6682 6683 -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]: 6684 6685 -- o The parent subtype shall be constrained; 6686 6687 -- o If the parent type is not a tagged type, then each discriminant of 6688 -- the derived type shall be used in the constraint defining a parent 6689 -- subtype. [Implementation note: This ensures that the new discriminant 6690 -- can share storage with an existing discriminant.] 6691 6692 -- For the derived type each discriminant of the parent type is either 6693 -- inherited, constrained to equal some new discriminant of the derived 6694 -- type, or constrained to the value of an expression. 6695 6696 -- When inherited or constrained to equal some new discriminant, the 6697 -- parent discriminant and the discriminant of the derived type are said 6698 -- to "correspond". 6699 6700 -- If a discriminant of the parent type is constrained to a specific value 6701 -- in the derived type definition, then the discriminant is said to be 6702 -- "specified" by that derived type definition. 6703 6704 -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES 6705 6706 -- We have spoken about stored discriminants in point 1 (introduction) 6707 -- above. There are two sort of stored discriminants: implicit and 6708 -- explicit. As long as the derived type inherits the same discriminants as 6709 -- the root record type, stored discriminants are the same as regular 6710 -- discriminants, and are said to be implicit. However, if any discriminant 6711 -- in the root type was renamed in the derived type, then the derived 6712 -- type will contain explicit stored discriminants. Explicit stored 6713 -- discriminants are discriminants in addition to the semantically visible 6714 -- discriminants defined for the derived type. Stored discriminants are 6715 -- used by Gigi to figure out what are the physical discriminants in 6716 -- objects of the derived type (see precise definition in einfo.ads). 6717 -- As an example, consider the following: 6718 6719 -- type R (D1, D2, D3 : Int) is record ... end record; 6720 -- type T1 is new R; 6721 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1); 6722 -- type T3 is new T2; 6723 -- type T4 (Y : Int) is new T3 (Y, 99); 6724 6725 -- The following table summarizes the discriminants and stored 6726 -- discriminants in R and T1 through T4. 6727 6728 -- Type Discrim Stored Discrim Comment 6729 -- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R 6730 -- T1 (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in T1 6731 -- T2 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T2 6732 -- T3 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T3 6733 -- T4 (Y) (D1, D2, D3) Girder discrims EXPLICIT in T4 6734 6735 -- Field Corresponding_Discriminant (abbreviated CD below) allows us to 6736 -- find the corresponding discriminant in the parent type, while 6737 -- Original_Record_Component (abbreviated ORC below), the actual physical 6738 -- component that is renamed. Finally the field Is_Completely_Hidden 6739 -- (abbreviated ICH below) is set for all explicit stored discriminants 6740 -- (see einfo.ads for more info). For the above example this gives: 6741 6742 -- Discrim CD ORC ICH 6743 -- ^^^^^^^ ^^ ^^^ ^^^ 6744 -- D1 in R empty itself no 6745 -- D2 in R empty itself no 6746 -- D3 in R empty itself no 6747 6748 -- D1 in T1 D1 in R itself no 6749 -- D2 in T1 D2 in R itself no 6750 -- D3 in T1 D3 in R itself no 6751 6752 -- X1 in T2 D3 in T1 D3 in T2 no 6753 -- X2 in T2 D1 in T1 D1 in T2 no 6754 -- D1 in T2 empty itself yes 6755 -- D2 in T2 empty itself yes 6756 -- D3 in T2 empty itself yes 6757 6758 -- X1 in T3 X1 in T2 D3 in T3 no 6759 -- X2 in T3 X2 in T2 D1 in T3 no 6760 -- D1 in T3 empty itself yes 6761 -- D2 in T3 empty itself yes 6762 -- D3 in T3 empty itself yes 6763 6764 -- Y in T4 X1 in T3 D3 in T3 no 6765 -- D1 in T3 empty itself yes 6766 -- D2 in T3 empty itself yes 6767 -- D3 in T3 empty itself yes 6768 6769 -- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES 6770 6771 -- Type derivation for tagged types is fairly straightforward. If no 6772 -- discriminants are specified by the derived type, these are inherited 6773 -- from the parent. No explicit stored discriminants are ever necessary. 6774 -- The only manipulation that is done to the tree is that of adding a 6775 -- _parent field with parent type and constrained to the same constraint 6776 -- specified for the parent in the derived type definition. For instance: 6777 6778 -- type R (D1, D2, D3 : Int) is tagged record ... end record; 6779 -- type T1 is new R with null record; 6780 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with null record; 6781 6782 -- are changed into: 6783 6784 -- type T1 (D1, D2, D3 : Int) is new R (D1, D2, D3) with record 6785 -- _parent : R (D1, D2, D3); 6786 -- end record; 6787 6788 -- type T2 (X1, X2: Int) is new T1 (X2, 88, X1) with record 6789 -- _parent : T1 (X2, 88, X1); 6790 -- end record; 6791 6792 -- The discriminants actually present in R, T1 and T2 as well as their CD, 6793 -- ORC and ICH fields are: 6794 6795 -- Discrim CD ORC ICH 6796 -- ^^^^^^^ ^^ ^^^ ^^^ 6797 -- D1 in R empty itself no 6798 -- D2 in R empty itself no 6799 -- D3 in R empty itself no 6800 6801 -- D1 in T1 D1 in R D1 in R no 6802 -- D2 in T1 D2 in R D2 in R no 6803 -- D3 in T1 D3 in R D3 in R no 6804 6805 -- X1 in T2 D3 in T1 D3 in R no 6806 -- X2 in T2 D1 in T1 D1 in R no 6807 6808 -- 5. FIRST TRANSFORMATION FOR DERIVED RECORDS 6809 -- 6810 -- Regardless of whether we dealing with a tagged or untagged type 6811 -- we will transform all derived type declarations of the form 6812 -- 6813 -- type T is new R (...) [with ...]; 6814 -- or 6815 -- subtype S is R (...); 6816 -- type T is new S [with ...]; 6817 -- into 6818 -- type BT is new R [with ...]; 6819 -- subtype T is BT (...); 6820 -- 6821 -- That is, the base derived type is constrained only if it has no 6822 -- discriminants. The reason for doing this is that GNAT's semantic model 6823 -- assumes that a base type with discriminants is unconstrained. 6824 -- 6825 -- Note that, strictly speaking, the above transformation is not always 6826 -- correct. Consider for instance the following excerpt from ACVC b34011a: 6827 -- 6828 -- procedure B34011A is 6829 -- type REC (D : integer := 0) is record 6830 -- I : Integer; 6831 -- end record; 6832 6833 -- package P is 6834 -- type T6 is new Rec; 6835 -- function F return T6; 6836 -- end P; 6837 6838 -- use P; 6839 -- package Q6 is 6840 -- type U is new T6 (Q6.F.I); -- ERROR: Q6.F. 6841 -- end Q6; 6842 -- 6843 -- The definition of Q6.U is illegal. However transforming Q6.U into 6844 6845 -- type BaseU is new T6; 6846 -- subtype U is BaseU (Q6.F.I) 6847 6848 -- turns U into a legal subtype, which is incorrect. To avoid this problem 6849 -- we always analyze the constraint (in this case (Q6.F.I)) before applying 6850 -- the transformation described above. 6851 6852 -- There is another instance where the above transformation is incorrect. 6853 -- Consider: 6854 6855 -- package Pack is 6856 -- type Base (D : Integer) is tagged null record; 6857 -- procedure P (X : Base); 6858 6859 -- type Der is new Base (2) with null record; 6860 -- procedure P (X : Der); 6861 -- end Pack; 6862 6863 -- Then the above transformation turns this into 6864 6865 -- type Der_Base is new Base with null record; 6866 -- -- procedure P (X : Base) is implicitly inherited here 6867 -- -- as procedure P (X : Der_Base). 6868 6869 -- subtype Der is Der_Base (2); 6870 -- procedure P (X : Der); 6871 -- -- The overriding of P (X : Der_Base) is illegal since we 6872 -- -- have a parameter conformance problem. 6873 6874 -- To get around this problem, after having semantically processed Der_Base 6875 -- and the rewritten subtype declaration for Der, we copy Der_Base field 6876 -- Discriminant_Constraint from Der so that when parameter conformance is 6877 -- checked when P is overridden, no semantic errors are flagged. 6878 6879 -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS 6880 6881 -- Regardless of whether we are dealing with a tagged or untagged type 6882 -- we will transform all derived type declarations of the form 6883 6884 -- type R (D1, .., Dn : ...) is [tagged] record ...; 6885 -- type T is new R [with ...]; 6886 -- into 6887 -- type T (D1, .., Dn : ...) is new R (D1, .., Dn) [with ...]; 6888 6889 -- The reason for such transformation is that it allows us to implement a 6890 -- very clean form of component inheritance as explained below. 6891 6892 -- Note that this transformation is not achieved by direct tree rewriting 6893 -- and manipulation, but rather by redoing the semantic actions that the 6894 -- above transformation will entail. This is done directly in routine 6895 -- Inherit_Components. 6896 6897 -- 7. TYPE DERIVATION AND COMPONENT INHERITANCE 6898 6899 -- In both tagged and untagged derived types, regular non discriminant 6900 -- components are inherited in the derived type from the parent type. In 6901 -- the absence of discriminants component, inheritance is straightforward 6902 -- as components can simply be copied from the parent. 6903 6904 -- If the parent has discriminants, inheriting components constrained with 6905 -- these discriminants requires caution. Consider the following example: 6906 6907 -- type R (D1, D2 : Positive) is [tagged] record 6908 -- S : String (D1 .. D2); 6909 -- end record; 6910 6911 -- type T1 is new R [with null record]; 6912 -- type T2 (X : positive) is new R (1, X) [with null record]; 6913 6914 -- As explained in 6. above, T1 is rewritten as 6915 -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record]; 6916 -- which makes the treatment for T1 and T2 identical. 6917 6918 -- What we want when inheriting S, is that references to D1 and D2 in R are 6919 -- replaced with references to their correct constraints, i.e. D1 and D2 in 6920 -- T1 and 1 and X in T2. So all R's discriminant references are replaced 6921 -- with either discriminant references in the derived type or expressions. 6922 -- This replacement is achieved as follows: before inheriting R's 6923 -- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is 6924 -- created in the scope of T1 (resp. scope of T2) so that discriminants D1 6925 -- and D2 of T1 are visible (resp. discriminant X of T2 is visible). 6926 -- For T2, for instance, this has the effect of replacing String (D1 .. D2) 6927 -- by String (1 .. X). 6928 6929 -- 8. TYPE DERIVATION IN PRIVATE TYPE EXTENSIONS 6930 6931 -- We explain here the rules governing private type extensions relevant to 6932 -- type derivation. These rules are explained on the following example: 6933 6934 -- type D [(...)] is new A [(...)] with private; <-- partial view 6935 -- type D [(...)] is new P [(...)] with null record; <-- full view 6936 6937 -- Type A is called the ancestor subtype of the private extension. 6938 -- Type P is the parent type of the full view of the private extension. It 6939 -- must be A or a type derived from A. 6940 6941 -- The rules concerning the discriminants of private type extensions are 6942 -- [7.3(10-13)]: 6943 6944 -- o If a private extension inherits known discriminants from the ancestor 6945 -- subtype, then the full view shall also inherit its discriminants from 6946 -- the ancestor subtype and the parent subtype of the full view shall be 6947 -- constrained if and only if the ancestor subtype is constrained. 6948 6949 -- o If a partial view has unknown discriminants, then the full view may 6950 -- define a definite or an indefinite subtype, with or without 6951 -- discriminants. 6952 6953 -- o If a partial view has neither known nor unknown discriminants, then 6954 -- the full view shall define a definite subtype. 6955 6956 -- o If the ancestor subtype of a private extension has constrained 6957 -- discriminants, then the parent subtype of the full view shall impose a 6958 -- statically matching constraint on those discriminants. 6959 6960 -- This means that only the following forms of private extensions are 6961 -- allowed: 6962 6963 -- type D is new A with private; <-- partial view 6964 -- type D is new P with null record; <-- full view 6965 6966 -- If A has no discriminants than P has no discriminants, otherwise P must 6967 -- inherit A's discriminants. 6968 6969 -- type D is new A (...) with private; <-- partial view 6970 -- type D is new P (:::) with null record; <-- full view 6971 6972 -- P must inherit A's discriminants and (...) and (:::) must statically 6973 -- match. 6974 6975 -- subtype A is R (...); 6976 -- type D is new A with private; <-- partial view 6977 -- type D is new P with null record; <-- full view 6978 6979 -- P must have inherited R's discriminants and must be derived from A or 6980 -- any of its subtypes. 6981 6982 -- type D (..) is new A with private; <-- partial view 6983 -- type D (..) is new P [(:::)] with null record; <-- full view 6984 6985 -- No specific constraints on P's discriminants or constraint (:::). 6986 -- Note that A can be unconstrained, but the parent subtype P must either 6987 -- be constrained or (:::) must be present. 6988 6989 -- type D (..) is new A [(...)] with private; <-- partial view 6990 -- type D (..) is new P [(:::)] with null record; <-- full view 6991 6992 -- P's constraints on A's discriminants must statically match those 6993 -- imposed by (...). 6994 6995 -- 9. IMPLEMENTATION OF TYPE DERIVATION FOR PRIVATE EXTENSIONS 6996 6997 -- The full view of a private extension is handled exactly as described 6998 -- above. The model chose for the private view of a private extension is 6999 -- the same for what concerns discriminants (i.e. they receive the same 7000 -- treatment as in the tagged case). However, the private view of the 7001 -- private extension always inherits the components of the parent base, 7002 -- without replacing any discriminant reference. Strictly speaking this is 7003 -- incorrect. However, Gigi never uses this view to generate code so this 7004 -- is a purely semantic issue. In theory, a set of transformations similar 7005 -- to those given in 5. and 6. above could be applied to private views of 7006 -- private extensions to have the same model of component inheritance as 7007 -- for non private extensions. However, this is not done because it would 7008 -- further complicate private type processing. Semantically speaking, this 7009 -- leaves us in an uncomfortable situation. As an example consider: 7010 7011 -- package Pack is 7012 -- type R (D : integer) is tagged record 7013 -- S : String (1 .. D); 7014 -- end record; 7015 -- procedure P (X : R); 7016 -- type T is new R (1) with private; 7017 -- private 7018 -- type T is new R (1) with null record; 7019 -- end; 7020 7021 -- This is transformed into: 7022 7023 -- package Pack is 7024 -- type R (D : integer) is tagged record 7025 -- S : String (1 .. D); 7026 -- end record; 7027 -- procedure P (X : R); 7028 -- type T is new R (1) with private; 7029 -- private 7030 -- type BaseT is new R with null record; 7031 -- subtype T is BaseT (1); 7032 -- end; 7033 7034 -- (strictly speaking the above is incorrect Ada) 7035 7036 -- From the semantic standpoint the private view of private extension T 7037 -- should be flagged as constrained since one can clearly have 7038 -- 7039 -- Obj : T; 7040 -- 7041 -- in a unit withing Pack. However, when deriving subprograms for the 7042 -- private view of private extension T, T must be seen as unconstrained 7043 -- since T has discriminants (this is a constraint of the current 7044 -- subprogram derivation model). Thus, when processing the private view of 7045 -- a private extension such as T, we first mark T as unconstrained, we 7046 -- process it, we perform program derivation and just before returning from 7047 -- Build_Derived_Record_Type we mark T as constrained. 7048 7049 -- ??? Are there are other uncomfortable cases that we will have to 7050 -- deal with. 7051 7052 -- 10. RECORD_TYPE_WITH_PRIVATE complications 7053 7054 -- Types that are derived from a visible record type and have a private 7055 -- extension present other peculiarities. They behave mostly like private 7056 -- types, but if they have primitive operations defined, these will not 7057 -- have the proper signatures for further inheritance, because other 7058 -- primitive operations will use the implicit base that we define for 7059 -- private derivations below. This affect subprogram inheritance (see 7060 -- Derive_Subprograms for details). We also derive the implicit base from 7061 -- the base type of the full view, so that the implicit base is a record 7062 -- type and not another private type, This avoids infinite loops. 7063 7064 procedure Build_Derived_Record_Type 7065 (N : Node_Id; 7066 Parent_Type : Entity_Id; 7067 Derived_Type : Entity_Id; 7068 Derive_Subps : Boolean := True) 7069 is 7070 Discriminant_Specs : constant Boolean := 7071 Present (Discriminant_Specifications (N)); 7072 Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type); 7073 Loc : constant Source_Ptr := Sloc (N); 7074 Private_Extension : constant Boolean := 7075 Nkind (N) = N_Private_Extension_Declaration; 7076 Assoc_List : Elist_Id; 7077 Constraint_Present : Boolean; 7078 Constrs : Elist_Id; 7079 Discrim : Entity_Id; 7080 Indic : Node_Id; 7081 Inherit_Discrims : Boolean := False; 7082 Last_Discrim : Entity_Id; 7083 New_Base : Entity_Id; 7084 New_Decl : Node_Id; 7085 New_Discrs : Elist_Id; 7086 New_Indic : Node_Id; 7087 Parent_Base : Entity_Id; 7088 Save_Etype : Entity_Id; 7089 Save_Discr_Constr : Elist_Id; 7090 Save_Next_Entity : Entity_Id; 7091 Type_Def : Node_Id; 7092 7093 Discs : Elist_Id := New_Elmt_List; 7094 -- An empty Discs list means that there were no constraints in the 7095 -- subtype indication or that there was an error processing it. 7096 7097 begin 7098 if Ekind (Parent_Type) = E_Record_Type_With_Private 7099 and then Present (Full_View (Parent_Type)) 7100 and then Has_Discriminants (Parent_Type) 7101 then 7102 Parent_Base := Base_Type (Full_View (Parent_Type)); 7103 else 7104 Parent_Base := Base_Type (Parent_Type); 7105 end if; 7106 7107 -- AI05-0115 : if this is a derivation from a private type in some 7108 -- other scope that may lead to invisible components for the derived 7109 -- type, mark it accordingly. 7110 7111 if Is_Private_Type (Parent_Type) then 7112 if Scope (Parent_Type) = Scope (Derived_Type) then 7113 null; 7114 7115 elsif In_Open_Scopes (Scope (Parent_Type)) 7116 and then In_Private_Part (Scope (Parent_Type)) 7117 then 7118 null; 7119 7120 else 7121 Set_Has_Private_Ancestor (Derived_Type); 7122 end if; 7123 7124 else 7125 Set_Has_Private_Ancestor 7126 (Derived_Type, Has_Private_Ancestor (Parent_Type)); 7127 end if; 7128 7129 -- Before we start the previously documented transformations, here is 7130 -- little fix for size and alignment of tagged types. Normally when we 7131 -- derive type D from type P, we copy the size and alignment of P as the 7132 -- default for D, and in the absence of explicit representation clauses 7133 -- for D, the size and alignment are indeed the same as the parent. 7134 7135 -- But this is wrong for tagged types, since fields may be added, and 7136 -- the default size may need to be larger, and the default alignment may 7137 -- need to be larger. 7138 7139 -- We therefore reset the size and alignment fields in the tagged case. 7140 -- Note that the size and alignment will in any case be at least as 7141 -- large as the parent type (since the derived type has a copy of the 7142 -- parent type in the _parent field) 7143 7144 -- The type is also marked as being tagged here, which is needed when 7145 -- processing components with a self-referential anonymous access type 7146 -- in the call to Check_Anonymous_Access_Components below. Note that 7147 -- this flag is also set later on for completeness. 7148 7149 if Is_Tagged then 7150 Set_Is_Tagged_Type (Derived_Type); 7151 Init_Size_Align (Derived_Type); 7152 end if; 7153 7154 -- STEP 0a: figure out what kind of derived type declaration we have 7155 7156 if Private_Extension then 7157 Type_Def := N; 7158 Set_Ekind (Derived_Type, E_Record_Type_With_Private); 7159 7160 else 7161 Type_Def := Type_Definition (N); 7162 7163 -- Ekind (Parent_Base) is not necessarily E_Record_Type since 7164 -- Parent_Base can be a private type or private extension. However, 7165 -- for tagged types with an extension the newly added fields are 7166 -- visible and hence the Derived_Type is always an E_Record_Type. 7167 -- (except that the parent may have its own private fields). 7168 -- For untagged types we preserve the Ekind of the Parent_Base. 7169 7170 if Present (Record_Extension_Part (Type_Def)) then 7171 Set_Ekind (Derived_Type, E_Record_Type); 7172 7173 -- Create internal access types for components with anonymous 7174 -- access types. 7175 7176 if Ada_Version >= Ada_2005 then 7177 Check_Anonymous_Access_Components 7178 (N, Derived_Type, Derived_Type, 7179 Component_List (Record_Extension_Part (Type_Def))); 7180 end if; 7181 7182 else 7183 Set_Ekind (Derived_Type, Ekind (Parent_Base)); 7184 end if; 7185 end if; 7186 7187 -- Indic can either be an N_Identifier if the subtype indication 7188 -- contains no constraint or an N_Subtype_Indication if the subtype 7189 -- indication has a constraint. 7190 7191 Indic := Subtype_Indication (Type_Def); 7192 Constraint_Present := (Nkind (Indic) = N_Subtype_Indication); 7193 7194 -- Check that the type has visible discriminants. The type may be 7195 -- a private type with unknown discriminants whose full view has 7196 -- discriminants which are invisible. 7197 7198 if Constraint_Present then 7199 if not Has_Discriminants (Parent_Base) 7200 or else 7201 (Has_Unknown_Discriminants (Parent_Base) 7202 and then Is_Private_Type (Parent_Base)) 7203 then 7204 Error_Msg_N 7205 ("invalid constraint: type has no discriminant", 7206 Constraint (Indic)); 7207 7208 Constraint_Present := False; 7209 Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic))); 7210 7211 elsif Is_Constrained (Parent_Type) then 7212 Error_Msg_N 7213 ("invalid constraint: parent type is already constrained", 7214 Constraint (Indic)); 7215 7216 Constraint_Present := False; 7217 Rewrite (Indic, New_Copy_Tree (Subtype_Mark (Indic))); 7218 end if; 7219 end if; 7220 7221 -- STEP 0b: If needed, apply transformation given in point 5. above 7222 7223 if not Private_Extension 7224 and then Has_Discriminants (Parent_Type) 7225 and then not Discriminant_Specs 7226 and then (Is_Constrained (Parent_Type) or else Constraint_Present) 7227 then 7228 -- First, we must analyze the constraint (see comment in point 5.) 7229 7230 if Constraint_Present then 7231 New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic); 7232 7233 if Has_Discriminants (Derived_Type) 7234 and then Has_Private_Declaration (Derived_Type) 7235 and then Present (Discriminant_Constraint (Derived_Type)) 7236 then 7237 -- Verify that constraints of the full view statically match 7238 -- those given in the partial view. 7239 7240 declare 7241 C1, C2 : Elmt_Id; 7242 7243 begin 7244 C1 := First_Elmt (New_Discrs); 7245 C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); 7246 while Present (C1) and then Present (C2) loop 7247 if Fully_Conformant_Expressions (Node (C1), Node (C2)) 7248 or else 7249 (Is_OK_Static_Expression (Node (C1)) 7250 and then 7251 Is_OK_Static_Expression (Node (C2)) 7252 and then 7253 Expr_Value (Node (C1)) = Expr_Value (Node (C2))) 7254 then 7255 null; 7256 7257 else 7258 Error_Msg_N ( 7259 "constraint not conformant to previous declaration", 7260 Node (C1)); 7261 end if; 7262 7263 Next_Elmt (C1); 7264 Next_Elmt (C2); 7265 end loop; 7266 end; 7267 end if; 7268 end if; 7269 7270 -- Insert and analyze the declaration for the unconstrained base type 7271 7272 New_Base := Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B'); 7273 7274 New_Decl := 7275 Make_Full_Type_Declaration (Loc, 7276 Defining_Identifier => New_Base, 7277 Type_Definition => 7278 Make_Derived_Type_Definition (Loc, 7279 Abstract_Present => Abstract_Present (Type_Def), 7280 Limited_Present => Limited_Present (Type_Def), 7281 Subtype_Indication => 7282 New_Occurrence_Of (Parent_Base, Loc), 7283 Record_Extension_Part => 7284 Relocate_Node (Record_Extension_Part (Type_Def)), 7285 Interface_List => Interface_List (Type_Def))); 7286 7287 Set_Parent (New_Decl, Parent (N)); 7288 Mark_Rewrite_Insertion (New_Decl); 7289 Insert_Before (N, New_Decl); 7290 7291 -- In the extension case, make sure ancestor is frozen appropriately 7292 -- (see also non-discriminated case below). 7293 7294 if Present (Record_Extension_Part (Type_Def)) 7295 or else Is_Interface (Parent_Base) 7296 then 7297 Freeze_Before (New_Decl, Parent_Type); 7298 end if; 7299 7300 -- Note that this call passes False for the Derive_Subps parameter 7301 -- because subprogram derivation is deferred until after creating 7302 -- the subtype (see below). 7303 7304 Build_Derived_Type 7305 (New_Decl, Parent_Base, New_Base, 7306 Is_Completion => True, Derive_Subps => False); 7307 7308 -- ??? This needs re-examination to determine whether the 7309 -- above call can simply be replaced by a call to Analyze. 7310 7311 Set_Analyzed (New_Decl); 7312 7313 -- Insert and analyze the declaration for the constrained subtype 7314 7315 if Constraint_Present then 7316 New_Indic := 7317 Make_Subtype_Indication (Loc, 7318 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 7319 Constraint => Relocate_Node (Constraint (Indic))); 7320 7321 else 7322 declare 7323 Constr_List : constant List_Id := New_List; 7324 C : Elmt_Id; 7325 Expr : Node_Id; 7326 7327 begin 7328 C := First_Elmt (Discriminant_Constraint (Parent_Type)); 7329 while Present (C) loop 7330 Expr := Node (C); 7331 7332 -- It is safe here to call New_Copy_Tree since 7333 -- Force_Evaluation was called on each constraint in 7334 -- Build_Discriminant_Constraints. 7335 7336 Append (New_Copy_Tree (Expr), To => Constr_List); 7337 7338 Next_Elmt (C); 7339 end loop; 7340 7341 New_Indic := 7342 Make_Subtype_Indication (Loc, 7343 Subtype_Mark => New_Occurrence_Of (New_Base, Loc), 7344 Constraint => 7345 Make_Index_Or_Discriminant_Constraint (Loc, Constr_List)); 7346 end; 7347 end if; 7348 7349 Rewrite (N, 7350 Make_Subtype_Declaration (Loc, 7351 Defining_Identifier => Derived_Type, 7352 Subtype_Indication => New_Indic)); 7353 7354 Analyze (N); 7355 7356 -- Derivation of subprograms must be delayed until the full subtype 7357 -- has been established, to ensure proper overriding of subprograms 7358 -- inherited by full types. If the derivations occurred as part of 7359 -- the call to Build_Derived_Type above, then the check for type 7360 -- conformance would fail because earlier primitive subprograms 7361 -- could still refer to the full type prior the change to the new 7362 -- subtype and hence would not match the new base type created here. 7363 -- Subprograms are not derived, however, when Derive_Subps is False 7364 -- (since otherwise there could be redundant derivations). 7365 7366 if Derive_Subps then 7367 Derive_Subprograms (Parent_Type, Derived_Type); 7368 end if; 7369 7370 -- For tagged types the Discriminant_Constraint of the new base itype 7371 -- is inherited from the first subtype so that no subtype conformance 7372 -- problem arise when the first subtype overrides primitive 7373 -- operations inherited by the implicit base type. 7374 7375 if Is_Tagged then 7376 Set_Discriminant_Constraint 7377 (New_Base, Discriminant_Constraint (Derived_Type)); 7378 end if; 7379 7380 return; 7381 end if; 7382 7383 -- If we get here Derived_Type will have no discriminants or it will be 7384 -- a discriminated unconstrained base type. 7385 7386 -- STEP 1a: perform preliminary actions/checks for derived tagged types 7387 7388 if Is_Tagged then 7389 7390 -- The parent type is frozen for non-private extensions (RM 13.14(7)) 7391 -- The declaration of a specific descendant of an interface type 7392 -- freezes the interface type (RM 13.14). 7393 7394 if not Private_Extension or else Is_Interface (Parent_Base) then 7395 Freeze_Before (N, Parent_Type); 7396 end if; 7397 7398 -- In Ada 2005 (AI-344), the restriction that a derived tagged type 7399 -- cannot be declared at a deeper level than its parent type is 7400 -- removed. The check on derivation within a generic body is also 7401 -- relaxed, but there's a restriction that a derived tagged type 7402 -- cannot be declared in a generic body if it's derived directly 7403 -- or indirectly from a formal type of that generic. 7404 7405 if Ada_Version >= Ada_2005 then 7406 if Present (Enclosing_Generic_Body (Derived_Type)) then 7407 declare 7408 Ancestor_Type : Entity_Id; 7409 7410 begin 7411 -- Check to see if any ancestor of the derived type is a 7412 -- formal type. 7413 7414 Ancestor_Type := Parent_Type; 7415 while not Is_Generic_Type (Ancestor_Type) 7416 and then Etype (Ancestor_Type) /= Ancestor_Type 7417 loop 7418 Ancestor_Type := Etype (Ancestor_Type); 7419 end loop; 7420 7421 -- If the derived type does have a formal type as an 7422 -- ancestor, then it's an error if the derived type is 7423 -- declared within the body of the generic unit that 7424 -- declares the formal type in its generic formal part. It's 7425 -- sufficient to check whether the ancestor type is declared 7426 -- inside the same generic body as the derived type (such as 7427 -- within a nested generic spec), in which case the 7428 -- derivation is legal. If the formal type is declared 7429 -- outside of that generic body, then it's guaranteed that 7430 -- the derived type is declared within the generic body of 7431 -- the generic unit declaring the formal type. 7432 7433 if Is_Generic_Type (Ancestor_Type) 7434 and then Enclosing_Generic_Body (Ancestor_Type) /= 7435 Enclosing_Generic_Body (Derived_Type) 7436 then 7437 Error_Msg_NE 7438 ("parent type of& must not be descendant of formal type" 7439 & " of an enclosing generic body", 7440 Indic, Derived_Type); 7441 end if; 7442 end; 7443 end if; 7444 7445 elsif Type_Access_Level (Derived_Type) /= 7446 Type_Access_Level (Parent_Type) 7447 and then not Is_Generic_Type (Derived_Type) 7448 then 7449 if Is_Controlled (Parent_Type) then 7450 Error_Msg_N 7451 ("controlled type must be declared at the library level", 7452 Indic); 7453 else 7454 Error_Msg_N 7455 ("type extension at deeper accessibility level than parent", 7456 Indic); 7457 end if; 7458 7459 else 7460 declare 7461 GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type); 7462 7463 begin 7464 if Present (GB) 7465 and then GB /= Enclosing_Generic_Body (Parent_Base) 7466 then 7467 Error_Msg_NE 7468 ("parent type of& must not be outside generic body" 7469 & " (RM 3.9.1(4))", 7470 Indic, Derived_Type); 7471 end if; 7472 end; 7473 end if; 7474 end if; 7475 7476 -- Ada 2005 (AI-251) 7477 7478 if Ada_Version >= Ada_2005 and then Is_Tagged then 7479 7480 -- "The declaration of a specific descendant of an interface type 7481 -- freezes the interface type" (RM 13.14). 7482 7483 declare 7484 Iface : Node_Id; 7485 begin 7486 if Is_Non_Empty_List (Interface_List (Type_Def)) then 7487 Iface := First (Interface_List (Type_Def)); 7488 while Present (Iface) loop 7489 Freeze_Before (N, Etype (Iface)); 7490 Next (Iface); 7491 end loop; 7492 end if; 7493 end; 7494 end if; 7495 7496 -- STEP 1b : preliminary cleanup of the full view of private types 7497 7498 -- If the type is already marked as having discriminants, then it's the 7499 -- completion of a private type or private extension and we need to 7500 -- retain the discriminants from the partial view if the current 7501 -- declaration has Discriminant_Specifications so that we can verify 7502 -- conformance. However, we must remove any existing components that 7503 -- were inherited from the parent (and attached in Copy_And_Swap) 7504 -- because the full type inherits all appropriate components anyway, and 7505 -- we do not want the partial view's components interfering. 7506 7507 if Has_Discriminants (Derived_Type) and then Discriminant_Specs then 7508 Discrim := First_Discriminant (Derived_Type); 7509 loop 7510 Last_Discrim := Discrim; 7511 Next_Discriminant (Discrim); 7512 exit when No (Discrim); 7513 end loop; 7514 7515 Set_Last_Entity (Derived_Type, Last_Discrim); 7516 7517 -- In all other cases wipe out the list of inherited components (even 7518 -- inherited discriminants), it will be properly rebuilt here. 7519 7520 else 7521 Set_First_Entity (Derived_Type, Empty); 7522 Set_Last_Entity (Derived_Type, Empty); 7523 end if; 7524 7525 -- STEP 1c: Initialize some flags for the Derived_Type 7526 7527 -- The following flags must be initialized here so that 7528 -- Process_Discriminants can check that discriminants of tagged types do 7529 -- not have a default initial value and that access discriminants are 7530 -- only specified for limited records. For completeness, these flags are 7531 -- also initialized along with all the other flags below. 7532 7533 -- AI-419: Limitedness is not inherited from an interface parent, so to 7534 -- be limited in that case the type must be explicitly declared as 7535 -- limited. However, task and protected interfaces are always limited. 7536 7537 if Limited_Present (Type_Def) then 7538 Set_Is_Limited_Record (Derived_Type); 7539 7540 elsif Is_Limited_Record (Parent_Type) 7541 or else (Present (Full_View (Parent_Type)) 7542 and then Is_Limited_Record (Full_View (Parent_Type))) 7543 then 7544 if not Is_Interface (Parent_Type) 7545 or else Is_Synchronized_Interface (Parent_Type) 7546 or else Is_Protected_Interface (Parent_Type) 7547 or else Is_Task_Interface (Parent_Type) 7548 then 7549 Set_Is_Limited_Record (Derived_Type); 7550 end if; 7551 end if; 7552 7553 -- STEP 2a: process discriminants of derived type if any 7554 7555 Push_Scope (Derived_Type); 7556 7557 if Discriminant_Specs then 7558 Set_Has_Unknown_Discriminants (Derived_Type, False); 7559 7560 -- The following call initializes fields Has_Discriminants and 7561 -- Discriminant_Constraint, unless we are processing the completion 7562 -- of a private type declaration. 7563 7564 Check_Or_Process_Discriminants (N, Derived_Type); 7565 7566 -- For untagged types, the constraint on the Parent_Type must be 7567 -- present and is used to rename the discriminants. 7568 7569 if not Is_Tagged and then not Has_Discriminants (Parent_Type) then 7570 Error_Msg_N ("untagged parent must have discriminants", Indic); 7571 7572 elsif not Is_Tagged and then not Constraint_Present then 7573 Error_Msg_N 7574 ("discriminant constraint needed for derived untagged records", 7575 Indic); 7576 7577 -- Otherwise the parent subtype must be constrained unless we have a 7578 -- private extension. 7579 7580 elsif not Constraint_Present 7581 and then not Private_Extension 7582 and then not Is_Constrained (Parent_Type) 7583 then 7584 Error_Msg_N 7585 ("unconstrained type not allowed in this context", Indic); 7586 7587 elsif Constraint_Present then 7588 -- The following call sets the field Corresponding_Discriminant 7589 -- for the discriminants in the Derived_Type. 7590 7591 Discs := Build_Discriminant_Constraints (Parent_Type, Indic, True); 7592 7593 -- For untagged types all new discriminants must rename 7594 -- discriminants in the parent. For private extensions new 7595 -- discriminants cannot rename old ones (implied by [7.3(13)]). 7596 7597 Discrim := First_Discriminant (Derived_Type); 7598 while Present (Discrim) loop 7599 if not Is_Tagged 7600 and then No (Corresponding_Discriminant (Discrim)) 7601 then 7602 Error_Msg_N 7603 ("new discriminants must constrain old ones", Discrim); 7604 7605 elsif Private_Extension 7606 and then Present (Corresponding_Discriminant (Discrim)) 7607 then 7608 Error_Msg_N 7609 ("only static constraints allowed for parent" 7610 & " discriminants in the partial view", Indic); 7611 exit; 7612 end if; 7613 7614 -- If a new discriminant is used in the constraint, then its 7615 -- subtype must be statically compatible with the parent 7616 -- discriminant's subtype (3.7(15)). 7617 7618 -- However, if the record contains an array constrained by 7619 -- the discriminant but with some different bound, the compiler 7620 -- attemps to create a smaller range for the discriminant type. 7621 -- (See exp_ch3.Adjust_Discriminants). In this case, where 7622 -- the discriminant type is a scalar type, the check must use 7623 -- the original discriminant type in the parent declaration. 7624 7625 declare 7626 Corr_Disc : constant Entity_Id := 7627 Corresponding_Discriminant (Discrim); 7628 Disc_Type : constant Entity_Id := Etype (Discrim); 7629 Corr_Type : Entity_Id; 7630 7631 begin 7632 if Present (Corr_Disc) then 7633 if Is_Scalar_Type (Disc_Type) then 7634 Corr_Type := 7635 Entity (Discriminant_Type (Parent (Corr_Disc))); 7636 else 7637 Corr_Type := Etype (Corr_Disc); 7638 end if; 7639 7640 if not 7641 Subtypes_Statically_Compatible (Disc_Type, Corr_Type) 7642 then 7643 Error_Msg_N 7644 ("subtype must be compatible " 7645 & "with parent discriminant", 7646 Discrim); 7647 end if; 7648 end if; 7649 end; 7650 7651 Next_Discriminant (Discrim); 7652 end loop; 7653 7654 -- Check whether the constraints of the full view statically 7655 -- match those imposed by the parent subtype [7.3(13)]. 7656 7657 if Present (Stored_Constraint (Derived_Type)) then 7658 declare 7659 C1, C2 : Elmt_Id; 7660 7661 begin 7662 C1 := First_Elmt (Discs); 7663 C2 := First_Elmt (Stored_Constraint (Derived_Type)); 7664 while Present (C1) and then Present (C2) loop 7665 if not 7666 Fully_Conformant_Expressions (Node (C1), Node (C2)) 7667 then 7668 Error_Msg_N 7669 ("not conformant with previous declaration", 7670 Node (C1)); 7671 end if; 7672 7673 Next_Elmt (C1); 7674 Next_Elmt (C2); 7675 end loop; 7676 end; 7677 end if; 7678 end if; 7679 7680 -- STEP 2b: No new discriminants, inherit discriminants if any 7681 7682 else 7683 if Private_Extension then 7684 Set_Has_Unknown_Discriminants 7685 (Derived_Type, 7686 Has_Unknown_Discriminants (Parent_Type) 7687 or else Unknown_Discriminants_Present (N)); 7688 7689 -- The partial view of the parent may have unknown discriminants, 7690 -- but if the full view has discriminants and the parent type is 7691 -- in scope they must be inherited. 7692 7693 elsif Has_Unknown_Discriminants (Parent_Type) 7694 and then 7695 (not Has_Discriminants (Parent_Type) 7696 or else not In_Open_Scopes (Scope (Parent_Type))) 7697 then 7698 Set_Has_Unknown_Discriminants (Derived_Type); 7699 end if; 7700 7701 if not Has_Unknown_Discriminants (Derived_Type) 7702 and then not Has_Unknown_Discriminants (Parent_Base) 7703 and then Has_Discriminants (Parent_Type) 7704 then 7705 Inherit_Discrims := True; 7706 Set_Has_Discriminants 7707 (Derived_Type, True); 7708 Set_Discriminant_Constraint 7709 (Derived_Type, Discriminant_Constraint (Parent_Base)); 7710 end if; 7711 7712 -- The following test is true for private types (remember 7713 -- transformation 5. is not applied to those) and in an error 7714 -- situation. 7715 7716 if Constraint_Present then 7717 Discs := Build_Discriminant_Constraints (Parent_Type, Indic); 7718 end if; 7719 7720 -- For now mark a new derived type as constrained only if it has no 7721 -- discriminants. At the end of Build_Derived_Record_Type we properly 7722 -- set this flag in the case of private extensions. See comments in 7723 -- point 9. just before body of Build_Derived_Record_Type. 7724 7725 Set_Is_Constrained 7726 (Derived_Type, 7727 not (Inherit_Discrims 7728 or else Has_Unknown_Discriminants (Derived_Type))); 7729 end if; 7730 7731 -- STEP 3: initialize fields of derived type 7732 7733 Set_Is_Tagged_Type (Derived_Type, Is_Tagged); 7734 Set_Stored_Constraint (Derived_Type, No_Elist); 7735 7736 -- Ada 2005 (AI-251): Private type-declarations can implement interfaces 7737 -- but cannot be interfaces 7738 7739 if not Private_Extension 7740 and then Ekind (Derived_Type) /= E_Private_Type 7741 and then Ekind (Derived_Type) /= E_Limited_Private_Type 7742 then 7743 if Interface_Present (Type_Def) then 7744 Analyze_Interface_Declaration (Derived_Type, Type_Def); 7745 end if; 7746 7747 Set_Interfaces (Derived_Type, No_Elist); 7748 end if; 7749 7750 -- Fields inherited from the Parent_Type 7751 7752 Set_Has_Specified_Layout 7753 (Derived_Type, Has_Specified_Layout (Parent_Type)); 7754 Set_Is_Limited_Composite 7755 (Derived_Type, Is_Limited_Composite (Parent_Type)); 7756 Set_Is_Private_Composite 7757 (Derived_Type, Is_Private_Composite (Parent_Type)); 7758 7759 -- Fields inherited from the Parent_Base 7760 7761 Set_Has_Controlled_Component 7762 (Derived_Type, Has_Controlled_Component (Parent_Base)); 7763 Set_Has_Non_Standard_Rep 7764 (Derived_Type, Has_Non_Standard_Rep (Parent_Base)); 7765 Set_Has_Primitive_Operations 7766 (Derived_Type, Has_Primitive_Operations (Parent_Base)); 7767 7768 -- Fields inherited from the Parent_Base in the non-private case 7769 7770 if Ekind (Derived_Type) = E_Record_Type then 7771 Set_Has_Complex_Representation 7772 (Derived_Type, Has_Complex_Representation (Parent_Base)); 7773 end if; 7774 7775 -- Fields inherited from the Parent_Base for record types 7776 7777 if Is_Record_Type (Derived_Type) then 7778 7779 declare 7780 Parent_Full : Entity_Id; 7781 7782 begin 7783 -- Ekind (Parent_Base) is not necessarily E_Record_Type since 7784 -- Parent_Base can be a private type or private extension. Go 7785 -- to the full view here to get the E_Record_Type specific flags. 7786 7787 if Present (Full_View (Parent_Base)) then 7788 Parent_Full := Full_View (Parent_Base); 7789 else 7790 Parent_Full := Parent_Base; 7791 end if; 7792 7793 Set_OK_To_Reorder_Components 7794 (Derived_Type, OK_To_Reorder_Components (Parent_Full)); 7795 end; 7796 end if; 7797 7798 -- Set fields for private derived types 7799 7800 if Is_Private_Type (Derived_Type) then 7801 Set_Depends_On_Private (Derived_Type, True); 7802 Set_Private_Dependents (Derived_Type, New_Elmt_List); 7803 7804 -- Inherit fields from non private record types. If this is the 7805 -- completion of a derivation from a private type, the parent itself 7806 -- is private, and the attributes come from its full view, which must 7807 -- be present. 7808 7809 else 7810 if Is_Private_Type (Parent_Base) 7811 and then not Is_Record_Type (Parent_Base) 7812 then 7813 Set_Component_Alignment 7814 (Derived_Type, Component_Alignment (Full_View (Parent_Base))); 7815 Set_C_Pass_By_Copy 7816 (Derived_Type, C_Pass_By_Copy (Full_View (Parent_Base))); 7817 else 7818 Set_Component_Alignment 7819 (Derived_Type, Component_Alignment (Parent_Base)); 7820 Set_C_Pass_By_Copy 7821 (Derived_Type, C_Pass_By_Copy (Parent_Base)); 7822 end if; 7823 end if; 7824 7825 -- Set fields for tagged types 7826 7827 if Is_Tagged then 7828 Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); 7829 7830 -- All tagged types defined in Ada.Finalization are controlled 7831 7832 if Chars (Scope (Derived_Type)) = Name_Finalization 7833 and then Chars (Scope (Scope (Derived_Type))) = Name_Ada 7834 and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard 7835 then 7836 Set_Is_Controlled (Derived_Type); 7837 else 7838 Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base)); 7839 end if; 7840 7841 -- Minor optimization: there is no need to generate the class-wide 7842 -- entity associated with an underlying record view. 7843 7844 if not Is_Underlying_Record_View (Derived_Type) then 7845 Make_Class_Wide_Type (Derived_Type); 7846 end if; 7847 7848 Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def)); 7849 7850 if Has_Discriminants (Derived_Type) 7851 and then Constraint_Present 7852 then 7853 Set_Stored_Constraint 7854 (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs)); 7855 end if; 7856 7857 if Ada_Version >= Ada_2005 then 7858 declare 7859 Ifaces_List : Elist_Id; 7860 7861 begin 7862 -- Checks rules 3.9.4 (13/2 and 14/2) 7863 7864 if Comes_From_Source (Derived_Type) 7865 and then not Is_Private_Type (Derived_Type) 7866 and then Is_Interface (Parent_Type) 7867 and then not Is_Interface (Derived_Type) 7868 then 7869 if Is_Task_Interface (Parent_Type) then 7870 Error_Msg_N 7871 ("(Ada 2005) task type required (RM 3.9.4 (13.2))", 7872 Derived_Type); 7873 7874 elsif Is_Protected_Interface (Parent_Type) then 7875 Error_Msg_N 7876 ("(Ada 2005) protected type required (RM 3.9.4 (14.2))", 7877 Derived_Type); 7878 end if; 7879 end if; 7880 7881 -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) 7882 7883 Check_Interfaces (N, Type_Def); 7884 7885 -- Ada 2005 (AI-251): Collect the list of progenitors that are 7886 -- not already in the parents. 7887 7888 Collect_Interfaces 7889 (T => Derived_Type, 7890 Ifaces_List => Ifaces_List, 7891 Exclude_Parents => True); 7892 7893 Set_Interfaces (Derived_Type, Ifaces_List); 7894 7895 -- If the derived type is the anonymous type created for 7896 -- a declaration whose parent has a constraint, propagate 7897 -- the interface list to the source type. This must be done 7898 -- prior to the completion of the analysis of the source type 7899 -- because the components in the extension may contain current 7900 -- instances whose legality depends on some ancestor. 7901 7902 if Is_Itype (Derived_Type) then 7903 declare 7904 Def : constant Node_Id := 7905 Associated_Node_For_Itype (Derived_Type); 7906 begin 7907 if Present (Def) 7908 and then Nkind (Def) = N_Full_Type_Declaration 7909 then 7910 Set_Interfaces 7911 (Defining_Identifier (Def), Ifaces_List); 7912 end if; 7913 end; 7914 end if; 7915 end; 7916 end if; 7917 7918 else 7919 Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base)); 7920 Set_Has_Non_Standard_Rep 7921 (Derived_Type, Has_Non_Standard_Rep (Parent_Base)); 7922 end if; 7923 7924 -- STEP 4: Inherit components from the parent base and constrain them. 7925 -- Apply the second transformation described in point 6. above. 7926 7927 if (not Is_Empty_Elmt_List (Discs) or else Inherit_Discrims) 7928 or else not Has_Discriminants (Parent_Type) 7929 or else not Is_Constrained (Parent_Type) 7930 then 7931 Constrs := Discs; 7932 else 7933 Constrs := Discriminant_Constraint (Parent_Type); 7934 end if; 7935 7936 Assoc_List := 7937 Inherit_Components 7938 (N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs); 7939 7940 -- STEP 5a: Copy the parent record declaration for untagged types 7941 7942 if not Is_Tagged then 7943 7944 -- Discriminant_Constraint (Derived_Type) has been properly 7945 -- constructed. Save it and temporarily set it to Empty because we 7946 -- do not want the call to New_Copy_Tree below to mess this list. 7947 7948 if Has_Discriminants (Derived_Type) then 7949 Save_Discr_Constr := Discriminant_Constraint (Derived_Type); 7950 Set_Discriminant_Constraint (Derived_Type, No_Elist); 7951 else 7952 Save_Discr_Constr := No_Elist; 7953 end if; 7954 7955 -- Save the Etype field of Derived_Type. It is correctly set now, 7956 -- but the call to New_Copy tree may remap it to point to itself, 7957 -- which is not what we want. Ditto for the Next_Entity field. 7958 7959 Save_Etype := Etype (Derived_Type); 7960 Save_Next_Entity := Next_Entity (Derived_Type); 7961 7962 -- Assoc_List maps all stored discriminants in the Parent_Base to 7963 -- stored discriminants in the Derived_Type. It is fundamental that 7964 -- no types or itypes with discriminants other than the stored 7965 -- discriminants appear in the entities declared inside 7966 -- Derived_Type, since the back end cannot deal with it. 7967 7968 New_Decl := 7969 New_Copy_Tree 7970 (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc); 7971 7972 -- Restore the fields saved prior to the New_Copy_Tree call 7973 -- and compute the stored constraint. 7974 7975 Set_Etype (Derived_Type, Save_Etype); 7976 Set_Next_Entity (Derived_Type, Save_Next_Entity); 7977 7978 if Has_Discriminants (Derived_Type) then 7979 Set_Discriminant_Constraint 7980 (Derived_Type, Save_Discr_Constr); 7981 Set_Stored_Constraint 7982 (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs)); 7983 Replace_Components (Derived_Type, New_Decl); 7984 Set_Has_Implicit_Dereference 7985 (Derived_Type, Has_Implicit_Dereference (Parent_Type)); 7986 end if; 7987 7988 -- Insert the new derived type declaration 7989 7990 Rewrite (N, New_Decl); 7991 7992 -- STEP 5b: Complete the processing for record extensions in generics 7993 7994 -- There is no completion for record extensions declared in the 7995 -- parameter part of a generic, so we need to complete processing for 7996 -- these generic record extensions here. The Record_Type_Definition call 7997 -- will change the Ekind of the components from E_Void to E_Component. 7998 7999 elsif Private_Extension and then Is_Generic_Type (Derived_Type) then 8000 Record_Type_Definition (Empty, Derived_Type); 8001 8002 -- STEP 5c: Process the record extension for non private tagged types 8003 8004 elsif not Private_Extension then 8005 8006 -- Add the _parent field in the derived type 8007 8008 Expand_Record_Extension (Derived_Type, Type_Def); 8009 8010 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the 8011 -- implemented interfaces if we are in expansion mode 8012 8013 if Expander_Active 8014 and then Has_Interfaces (Derived_Type) 8015 then 8016 Add_Interface_Tag_Components (N, Derived_Type); 8017 end if; 8018 8019 -- Analyze the record extension 8020 8021 Record_Type_Definition 8022 (Record_Extension_Part (Type_Def), Derived_Type); 8023 end if; 8024 8025 End_Scope; 8026 8027 -- Nothing else to do if there is an error in the derivation. 8028 -- An unusual case: the full view may be derived from a type in an 8029 -- instance, when the partial view was used illegally as an actual 8030 -- in that instance, leading to a circular definition. 8031 8032 if Etype (Derived_Type) = Any_Type 8033 or else Etype (Parent_Type) = Derived_Type 8034 then 8035 return; 8036 end if; 8037 8038 -- Set delayed freeze and then derive subprograms, we need to do 8039 -- this in this order so that derived subprograms inherit the 8040 -- derived freeze if necessary. 8041 8042 Set_Has_Delayed_Freeze (Derived_Type); 8043 8044 if Derive_Subps then 8045 Derive_Subprograms (Parent_Type, Derived_Type); 8046 end if; 8047 8048 -- If we have a private extension which defines a constrained derived 8049 -- type mark as constrained here after we have derived subprograms. See 8050 -- comment on point 9. just above the body of Build_Derived_Record_Type. 8051 8052 if Private_Extension and then Inherit_Discrims then 8053 if Constraint_Present and then not Is_Empty_Elmt_List (Discs) then 8054 Set_Is_Constrained (Derived_Type, True); 8055 Set_Discriminant_Constraint (Derived_Type, Discs); 8056 8057 elsif Is_Constrained (Parent_Type) then 8058 Set_Is_Constrained 8059 (Derived_Type, True); 8060 Set_Discriminant_Constraint 8061 (Derived_Type, Discriminant_Constraint (Parent_Type)); 8062 end if; 8063 end if; 8064 8065 -- Update the class-wide type, which shares the now-completed entity 8066 -- list with its specific type. In case of underlying record views, 8067 -- we do not generate the corresponding class wide entity. 8068 8069 if Is_Tagged 8070 and then not Is_Underlying_Record_View (Derived_Type) 8071 then 8072 Set_First_Entity 8073 (Class_Wide_Type (Derived_Type), First_Entity (Derived_Type)); 8074 Set_Last_Entity 8075 (Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type)); 8076 end if; 8077 8078 Check_Function_Writable_Actuals (N); 8079 end Build_Derived_Record_Type; 8080 8081 ------------------------ 8082 -- Build_Derived_Type -- 8083 ------------------------ 8084 8085 procedure Build_Derived_Type 8086 (N : Node_Id; 8087 Parent_Type : Entity_Id; 8088 Derived_Type : Entity_Id; 8089 Is_Completion : Boolean; 8090 Derive_Subps : Boolean := True) 8091 is 8092 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 8093 8094 begin 8095 -- Set common attributes 8096 8097 Set_Scope (Derived_Type, Current_Scope); 8098 8099 Set_Ekind (Derived_Type, Ekind (Parent_Base)); 8100 Set_Etype (Derived_Type, Parent_Base); 8101 Set_Has_Task (Derived_Type, Has_Task (Parent_Base)); 8102 8103 Set_Size_Info (Derived_Type, Parent_Type); 8104 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 8105 Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); 8106 Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); 8107 8108 -- If the parent type is a private subtype, the convention on the base 8109 -- type may be set in the private part, and not propagated to the 8110 -- subtype until later, so we obtain the convention from the base type. 8111 8112 Set_Convention (Derived_Type, Convention (Parent_Base)); 8113 8114 -- Propagate invariant information. The new type has invariants if 8115 -- they are inherited from the parent type, and these invariants can 8116 -- be further inherited, so both flags are set. 8117 8118 -- We similarly inherit predicates 8119 8120 if Has_Predicates (Parent_Type) then 8121 Set_Has_Predicates (Derived_Type); 8122 end if; 8123 8124 -- The derived type inherits the representation clauses of the parent. 8125 -- However, for a private type that is completed by a derivation, there 8126 -- may be operation attributes that have been specified already (stream 8127 -- attributes and External_Tag) and those must be provided. Finally, 8128 -- if the partial view is a private extension, the representation items 8129 -- of the parent have been inherited already, and should not be chained 8130 -- twice to the derived type. 8131 8132 if Is_Tagged_Type (Parent_Type) 8133 and then Present (First_Rep_Item (Derived_Type)) 8134 then 8135 -- The existing items are either operational items or items inherited 8136 -- from a private extension declaration. 8137 8138 declare 8139 Rep : Node_Id; 8140 -- Used to iterate over representation items of the derived type 8141 8142 Last_Rep : Node_Id; 8143 -- Last representation item of the (non-empty) representation 8144 -- item list of the derived type. 8145 8146 Found : Boolean := False; 8147 8148 begin 8149 Rep := First_Rep_Item (Derived_Type); 8150 Last_Rep := Rep; 8151 while Present (Rep) loop 8152 if Rep = First_Rep_Item (Parent_Type) then 8153 Found := True; 8154 exit; 8155 8156 else 8157 Rep := Next_Rep_Item (Rep); 8158 8159 if Present (Rep) then 8160 Last_Rep := Rep; 8161 end if; 8162 end if; 8163 end loop; 8164 8165 -- Here if we either encountered the parent type's first rep 8166 -- item on the derived type's rep item list (in which case 8167 -- Found is True, and we have nothing else to do), or if we 8168 -- reached the last rep item of the derived type, which is 8169 -- Last_Rep, in which case we further chain the parent type's 8170 -- rep items to those of the derived type. 8171 8172 if not Found then 8173 Set_Next_Rep_Item (Last_Rep, First_Rep_Item (Parent_Type)); 8174 end if; 8175 end; 8176 8177 else 8178 Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type)); 8179 end if; 8180 8181 case Ekind (Parent_Type) is 8182 when Numeric_Kind => 8183 Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type); 8184 8185 when Array_Kind => 8186 Build_Derived_Array_Type (N, Parent_Type, Derived_Type); 8187 8188 when E_Record_Type 8189 | E_Record_Subtype 8190 | Class_Wide_Kind => 8191 Build_Derived_Record_Type 8192 (N, Parent_Type, Derived_Type, Derive_Subps); 8193 return; 8194 8195 when Enumeration_Kind => 8196 Build_Derived_Enumeration_Type (N, Parent_Type, Derived_Type); 8197 8198 when Access_Kind => 8199 Build_Derived_Access_Type (N, Parent_Type, Derived_Type); 8200 8201 when Incomplete_Or_Private_Kind => 8202 Build_Derived_Private_Type 8203 (N, Parent_Type, Derived_Type, Is_Completion, Derive_Subps); 8204 8205 -- For discriminated types, the derivation includes deriving 8206 -- primitive operations. For others it is done below. 8207 8208 if Is_Tagged_Type (Parent_Type) 8209 or else Has_Discriminants (Parent_Type) 8210 or else (Present (Full_View (Parent_Type)) 8211 and then Has_Discriminants (Full_View (Parent_Type))) 8212 then 8213 return; 8214 end if; 8215 8216 when Concurrent_Kind => 8217 Build_Derived_Concurrent_Type (N, Parent_Type, Derived_Type); 8218 8219 when others => 8220 raise Program_Error; 8221 end case; 8222 8223 if Etype (Derived_Type) = Any_Type then 8224 return; 8225 end if; 8226 8227 -- Set delayed freeze and then derive subprograms, we need to do this 8228 -- in this order so that derived subprograms inherit the derived freeze 8229 -- if necessary. 8230 8231 Set_Has_Delayed_Freeze (Derived_Type); 8232 if Derive_Subps then 8233 Derive_Subprograms (Parent_Type, Derived_Type); 8234 end if; 8235 8236 Set_Has_Primitive_Operations 8237 (Base_Type (Derived_Type), Has_Primitive_Operations (Parent_Type)); 8238 end Build_Derived_Type; 8239 8240 ----------------------- 8241 -- Build_Discriminal -- 8242 ----------------------- 8243 8244 procedure Build_Discriminal (Discrim : Entity_Id) is 8245 D_Minal : Entity_Id; 8246 CR_Disc : Entity_Id; 8247 8248 begin 8249 -- A discriminal has the same name as the discriminant 8250 8251 D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); 8252 8253 Set_Ekind (D_Minal, E_In_Parameter); 8254 Set_Mechanism (D_Minal, Default_Mechanism); 8255 Set_Etype (D_Minal, Etype (Discrim)); 8256 Set_Scope (D_Minal, Current_Scope); 8257 8258 Set_Discriminal (Discrim, D_Minal); 8259 Set_Discriminal_Link (D_Minal, Discrim); 8260 8261 -- For task types, build at once the discriminants of the corresponding 8262 -- record, which are needed if discriminants are used in entry defaults 8263 -- and in family bounds. 8264 8265 if Is_Concurrent_Type (Current_Scope) 8266 or else Is_Limited_Type (Current_Scope) 8267 then 8268 CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); 8269 8270 Set_Ekind (CR_Disc, E_In_Parameter); 8271 Set_Mechanism (CR_Disc, Default_Mechanism); 8272 Set_Etype (CR_Disc, Etype (Discrim)); 8273 Set_Scope (CR_Disc, Current_Scope); 8274 Set_Discriminal_Link (CR_Disc, Discrim); 8275 Set_CR_Discriminant (Discrim, CR_Disc); 8276 end if; 8277 end Build_Discriminal; 8278 8279 ------------------------------------ 8280 -- Build_Discriminant_Constraints -- 8281 ------------------------------------ 8282 8283 function Build_Discriminant_Constraints 8284 (T : Entity_Id; 8285 Def : Node_Id; 8286 Derived_Def : Boolean := False) return Elist_Id 8287 is 8288 C : constant Node_Id := Constraint (Def); 8289 Nb_Discr : constant Nat := Number_Discriminants (T); 8290 8291 Discr_Expr : array (1 .. Nb_Discr) of Node_Id := (others => Empty); 8292 -- Saves the expression corresponding to a given discriminant in T 8293 8294 function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat; 8295 -- Return the Position number within array Discr_Expr of a discriminant 8296 -- D within the discriminant list of the discriminated type T. 8297 8298 procedure Process_Discriminant_Expression 8299 (Expr : Node_Id; 8300 D : Entity_Id); 8301 -- If this is a discriminant constraint on a partial view, do not 8302 -- generate an overflow check on the discriminant expression. The check 8303 -- will be generated when constraining the full view. Otherwise the 8304 -- backend creates duplicate symbols for the temporaries corresponding 8305 -- to the expressions to be checked, causing spurious assembler errors. 8306 8307 ------------------ 8308 -- Pos_Of_Discr -- 8309 ------------------ 8310 8311 function Pos_Of_Discr (T : Entity_Id; D : Entity_Id) return Nat is 8312 Disc : Entity_Id; 8313 8314 begin 8315 Disc := First_Discriminant (T); 8316 for J in Discr_Expr'Range loop 8317 if Disc = D then 8318 return J; 8319 end if; 8320 8321 Next_Discriminant (Disc); 8322 end loop; 8323 8324 -- Note: Since this function is called on discriminants that are 8325 -- known to belong to the discriminated type, falling through the 8326 -- loop with no match signals an internal compiler error. 8327 8328 raise Program_Error; 8329 end Pos_Of_Discr; 8330 8331 ------------------------------------- 8332 -- Process_Discriminant_Expression -- 8333 ------------------------------------- 8334 8335 procedure Process_Discriminant_Expression 8336 (Expr : Node_Id; 8337 D : Entity_Id) 8338 is 8339 BDT : constant Entity_Id := Base_Type (Etype (D)); 8340 8341 begin 8342 -- If this is a discriminant constraint on a partial view, do 8343 -- not generate an overflow on the discriminant expression. The 8344 -- check will be generated when constraining the full view. 8345 8346 if Is_Private_Type (T) 8347 and then Present (Full_View (T)) 8348 then 8349 Analyze_And_Resolve (Expr, BDT, Suppress => Overflow_Check); 8350 8351 else 8352 Analyze_And_Resolve (Expr, BDT); 8353 end if; 8354 end Process_Discriminant_Expression; 8355 8356 -- Declarations local to Build_Discriminant_Constraints 8357 8358 Discr : Entity_Id; 8359 E : Entity_Id; 8360 Elist : constant Elist_Id := New_Elmt_List; 8361 8362 Constr : Node_Id; 8363 Expr : Node_Id; 8364 Id : Node_Id; 8365 Position : Nat; 8366 Found : Boolean; 8367 8368 Discrim_Present : Boolean := False; 8369 8370 -- Start of processing for Build_Discriminant_Constraints 8371 8372 begin 8373 -- The following loop will process positional associations only. 8374 -- For a positional association, the (single) discriminant is 8375 -- implicitly specified by position, in textual order (RM 3.7.2). 8376 8377 Discr := First_Discriminant (T); 8378 Constr := First (Constraints (C)); 8379 for D in Discr_Expr'Range loop 8380 exit when Nkind (Constr) = N_Discriminant_Association; 8381 8382 if No (Constr) then 8383 Error_Msg_N ("too few discriminants given in constraint", C); 8384 return New_Elmt_List; 8385 8386 elsif Nkind (Constr) = N_Range 8387 or else (Nkind (Constr) = N_Attribute_Reference 8388 and then 8389 Attribute_Name (Constr) = Name_Range) 8390 then 8391 Error_Msg_N 8392 ("a range is not a valid discriminant constraint", Constr); 8393 Discr_Expr (D) := Error; 8394 8395 else 8396 Process_Discriminant_Expression (Constr, Discr); 8397 Discr_Expr (D) := Constr; 8398 end if; 8399 8400 Next_Discriminant (Discr); 8401 Next (Constr); 8402 end loop; 8403 8404 if No (Discr) and then Present (Constr) then 8405 Error_Msg_N ("too many discriminants given in constraint", Constr); 8406 return New_Elmt_List; 8407 end if; 8408 8409 -- Named associations can be given in any order, but if both positional 8410 -- and named associations are used in the same discriminant constraint, 8411 -- then positional associations must occur first, at their normal 8412 -- position. Hence once a named association is used, the rest of the 8413 -- discriminant constraint must use only named associations. 8414 8415 while Present (Constr) loop 8416 8417 -- Positional association forbidden after a named association 8418 8419 if Nkind (Constr) /= N_Discriminant_Association then 8420 Error_Msg_N ("positional association follows named one", Constr); 8421 return New_Elmt_List; 8422 8423 -- Otherwise it is a named association 8424 8425 else 8426 -- E records the type of the discriminants in the named 8427 -- association. All the discriminants specified in the same name 8428 -- association must have the same type. 8429 8430 E := Empty; 8431 8432 -- Search the list of discriminants in T to see if the simple name 8433 -- given in the constraint matches any of them. 8434 8435 Id := First (Selector_Names (Constr)); 8436 while Present (Id) loop 8437 Found := False; 8438 8439 -- If Original_Discriminant is present, we are processing a 8440 -- generic instantiation and this is an instance node. We need 8441 -- to find the name of the corresponding discriminant in the 8442 -- actual record type T and not the name of the discriminant in 8443 -- the generic formal. Example: 8444 8445 -- generic 8446 -- type G (D : int) is private; 8447 -- package P is 8448 -- subtype W is G (D => 1); 8449 -- end package; 8450 -- type Rec (X : int) is record ... end record; 8451 -- package Q is new P (G => Rec); 8452 8453 -- At the point of the instantiation, formal type G is Rec 8454 -- and therefore when reanalyzing "subtype W is G (D => 1);" 8455 -- which really looks like "subtype W is Rec (D => 1);" at 8456 -- the point of instantiation, we want to find the discriminant 8457 -- that corresponds to D in Rec, i.e. X. 8458 8459 if Present (Original_Discriminant (Id)) 8460 and then In_Instance 8461 then 8462 Discr := Find_Corresponding_Discriminant (Id, T); 8463 Found := True; 8464 8465 else 8466 Discr := First_Discriminant (T); 8467 while Present (Discr) loop 8468 if Chars (Discr) = Chars (Id) then 8469 Found := True; 8470 exit; 8471 end if; 8472 8473 Next_Discriminant (Discr); 8474 end loop; 8475 8476 if not Found then 8477 Error_Msg_N ("& does not match any discriminant", Id); 8478 return New_Elmt_List; 8479 8480 -- If the parent type is a generic formal, preserve the 8481 -- name of the discriminant for subsequent instances. 8482 -- see comment at the beginning of this if statement. 8483 8484 elsif Is_Generic_Type (Root_Type (T)) then 8485 Set_Original_Discriminant (Id, Discr); 8486 end if; 8487 end if; 8488 8489 Position := Pos_Of_Discr (T, Discr); 8490 8491 if Present (Discr_Expr (Position)) then 8492 Error_Msg_N ("duplicate constraint for discriminant&", Id); 8493 8494 else 8495 -- Each discriminant specified in the same named association 8496 -- must be associated with a separate copy of the 8497 -- corresponding expression. 8498 8499 if Present (Next (Id)) then 8500 Expr := New_Copy_Tree (Expression (Constr)); 8501 Set_Parent (Expr, Parent (Expression (Constr))); 8502 else 8503 Expr := Expression (Constr); 8504 end if; 8505 8506 Discr_Expr (Position) := Expr; 8507 Process_Discriminant_Expression (Expr, Discr); 8508 end if; 8509 8510 -- A discriminant association with more than one discriminant 8511 -- name is only allowed if the named discriminants are all of 8512 -- the same type (RM 3.7.1(8)). 8513 8514 if E = Empty then 8515 E := Base_Type (Etype (Discr)); 8516 8517 elsif Base_Type (Etype (Discr)) /= E then 8518 Error_Msg_N 8519 ("all discriminants in an association " & 8520 "must have the same type", Id); 8521 end if; 8522 8523 Next (Id); 8524 end loop; 8525 end if; 8526 8527 Next (Constr); 8528 end loop; 8529 8530 -- A discriminant constraint must provide exactly one value for each 8531 -- discriminant of the type (RM 3.7.1(8)). 8532 8533 for J in Discr_Expr'Range loop 8534 if No (Discr_Expr (J)) then 8535 Error_Msg_N ("too few discriminants given in constraint", C); 8536 return New_Elmt_List; 8537 end if; 8538 end loop; 8539 8540 -- Determine if there are discriminant expressions in the constraint 8541 8542 for J in Discr_Expr'Range loop 8543 if Denotes_Discriminant 8544 (Discr_Expr (J), Check_Concurrent => True) 8545 then 8546 Discrim_Present := True; 8547 end if; 8548 end loop; 8549 8550 -- Build an element list consisting of the expressions given in the 8551 -- discriminant constraint and apply the appropriate checks. The list 8552 -- is constructed after resolving any named discriminant associations 8553 -- and therefore the expressions appear in the textual order of the 8554 -- discriminants. 8555 8556 Discr := First_Discriminant (T); 8557 for J in Discr_Expr'Range loop 8558 if Discr_Expr (J) /= Error then 8559 Append_Elmt (Discr_Expr (J), Elist); 8560 8561 -- If any of the discriminant constraints is given by a 8562 -- discriminant and we are in a derived type declaration we 8563 -- have a discriminant renaming. Establish link between new 8564 -- and old discriminant. 8565 8566 if Denotes_Discriminant (Discr_Expr (J)) then 8567 if Derived_Def then 8568 Set_Corresponding_Discriminant 8569 (Entity (Discr_Expr (J)), Discr); 8570 end if; 8571 8572 -- Force the evaluation of non-discriminant expressions. 8573 -- If we have found a discriminant in the constraint 3.4(26) 8574 -- and 3.8(18) demand that no range checks are performed are 8575 -- after evaluation. If the constraint is for a component 8576 -- definition that has a per-object constraint, expressions are 8577 -- evaluated but not checked either. In all other cases perform 8578 -- a range check. 8579 8580 else 8581 if Discrim_Present then 8582 null; 8583 8584 elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration 8585 and then 8586 Has_Per_Object_Constraint 8587 (Defining_Identifier (Parent (Parent (Def)))) 8588 then 8589 null; 8590 8591 elsif Is_Access_Type (Etype (Discr)) then 8592 Apply_Constraint_Check (Discr_Expr (J), Etype (Discr)); 8593 8594 else 8595 Apply_Range_Check (Discr_Expr (J), Etype (Discr)); 8596 end if; 8597 8598 Force_Evaluation (Discr_Expr (J)); 8599 end if; 8600 8601 -- Check that the designated type of an access discriminant's 8602 -- expression is not a class-wide type unless the discriminant's 8603 -- designated type is also class-wide. 8604 8605 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type 8606 and then not Is_Class_Wide_Type 8607 (Designated_Type (Etype (Discr))) 8608 and then Etype (Discr_Expr (J)) /= Any_Type 8609 and then Is_Class_Wide_Type 8610 (Designated_Type (Etype (Discr_Expr (J)))) 8611 then 8612 Wrong_Type (Discr_Expr (J), Etype (Discr)); 8613 8614 elsif Is_Access_Type (Etype (Discr)) 8615 and then not Is_Access_Constant (Etype (Discr)) 8616 and then Is_Access_Type (Etype (Discr_Expr (J))) 8617 and then Is_Access_Constant (Etype (Discr_Expr (J))) 8618 then 8619 Error_Msg_NE 8620 ("constraint for discriminant& must be access to variable", 8621 Def, Discr); 8622 end if; 8623 end if; 8624 8625 Next_Discriminant (Discr); 8626 end loop; 8627 8628 return Elist; 8629 end Build_Discriminant_Constraints; 8630 8631 --------------------------------- 8632 -- Build_Discriminated_Subtype -- 8633 --------------------------------- 8634 8635 procedure Build_Discriminated_Subtype 8636 (T : Entity_Id; 8637 Def_Id : Entity_Id; 8638 Elist : Elist_Id; 8639 Related_Nod : Node_Id; 8640 For_Access : Boolean := False) 8641 is 8642 Has_Discrs : constant Boolean := Has_Discriminants (T); 8643 Constrained : constant Boolean := 8644 (Has_Discrs 8645 and then not Is_Empty_Elmt_List (Elist) 8646 and then not Is_Class_Wide_Type (T)) 8647 or else Is_Constrained (T); 8648 8649 begin 8650 if Ekind (T) = E_Record_Type then 8651 if For_Access then 8652 Set_Ekind (Def_Id, E_Private_Subtype); 8653 Set_Is_For_Access_Subtype (Def_Id, True); 8654 else 8655 Set_Ekind (Def_Id, E_Record_Subtype); 8656 end if; 8657 8658 -- Inherit preelaboration flag from base, for types for which it 8659 -- may have been set: records, private types, protected types. 8660 8661 Set_Known_To_Have_Preelab_Init 8662 (Def_Id, Known_To_Have_Preelab_Init (T)); 8663 8664 elsif Ekind (T) = E_Task_Type then 8665 Set_Ekind (Def_Id, E_Task_Subtype); 8666 8667 elsif Ekind (T) = E_Protected_Type then 8668 Set_Ekind (Def_Id, E_Protected_Subtype); 8669 Set_Known_To_Have_Preelab_Init 8670 (Def_Id, Known_To_Have_Preelab_Init (T)); 8671 8672 elsif Is_Private_Type (T) then 8673 Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); 8674 Set_Known_To_Have_Preelab_Init 8675 (Def_Id, Known_To_Have_Preelab_Init (T)); 8676 8677 elsif Is_Class_Wide_Type (T) then 8678 Set_Ekind (Def_Id, E_Class_Wide_Subtype); 8679 8680 else 8681 -- Incomplete type. Attach subtype to list of dependents, to be 8682 -- completed with full view of parent type, unless is it the 8683 -- designated subtype of a record component within an init_proc. 8684 -- This last case arises for a component of an access type whose 8685 -- designated type is incomplete (e.g. a Taft Amendment type). 8686 -- The designated subtype is within an inner scope, and needs no 8687 -- elaboration, because only the access type is needed in the 8688 -- initialization procedure. 8689 8690 Set_Ekind (Def_Id, Ekind (T)); 8691 8692 if For_Access and then Within_Init_Proc then 8693 null; 8694 else 8695 Append_Elmt (Def_Id, Private_Dependents (T)); 8696 end if; 8697 end if; 8698 8699 Set_Etype (Def_Id, T); 8700 Init_Size_Align (Def_Id); 8701 Set_Has_Discriminants (Def_Id, Has_Discrs); 8702 Set_Is_Constrained (Def_Id, Constrained); 8703 8704 Set_First_Entity (Def_Id, First_Entity (T)); 8705 Set_Last_Entity (Def_Id, Last_Entity (T)); 8706 Set_Has_Implicit_Dereference 8707 (Def_Id, Has_Implicit_Dereference (T)); 8708 8709 -- If the subtype is the completion of a private declaration, there may 8710 -- have been representation clauses for the partial view, and they must 8711 -- be preserved. Build_Derived_Type chains the inherited clauses with 8712 -- the ones appearing on the extension. If this comes from a subtype 8713 -- declaration, all clauses are inherited. 8714 8715 if No (First_Rep_Item (Def_Id)) then 8716 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 8717 end if; 8718 8719 if Is_Tagged_Type (T) then 8720 Set_Is_Tagged_Type (Def_Id); 8721 Make_Class_Wide_Type (Def_Id); 8722 end if; 8723 8724 Set_Stored_Constraint (Def_Id, No_Elist); 8725 8726 if Has_Discrs then 8727 Set_Discriminant_Constraint (Def_Id, Elist); 8728 Set_Stored_Constraint_From_Discriminant_Constraint (Def_Id); 8729 end if; 8730 8731 if Is_Tagged_Type (T) then 8732 8733 -- Ada 2005 (AI-251): In case of concurrent types we inherit the 8734 -- concurrent record type (which has the list of primitive 8735 -- operations). 8736 8737 if Ada_Version >= Ada_2005 8738 and then Is_Concurrent_Type (T) 8739 then 8740 Set_Corresponding_Record_Type (Def_Id, 8741 Corresponding_Record_Type (T)); 8742 else 8743 Set_Direct_Primitive_Operations (Def_Id, 8744 Direct_Primitive_Operations (T)); 8745 end if; 8746 8747 Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T)); 8748 end if; 8749 8750 -- Subtypes introduced by component declarations do not need to be 8751 -- marked as delayed, and do not get freeze nodes, because the semantics 8752 -- verifies that the parents of the subtypes are frozen before the 8753 -- enclosing record is frozen. 8754 8755 if not Is_Type (Scope (Def_Id)) then 8756 Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); 8757 8758 if Is_Private_Type (T) 8759 and then Present (Full_View (T)) 8760 then 8761 Conditional_Delay (Def_Id, Full_View (T)); 8762 else 8763 Conditional_Delay (Def_Id, T); 8764 end if; 8765 end if; 8766 8767 if Is_Record_Type (T) then 8768 Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T)); 8769 8770 if Has_Discrs 8771 and then not Is_Empty_Elmt_List (Elist) 8772 and then not For_Access 8773 then 8774 Create_Constrained_Components (Def_Id, Related_Nod, T, Elist); 8775 elsif not For_Access then 8776 Set_Cloned_Subtype (Def_Id, T); 8777 end if; 8778 end if; 8779 end Build_Discriminated_Subtype; 8780 8781 --------------------------- 8782 -- Build_Itype_Reference -- 8783 --------------------------- 8784 8785 procedure Build_Itype_Reference 8786 (Ityp : Entity_Id; 8787 Nod : Node_Id) 8788 is 8789 IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod)); 8790 begin 8791 8792 -- Itype references are only created for use by the back-end 8793 8794 if Inside_A_Generic then 8795 return; 8796 else 8797 Set_Itype (IR, Ityp); 8798 Insert_After (Nod, IR); 8799 end if; 8800 end Build_Itype_Reference; 8801 8802 ------------------------ 8803 -- Build_Scalar_Bound -- 8804 ------------------------ 8805 8806 function Build_Scalar_Bound 8807 (Bound : Node_Id; 8808 Par_T : Entity_Id; 8809 Der_T : Entity_Id) return Node_Id 8810 is 8811 New_Bound : Entity_Id; 8812 8813 begin 8814 -- Note: not clear why this is needed, how can the original bound 8815 -- be unanalyzed at this point? and if it is, what business do we 8816 -- have messing around with it? and why is the base type of the 8817 -- parent type the right type for the resolution. It probably is 8818 -- not! It is OK for the new bound we are creating, but not for 8819 -- the old one??? Still if it never happens, no problem! 8820 8821 Analyze_And_Resolve (Bound, Base_Type (Par_T)); 8822 8823 if Nkind_In (Bound, N_Integer_Literal, N_Real_Literal) then 8824 New_Bound := New_Copy (Bound); 8825 Set_Etype (New_Bound, Der_T); 8826 Set_Analyzed (New_Bound); 8827 8828 elsif Is_Entity_Name (Bound) then 8829 New_Bound := OK_Convert_To (Der_T, New_Copy (Bound)); 8830 8831 -- The following is almost certainly wrong. What business do we have 8832 -- relocating a node (Bound) that is presumably still attached to 8833 -- the tree elsewhere??? 8834 8835 else 8836 New_Bound := OK_Convert_To (Der_T, Relocate_Node (Bound)); 8837 end if; 8838 8839 Set_Etype (New_Bound, Der_T); 8840 return New_Bound; 8841 end Build_Scalar_Bound; 8842 8843 -------------------------------- 8844 -- Build_Underlying_Full_View -- 8845 -------------------------------- 8846 8847 procedure Build_Underlying_Full_View 8848 (N : Node_Id; 8849 Typ : Entity_Id; 8850 Par : Entity_Id) 8851 is 8852 Loc : constant Source_Ptr := Sloc (N); 8853 Subt : constant Entity_Id := 8854 Make_Defining_Identifier 8855 (Loc, New_External_Name (Chars (Typ), 'S')); 8856 8857 Constr : Node_Id; 8858 Indic : Node_Id; 8859 C : Node_Id; 8860 Id : Node_Id; 8861 8862 procedure Set_Discriminant_Name (Id : Node_Id); 8863 -- If the derived type has discriminants, they may rename discriminants 8864 -- of the parent. When building the full view of the parent, we need to 8865 -- recover the names of the original discriminants if the constraint is 8866 -- given by named associations. 8867 8868 --------------------------- 8869 -- Set_Discriminant_Name -- 8870 --------------------------- 8871 8872 procedure Set_Discriminant_Name (Id : Node_Id) is 8873 Disc : Entity_Id; 8874 8875 begin 8876 Set_Original_Discriminant (Id, Empty); 8877 8878 if Has_Discriminants (Typ) then 8879 Disc := First_Discriminant (Typ); 8880 while Present (Disc) loop 8881 if Chars (Disc) = Chars (Id) 8882 and then Present (Corresponding_Discriminant (Disc)) 8883 then 8884 Set_Chars (Id, Chars (Corresponding_Discriminant (Disc))); 8885 end if; 8886 Next_Discriminant (Disc); 8887 end loop; 8888 end if; 8889 end Set_Discriminant_Name; 8890 8891 -- Start of processing for Build_Underlying_Full_View 8892 8893 begin 8894 if Nkind (N) = N_Full_Type_Declaration then 8895 Constr := Constraint (Subtype_Indication (Type_Definition (N))); 8896 8897 elsif Nkind (N) = N_Subtype_Declaration then 8898 Constr := New_Copy_Tree (Constraint (Subtype_Indication (N))); 8899 8900 elsif Nkind (N) = N_Component_Declaration then 8901 Constr := 8902 New_Copy_Tree 8903 (Constraint (Subtype_Indication (Component_Definition (N)))); 8904 8905 else 8906 raise Program_Error; 8907 end if; 8908 8909 C := First (Constraints (Constr)); 8910 while Present (C) loop 8911 if Nkind (C) = N_Discriminant_Association then 8912 Id := First (Selector_Names (C)); 8913 while Present (Id) loop 8914 Set_Discriminant_Name (Id); 8915 Next (Id); 8916 end loop; 8917 end if; 8918 8919 Next (C); 8920 end loop; 8921 8922 Indic := 8923 Make_Subtype_Declaration (Loc, 8924 Defining_Identifier => Subt, 8925 Subtype_Indication => 8926 Make_Subtype_Indication (Loc, 8927 Subtype_Mark => New_Reference_To (Par, Loc), 8928 Constraint => New_Copy_Tree (Constr))); 8929 8930 -- If this is a component subtype for an outer itype, it is not 8931 -- a list member, so simply set the parent link for analysis: if 8932 -- the enclosing type does not need to be in a declarative list, 8933 -- neither do the components. 8934 8935 if Is_List_Member (N) 8936 and then Nkind (N) /= N_Component_Declaration 8937 then 8938 Insert_Before (N, Indic); 8939 else 8940 Set_Parent (Indic, Parent (N)); 8941 end if; 8942 8943 Analyze (Indic); 8944 Set_Underlying_Full_View (Typ, Full_View (Subt)); 8945 end Build_Underlying_Full_View; 8946 8947 ------------------------------- 8948 -- Check_Abstract_Overriding -- 8949 ------------------------------- 8950 8951 procedure Check_Abstract_Overriding (T : Entity_Id) is 8952 Alias_Subp : Entity_Id; 8953 Elmt : Elmt_Id; 8954 Op_List : Elist_Id; 8955 Subp : Entity_Id; 8956 Type_Def : Node_Id; 8957 8958 procedure Check_Pragma_Implemented (Subp : Entity_Id); 8959 -- Ada 2012 (AI05-0030): Subprogram Subp overrides an interface routine 8960 -- which has pragma Implemented already set. Check whether Subp's entity 8961 -- kind conforms to the implementation kind of the overridden routine. 8962 8963 procedure Check_Pragma_Implemented 8964 (Subp : Entity_Id; 8965 Iface_Subp : Entity_Id); 8966 -- Ada 2012 (AI05-0030): Subprogram Subp overrides interface routine 8967 -- Iface_Subp and both entities have pragma Implemented already set on 8968 -- them. Check whether the two implementation kinds are conforming. 8969 8970 procedure Inherit_Pragma_Implemented 8971 (Subp : Entity_Id; 8972 Iface_Subp : Entity_Id); 8973 -- Ada 2012 (AI05-0030): Interface primitive Subp overrides interface 8974 -- subprogram Iface_Subp which has been marked by pragma Implemented. 8975 -- Propagate the implementation kind of Iface_Subp to Subp. 8976 8977 ------------------------------ 8978 -- Check_Pragma_Implemented -- 8979 ------------------------------ 8980 8981 procedure Check_Pragma_Implemented (Subp : Entity_Id) is 8982 Iface_Alias : constant Entity_Id := Interface_Alias (Subp); 8983 Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias); 8984 Subp_Alias : constant Entity_Id := Alias (Subp); 8985 Contr_Typ : Entity_Id; 8986 Impl_Subp : Entity_Id; 8987 8988 begin 8989 -- Subp must have an alias since it is a hidden entity used to link 8990 -- an interface subprogram to its overriding counterpart. 8991 8992 pragma Assert (Present (Subp_Alias)); 8993 8994 -- Handle aliases to synchronized wrappers 8995 8996 Impl_Subp := Subp_Alias; 8997 8998 if Is_Primitive_Wrapper (Impl_Subp) then 8999 Impl_Subp := Wrapped_Entity (Impl_Subp); 9000 end if; 9001 9002 -- Extract the type of the controlling formal 9003 9004 Contr_Typ := Etype (First_Formal (Subp_Alias)); 9005 9006 if Is_Concurrent_Record_Type (Contr_Typ) then 9007 Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ); 9008 end if; 9009 9010 -- An interface subprogram whose implementation kind is By_Entry must 9011 -- be implemented by an entry. 9012 9013 if Impl_Kind = Name_By_Entry 9014 and then Ekind (Impl_Subp) /= E_Entry 9015 then 9016 Error_Msg_Node_2 := Iface_Alias; 9017 Error_Msg_NE 9018 ("type & must implement abstract subprogram & with an entry", 9019 Subp_Alias, Contr_Typ); 9020 9021 elsif Impl_Kind = Name_By_Protected_Procedure then 9022 9023 -- An interface subprogram whose implementation kind is By_ 9024 -- Protected_Procedure cannot be implemented by a primitive 9025 -- procedure of a task type. 9026 9027 if Ekind (Contr_Typ) /= E_Protected_Type then 9028 Error_Msg_Node_2 := Contr_Typ; 9029 Error_Msg_NE 9030 ("interface subprogram & cannot be implemented by a " & 9031 "primitive procedure of task type &", Subp_Alias, 9032 Iface_Alias); 9033 9034 -- An interface subprogram whose implementation kind is By_ 9035 -- Protected_Procedure must be implemented by a procedure. 9036 9037 elsif Ekind (Impl_Subp) /= E_Procedure then 9038 Error_Msg_Node_2 := Iface_Alias; 9039 Error_Msg_NE 9040 ("type & must implement abstract subprogram & with a " & 9041 "procedure", Subp_Alias, Contr_Typ); 9042 end if; 9043 end if; 9044 end Check_Pragma_Implemented; 9045 9046 ------------------------------ 9047 -- Check_Pragma_Implemented -- 9048 ------------------------------ 9049 9050 procedure Check_Pragma_Implemented 9051 (Subp : Entity_Id; 9052 Iface_Subp : Entity_Id) 9053 is 9054 Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); 9055 Subp_Kind : constant Name_Id := Implementation_Kind (Subp); 9056 9057 begin 9058 -- Ada 2012 (AI05-0030): The implementation kinds of an overridden 9059 -- and overriding subprogram are different. In general this is an 9060 -- error except when the implementation kind of the overridden 9061 -- subprograms is By_Any or Optional. 9062 9063 if Iface_Kind /= Subp_Kind 9064 and then Iface_Kind /= Name_By_Any 9065 and then Iface_Kind /= Name_Optional 9066 then 9067 if Iface_Kind = Name_By_Entry then 9068 Error_Msg_N 9069 ("incompatible implementation kind, overridden subprogram " & 9070 "is marked By_Entry", Subp); 9071 else 9072 Error_Msg_N 9073 ("incompatible implementation kind, overridden subprogram " & 9074 "is marked By_Protected_Procedure", Subp); 9075 end if; 9076 end if; 9077 end Check_Pragma_Implemented; 9078 9079 -------------------------------- 9080 -- Inherit_Pragma_Implemented -- 9081 -------------------------------- 9082 9083 procedure Inherit_Pragma_Implemented 9084 (Subp : Entity_Id; 9085 Iface_Subp : Entity_Id) 9086 is 9087 Iface_Kind : constant Name_Id := Implementation_Kind (Iface_Subp); 9088 Loc : constant Source_Ptr := Sloc (Subp); 9089 Impl_Prag : Node_Id; 9090 9091 begin 9092 -- Since the implementation kind is stored as a representation item 9093 -- rather than a flag, create a pragma node. 9094 9095 Impl_Prag := 9096 Make_Pragma (Loc, 9097 Chars => Name_Implemented, 9098 Pragma_Argument_Associations => New_List ( 9099 Make_Pragma_Argument_Association (Loc, 9100 Expression => New_Reference_To (Subp, Loc)), 9101 9102 Make_Pragma_Argument_Association (Loc, 9103 Expression => Make_Identifier (Loc, Iface_Kind)))); 9104 9105 -- The pragma doesn't need to be analyzed because it is internally 9106 -- built. It is safe to directly register it as a rep item since we 9107 -- are only interested in the characters of the implementation kind. 9108 9109 Record_Rep_Item (Subp, Impl_Prag); 9110 end Inherit_Pragma_Implemented; 9111 9112 -- Start of processing for Check_Abstract_Overriding 9113 9114 begin 9115 Op_List := Primitive_Operations (T); 9116 9117 -- Loop to check primitive operations 9118 9119 Elmt := First_Elmt (Op_List); 9120 while Present (Elmt) loop 9121 Subp := Node (Elmt); 9122 Alias_Subp := Alias (Subp); 9123 9124 -- Inherited subprograms are identified by the fact that they do not 9125 -- come from source, and the associated source location is the 9126 -- location of the first subtype of the derived type. 9127 9128 -- Ada 2005 (AI-228): Apply the rules of RM-3.9.3(6/2) for 9129 -- subprograms that "require overriding". 9130 9131 -- Special exception, do not complain about failure to override the 9132 -- stream routines _Input and _Output, as well as the primitive 9133 -- operations used in dispatching selects since we always provide 9134 -- automatic overridings for these subprograms. 9135 9136 -- Also ignore this rule for convention CIL since .NET libraries 9137 -- do bizarre things with interfaces??? 9138 9139 -- The partial view of T may have been a private extension, for 9140 -- which inherited functions dispatching on result are abstract. 9141 -- If the full view is a null extension, there is no need for 9142 -- overriding in Ada 2005, but wrappers need to be built for them 9143 -- (see exp_ch3, Build_Controlling_Function_Wrappers). 9144 9145 if Is_Null_Extension (T) 9146 and then Has_Controlling_Result (Subp) 9147 and then Ada_Version >= Ada_2005 9148 and then Present (Alias_Subp) 9149 and then not Comes_From_Source (Subp) 9150 and then not Is_Abstract_Subprogram (Alias_Subp) 9151 and then not Is_Access_Type (Etype (Subp)) 9152 then 9153 null; 9154 9155 -- Ada 2005 (AI-251): Internal entities of interfaces need no 9156 -- processing because this check is done with the aliased 9157 -- entity 9158 9159 elsif Present (Interface_Alias (Subp)) then 9160 null; 9161 9162 elsif (Is_Abstract_Subprogram (Subp) 9163 or else Requires_Overriding (Subp) 9164 or else 9165 (Has_Controlling_Result (Subp) 9166 and then Present (Alias_Subp) 9167 and then not Comes_From_Source (Subp) 9168 and then Sloc (Subp) = Sloc (First_Subtype (T)))) 9169 and then not Is_TSS (Subp, TSS_Stream_Input) 9170 and then not Is_TSS (Subp, TSS_Stream_Output) 9171 and then not Is_Abstract_Type (T) 9172 and then Convention (T) /= Convention_CIL 9173 and then not Is_Predefined_Interface_Primitive (Subp) 9174 9175 -- Ada 2005 (AI-251): Do not consider hidden entities associated 9176 -- with abstract interface types because the check will be done 9177 -- with the aliased entity (otherwise we generate a duplicated 9178 -- error message). 9179 9180 and then not Present (Interface_Alias (Subp)) 9181 then 9182 if Present (Alias_Subp) then 9183 9184 -- Only perform the check for a derived subprogram when the 9185 -- type has an explicit record extension. This avoids incorrect 9186 -- flagging of abstract subprograms for the case of a type 9187 -- without an extension that is derived from a formal type 9188 -- with a tagged actual (can occur within a private part). 9189 9190 -- Ada 2005 (AI-391): In the case of an inherited function with 9191 -- a controlling result of the type, the rule does not apply if 9192 -- the type is a null extension (unless the parent function 9193 -- itself is abstract, in which case the function must still be 9194 -- be overridden). The expander will generate an overriding 9195 -- wrapper function calling the parent subprogram (see 9196 -- Exp_Ch3.Make_Controlling_Wrapper_Functions). 9197 9198 Type_Def := Type_Definition (Parent (T)); 9199 9200 if Nkind (Type_Def) = N_Derived_Type_Definition 9201 and then Present (Record_Extension_Part (Type_Def)) 9202 and then 9203 (Ada_Version < Ada_2005 9204 or else not Is_Null_Extension (T) 9205 or else Ekind (Subp) = E_Procedure 9206 or else not Has_Controlling_Result (Subp) 9207 or else Is_Abstract_Subprogram (Alias_Subp) 9208 or else Requires_Overriding (Subp) 9209 or else Is_Access_Type (Etype (Subp))) 9210 then 9211 -- Avoid reporting error in case of abstract predefined 9212 -- primitive inherited from interface type because the 9213 -- body of internally generated predefined primitives 9214 -- of tagged types are generated later by Freeze_Type 9215 9216 if Is_Interface (Root_Type (T)) 9217 and then Is_Abstract_Subprogram (Subp) 9218 and then Is_Predefined_Dispatching_Operation (Subp) 9219 and then not Comes_From_Source (Ultimate_Alias (Subp)) 9220 then 9221 null; 9222 9223 else 9224 Error_Msg_NE 9225 ("type must be declared abstract or & overridden", 9226 T, Subp); 9227 9228 -- Traverse the whole chain of aliased subprograms to 9229 -- complete the error notification. This is especially 9230 -- useful for traceability of the chain of entities when 9231 -- the subprogram corresponds with an interface 9232 -- subprogram (which may be defined in another package). 9233 9234 if Present (Alias_Subp) then 9235 declare 9236 E : Entity_Id; 9237 9238 begin 9239 E := Subp; 9240 while Present (Alias (E)) loop 9241 9242 -- Avoid reporting redundant errors on entities 9243 -- inherited from interfaces 9244 9245 if Sloc (E) /= Sloc (T) then 9246 Error_Msg_Sloc := Sloc (E); 9247 Error_Msg_NE 9248 ("\& has been inherited #", T, Subp); 9249 end if; 9250 9251 E := Alias (E); 9252 end loop; 9253 9254 Error_Msg_Sloc := Sloc (E); 9255 9256 -- AI05-0068: report if there is an overriding 9257 -- non-abstract subprogram that is invisible. 9258 9259 if Is_Hidden (E) 9260 and then not Is_Abstract_Subprogram (E) 9261 then 9262 Error_Msg_NE 9263 ("\& subprogram# is not visible", 9264 T, Subp); 9265 9266 else 9267 Error_Msg_NE 9268 ("\& has been inherited from subprogram #", 9269 T, Subp); 9270 end if; 9271 end; 9272 end if; 9273 end if; 9274 9275 -- Ada 2005 (AI-345): Protected or task type implementing 9276 -- abstract interfaces. 9277 9278 elsif Is_Concurrent_Record_Type (T) 9279 and then Present (Interfaces (T)) 9280 then 9281 -- The controlling formal of Subp must be of mode "out", 9282 -- "in out" or an access-to-variable to be overridden. 9283 9284 if Ekind (First_Formal (Subp)) = E_In_Parameter 9285 and then Ekind (Subp) /= E_Function 9286 then 9287 if not Is_Predefined_Dispatching_Operation (Subp) 9288 and then Is_Protected_Type 9289 (Corresponding_Concurrent_Type (T)) 9290 then 9291 Error_Msg_PT (T, Subp); 9292 end if; 9293 9294 -- Some other kind of overriding failure 9295 9296 else 9297 Error_Msg_NE 9298 ("interface subprogram & must be overridden", 9299 T, Subp); 9300 9301 -- Examine primitive operations of synchronized type, 9302 -- to find homonyms that have the wrong profile. 9303 9304 declare 9305 Prim : Entity_Id; 9306 9307 begin 9308 Prim := 9309 First_Entity (Corresponding_Concurrent_Type (T)); 9310 while Present (Prim) loop 9311 if Chars (Prim) = Chars (Subp) then 9312 Error_Msg_NE 9313 ("profile is not type conformant with " 9314 & "prefixed view profile of " 9315 & "inherited operation&", Prim, Subp); 9316 end if; 9317 9318 Next_Entity (Prim); 9319 end loop; 9320 end; 9321 end if; 9322 end if; 9323 9324 else 9325 Error_Msg_Node_2 := T; 9326 Error_Msg_N 9327 ("abstract subprogram& not allowed for type&", Subp); 9328 9329 -- Also post unconditional warning on the type (unconditional 9330 -- so that if there are more than one of these cases, we get 9331 -- them all, and not just the first one). 9332 9333 Error_Msg_Node_2 := Subp; 9334 Error_Msg_N ("nonabstract type& has abstract subprogram&!", T); 9335 end if; 9336 end if; 9337 9338 -- Ada 2012 (AI05-0030): Perform some checks related to pragma 9339 -- Implemented 9340 9341 -- Subp is an expander-generated procedure which maps an interface 9342 -- alias to a protected wrapper. The interface alias is flagged by 9343 -- pragma Implemented. Ensure that Subp is a procedure when the 9344 -- implementation kind is By_Protected_Procedure or an entry when 9345 -- By_Entry. 9346 9347 if Ada_Version >= Ada_2012 9348 and then Is_Hidden (Subp) 9349 and then Present (Interface_Alias (Subp)) 9350 and then Has_Rep_Pragma (Interface_Alias (Subp), Name_Implemented) 9351 then 9352 Check_Pragma_Implemented (Subp); 9353 end if; 9354 9355 -- Subp is an interface primitive which overrides another interface 9356 -- primitive marked with pragma Implemented. 9357 9358 if Ada_Version >= Ada_2012 9359 and then Present (Overridden_Operation (Subp)) 9360 and then Has_Rep_Pragma 9361 (Overridden_Operation (Subp), Name_Implemented) 9362 then 9363 -- If the overriding routine is also marked by Implemented, check 9364 -- that the two implementation kinds are conforming. 9365 9366 if Has_Rep_Pragma (Subp, Name_Implemented) then 9367 Check_Pragma_Implemented 9368 (Subp => Subp, 9369 Iface_Subp => Overridden_Operation (Subp)); 9370 9371 -- Otherwise the overriding routine inherits the implementation 9372 -- kind from the overridden subprogram. 9373 9374 else 9375 Inherit_Pragma_Implemented 9376 (Subp => Subp, 9377 Iface_Subp => Overridden_Operation (Subp)); 9378 end if; 9379 end if; 9380 9381 Next_Elmt (Elmt); 9382 end loop; 9383 end Check_Abstract_Overriding; 9384 9385 ------------------------------------------------ 9386 -- Check_Access_Discriminant_Requires_Limited -- 9387 ------------------------------------------------ 9388 9389 procedure Check_Access_Discriminant_Requires_Limited 9390 (D : Node_Id; 9391 Loc : Node_Id) 9392 is 9393 begin 9394 -- A discriminant_specification for an access discriminant shall appear 9395 -- only in the declaration for a task or protected type, or for a type 9396 -- with the reserved word 'limited' in its definition or in one of its 9397 -- ancestors (RM 3.7(10)). 9398 9399 -- AI-0063: The proper condition is that type must be immutably limited, 9400 -- or else be a partial view. 9401 9402 if Nkind (Discriminant_Type (D)) = N_Access_Definition then 9403 if Is_Immutably_Limited_Type (Current_Scope) 9404 or else 9405 (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration 9406 and then Limited_Present (Parent (Current_Scope))) 9407 then 9408 null; 9409 9410 else 9411 Error_Msg_N 9412 ("access discriminants allowed only for limited types", Loc); 9413 end if; 9414 end if; 9415 end Check_Access_Discriminant_Requires_Limited; 9416 9417 ----------------------------------- 9418 -- Check_Aliased_Component_Types -- 9419 ----------------------------------- 9420 9421 procedure Check_Aliased_Component_Types (T : Entity_Id) is 9422 C : Entity_Id; 9423 9424 begin 9425 -- ??? Also need to check components of record extensions, but not 9426 -- components of protected types (which are always limited). 9427 9428 -- Ada 2005: AI-363 relaxes this rule, to allow heap objects of such 9429 -- types to be unconstrained. This is safe because it is illegal to 9430 -- create access subtypes to such types with explicit discriminant 9431 -- constraints. 9432 9433 if not Is_Limited_Type (T) then 9434 if Ekind (T) = E_Record_Type then 9435 C := First_Component (T); 9436 while Present (C) loop 9437 if Is_Aliased (C) 9438 and then Has_Discriminants (Etype (C)) 9439 and then not Is_Constrained (Etype (C)) 9440 and then not In_Instance_Body 9441 and then Ada_Version < Ada_2005 9442 then 9443 Error_Msg_N 9444 ("aliased component must be constrained (RM 3.6(11))", 9445 C); 9446 end if; 9447 9448 Next_Component (C); 9449 end loop; 9450 9451 elsif Ekind (T) = E_Array_Type then 9452 if Has_Aliased_Components (T) 9453 and then Has_Discriminants (Component_Type (T)) 9454 and then not Is_Constrained (Component_Type (T)) 9455 and then not In_Instance_Body 9456 and then Ada_Version < Ada_2005 9457 then 9458 Error_Msg_N 9459 ("aliased component type must be constrained (RM 3.6(11))", 9460 T); 9461 end if; 9462 end if; 9463 end if; 9464 end Check_Aliased_Component_Types; 9465 9466 ---------------------- 9467 -- Check_Completion -- 9468 ---------------------- 9469 9470 procedure Check_Completion (Body_Id : Node_Id := Empty) is 9471 E : Entity_Id; 9472 9473 procedure Post_Error; 9474 -- Post error message for lack of completion for entity E 9475 9476 ---------------- 9477 -- Post_Error -- 9478 ---------------- 9479 9480 procedure Post_Error is 9481 9482 procedure Missing_Body; 9483 -- Output missing body message 9484 9485 ------------------ 9486 -- Missing_Body -- 9487 ------------------ 9488 9489 procedure Missing_Body is 9490 begin 9491 -- Spec is in same unit, so we can post on spec 9492 9493 if In_Same_Source_Unit (Body_Id, E) then 9494 Error_Msg_N ("missing body for &", E); 9495 9496 -- Spec is in a separate unit, so we have to post on the body 9497 9498 else 9499 Error_Msg_NE ("missing body for & declared#!", Body_Id, E); 9500 end if; 9501 end Missing_Body; 9502 9503 -- Start of processing for Post_Error 9504 9505 begin 9506 if not Comes_From_Source (E) then 9507 9508 if Ekind_In (E, E_Task_Type, E_Protected_Type) then 9509 -- It may be an anonymous protected type created for a 9510 -- single variable. Post error on variable, if present. 9511 9512 declare 9513 Var : Entity_Id; 9514 9515 begin 9516 Var := First_Entity (Current_Scope); 9517 while Present (Var) loop 9518 exit when Etype (Var) = E 9519 and then Comes_From_Source (Var); 9520 9521 Next_Entity (Var); 9522 end loop; 9523 9524 if Present (Var) then 9525 E := Var; 9526 end if; 9527 end; 9528 end if; 9529 end if; 9530 9531 -- If a generated entity has no completion, then either previous 9532 -- semantic errors have disabled the expansion phase, or else we had 9533 -- missing subunits, or else we are compiling without expansion, 9534 -- or else something is very wrong. 9535 9536 if not Comes_From_Source (E) then 9537 pragma Assert 9538 (Serious_Errors_Detected > 0 9539 or else Configurable_Run_Time_Violations > 0 9540 or else Subunits_Missing 9541 or else not Expander_Active); 9542 return; 9543 9544 -- Here for source entity 9545 9546 else 9547 -- Here if no body to post the error message, so we post the error 9548 -- on the declaration that has no completion. This is not really 9549 -- the right place to post it, think about this later ??? 9550 9551 if No (Body_Id) then 9552 if Is_Type (E) then 9553 Error_Msg_NE 9554 ("missing full declaration for }", Parent (E), E); 9555 else 9556 Error_Msg_NE ("missing body for &", Parent (E), E); 9557 end if; 9558 9559 -- Package body has no completion for a declaration that appears 9560 -- in the corresponding spec. Post error on the body, with a 9561 -- reference to the non-completed declaration. 9562 9563 else 9564 Error_Msg_Sloc := Sloc (E); 9565 9566 if Is_Type (E) then 9567 Error_Msg_NE ("missing full declaration for }!", Body_Id, E); 9568 9569 elsif Is_Overloadable (E) 9570 and then Current_Entity_In_Scope (E) /= E 9571 then 9572 -- It may be that the completion is mistyped and appears as 9573 -- a distinct overloading of the entity. 9574 9575 declare 9576 Candidate : constant Entity_Id := 9577 Current_Entity_In_Scope (E); 9578 Decl : constant Node_Id := 9579 Unit_Declaration_Node (Candidate); 9580 9581 begin 9582 if Is_Overloadable (Candidate) 9583 and then Ekind (Candidate) = Ekind (E) 9584 and then Nkind (Decl) = N_Subprogram_Body 9585 and then Acts_As_Spec (Decl) 9586 then 9587 Check_Type_Conformant (Candidate, E); 9588 9589 else 9590 Missing_Body; 9591 end if; 9592 end; 9593 9594 else 9595 Missing_Body; 9596 end if; 9597 end if; 9598 end if; 9599 end Post_Error; 9600 9601 -- Start of processing for Check_Completion 9602 9603 begin 9604 E := First_Entity (Current_Scope); 9605 while Present (E) loop 9606 if Is_Intrinsic_Subprogram (E) then 9607 null; 9608 9609 -- The following situation requires special handling: a child unit 9610 -- that appears in the context clause of the body of its parent: 9611 9612 -- procedure Parent.Child (...); 9613 9614 -- with Parent.Child; 9615 -- package body Parent is 9616 9617 -- Here Parent.Child appears as a local entity, but should not be 9618 -- flagged as requiring completion, because it is a compilation 9619 -- unit. 9620 9621 -- Ignore missing completion for a subprogram that does not come from 9622 -- source (including the _Call primitive operation of RAS types, 9623 -- which has to have the flag Comes_From_Source for other purposes): 9624 -- we assume that the expander will provide the missing completion. 9625 -- In case of previous errors, other expansion actions that provide 9626 -- bodies for null procedures with not be invoked, so inhibit message 9627 -- in those cases. 9628 9629 -- Note that E_Operator is not in the list that follows, because 9630 -- this kind is reserved for predefined operators, that are 9631 -- intrinsic and do not need completion. 9632 9633 elsif Ekind (E) = E_Function 9634 or else Ekind (E) = E_Procedure 9635 or else Ekind (E) = E_Generic_Function 9636 or else Ekind (E) = E_Generic_Procedure 9637 then 9638 if Has_Completion (E) then 9639 null; 9640 9641 elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then 9642 null; 9643 9644 elsif Is_Subprogram (E) 9645 and then (not Comes_From_Source (E) 9646 or else Chars (E) = Name_uCall) 9647 then 9648 null; 9649 9650 elsif 9651 Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit 9652 then 9653 null; 9654 9655 elsif Nkind (Parent (E)) = N_Procedure_Specification 9656 and then Null_Present (Parent (E)) 9657 and then Serious_Errors_Detected > 0 9658 then 9659 null; 9660 9661 else 9662 Post_Error; 9663 end if; 9664 9665 elsif Is_Entry (E) then 9666 if not Has_Completion (E) and then 9667 (Ekind (Scope (E)) = E_Protected_Object 9668 or else Ekind (Scope (E)) = E_Protected_Type) 9669 then 9670 Post_Error; 9671 end if; 9672 9673 elsif Is_Package_Or_Generic_Package (E) then 9674 if Unit_Requires_Body (E) then 9675 if not Has_Completion (E) 9676 and then Nkind (Parent (Unit_Declaration_Node (E))) /= 9677 N_Compilation_Unit 9678 then 9679 Post_Error; 9680 end if; 9681 9682 elsif not Is_Child_Unit (E) then 9683 May_Need_Implicit_Body (E); 9684 end if; 9685 9686 -- A formal incomplete type (Ada 2012) does not require a completion; 9687 -- other incomplete type declarations do. 9688 9689 elsif Ekind (E) = E_Incomplete_Type 9690 and then No (Underlying_Type (E)) 9691 and then not Is_Generic_Type (E) 9692 then 9693 Post_Error; 9694 9695 elsif (Ekind (E) = E_Task_Type or else 9696 Ekind (E) = E_Protected_Type) 9697 and then not Has_Completion (E) 9698 then 9699 Post_Error; 9700 9701 -- A single task declared in the current scope is a constant, verify 9702 -- that the body of its anonymous type is in the same scope. If the 9703 -- task is defined elsewhere, this may be a renaming declaration for 9704 -- which no completion is needed. 9705 9706 elsif Ekind (E) = E_Constant 9707 and then Ekind (Etype (E)) = E_Task_Type 9708 and then not Has_Completion (Etype (E)) 9709 and then Scope (Etype (E)) = Current_Scope 9710 then 9711 Post_Error; 9712 9713 elsif Ekind (E) = E_Protected_Object 9714 and then not Has_Completion (Etype (E)) 9715 then 9716 Post_Error; 9717 9718 elsif Ekind (E) = E_Record_Type then 9719 if Is_Tagged_Type (E) then 9720 Check_Abstract_Overriding (E); 9721 Check_Conventions (E); 9722 end if; 9723 9724 Check_Aliased_Component_Types (E); 9725 9726 elsif Ekind (E) = E_Array_Type then 9727 Check_Aliased_Component_Types (E); 9728 9729 end if; 9730 9731 Next_Entity (E); 9732 end loop; 9733 end Check_Completion; 9734 9735 ------------------------------------ 9736 -- Check_CPP_Type_Has_No_Defaults -- 9737 ------------------------------------ 9738 9739 procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is 9740 Tdef : constant Node_Id := Type_Definition (Declaration_Node (T)); 9741 Clist : Node_Id; 9742 Comp : Node_Id; 9743 9744 begin 9745 -- Obtain the component list 9746 9747 if Nkind (Tdef) = N_Record_Definition then 9748 Clist := Component_List (Tdef); 9749 else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); 9750 Clist := Component_List (Record_Extension_Part (Tdef)); 9751 end if; 9752 9753 -- Check all components to ensure no default expressions 9754 9755 if Present (Clist) then 9756 Comp := First (Component_Items (Clist)); 9757 while Present (Comp) loop 9758 if Present (Expression (Comp)) then 9759 Error_Msg_N 9760 ("component of imported 'C'P'P type cannot have " 9761 & "default expression", Expression (Comp)); 9762 end if; 9763 9764 Next (Comp); 9765 end loop; 9766 end if; 9767 end Check_CPP_Type_Has_No_Defaults; 9768 9769 ---------------------------- 9770 -- Check_Delta_Expression -- 9771 ---------------------------- 9772 9773 procedure Check_Delta_Expression (E : Node_Id) is 9774 begin 9775 if not (Is_Real_Type (Etype (E))) then 9776 Wrong_Type (E, Any_Real); 9777 9778 elsif not Is_OK_Static_Expression (E) then 9779 Flag_Non_Static_Expr 9780 ("non-static expression used for delta value!", E); 9781 9782 elsif not UR_Is_Positive (Expr_Value_R (E)) then 9783 Error_Msg_N ("delta expression must be positive", E); 9784 9785 else 9786 return; 9787 end if; 9788 9789 -- If any of above errors occurred, then replace the incorrect 9790 -- expression by the real 0.1, which should prevent further errors. 9791 9792 Rewrite (E, 9793 Make_Real_Literal (Sloc (E), Ureal_Tenth)); 9794 Analyze_And_Resolve (E, Standard_Float); 9795 end Check_Delta_Expression; 9796 9797 ----------------------------- 9798 -- Check_Digits_Expression -- 9799 ----------------------------- 9800 9801 procedure Check_Digits_Expression (E : Node_Id) is 9802 begin 9803 if not (Is_Integer_Type (Etype (E))) then 9804 Wrong_Type (E, Any_Integer); 9805 9806 elsif not Is_OK_Static_Expression (E) then 9807 Flag_Non_Static_Expr 9808 ("non-static expression used for digits value!", E); 9809 9810 elsif Expr_Value (E) <= 0 then 9811 Error_Msg_N ("digits value must be greater than zero", E); 9812 9813 else 9814 return; 9815 end if; 9816 9817 -- If any of above errors occurred, then replace the incorrect 9818 -- expression by the integer 1, which should prevent further errors. 9819 9820 Rewrite (E, Make_Integer_Literal (Sloc (E), 1)); 9821 Analyze_And_Resolve (E, Standard_Integer); 9822 9823 end Check_Digits_Expression; 9824 9825 -------------------------- 9826 -- Check_Initialization -- 9827 -------------------------- 9828 9829 procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is 9830 begin 9831 if Is_Limited_Type (T) 9832 and then not In_Instance 9833 and then not In_Inlined_Body 9834 then 9835 if not OK_For_Limited_Init (T, Exp) then 9836 9837 -- In GNAT mode, this is just a warning, to allow it to be evilly 9838 -- turned off. Otherwise it is a real error. 9839 9840 if GNAT_Mode then 9841 Error_Msg_N 9842 ("?cannot initialize entities of limited type!", Exp); 9843 9844 elsif Ada_Version < Ada_2005 then 9845 9846 -- The side effect removal machinery may generate illegal Ada 9847 -- code to avoid the usage of access types and 'reference in 9848 -- Alfa mode. Since this is legal code with respect to theorem 9849 -- proving, do not emit the error. 9850 9851 if Alfa_Mode 9852 and then Nkind (Exp) = N_Function_Call 9853 and then Nkind (Parent (Exp)) = N_Object_Declaration 9854 and then not Comes_From_Source 9855 (Defining_Identifier (Parent (Exp))) 9856 then 9857 null; 9858 9859 else 9860 Error_Msg_N 9861 ("cannot initialize entities of limited type", Exp); 9862 Explain_Limited_Type (T, Exp); 9863 end if; 9864 9865 else 9866 -- Specialize error message according to kind of illegal 9867 -- initial expression. 9868 9869 if Nkind (Exp) = N_Type_Conversion 9870 and then Nkind (Expression (Exp)) = N_Function_Call 9871 then 9872 Error_Msg_N 9873 ("illegal context for call" 9874 & " to function with limited result", Exp); 9875 9876 else 9877 Error_Msg_N 9878 ("initialization of limited object requires aggregate " 9879 & "or function call", Exp); 9880 end if; 9881 end if; 9882 end if; 9883 end if; 9884 end Check_Initialization; 9885 9886 ---------------------- 9887 -- Check_Interfaces -- 9888 ---------------------- 9889 9890 procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is 9891 Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); 9892 9893 Iface : Node_Id; 9894 Iface_Def : Node_Id; 9895 Iface_Typ : Entity_Id; 9896 Parent_Node : Node_Id; 9897 9898 Is_Task : Boolean := False; 9899 -- Set True if parent type or any progenitor is a task interface 9900 9901 Is_Protected : Boolean := False; 9902 -- Set True if parent type or any progenitor is a protected interface 9903 9904 procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); 9905 -- Check that a progenitor is compatible with declaration. 9906 -- Error is posted on Error_Node. 9907 9908 ------------------ 9909 -- Check_Ifaces -- 9910 ------------------ 9911 9912 procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is 9913 Iface_Id : constant Entity_Id := 9914 Defining_Identifier (Parent (Iface_Def)); 9915 Type_Def : Node_Id; 9916 9917 begin 9918 if Nkind (N) = N_Private_Extension_Declaration then 9919 Type_Def := N; 9920 else 9921 Type_Def := Type_Definition (N); 9922 end if; 9923 9924 if Is_Task_Interface (Iface_Id) then 9925 Is_Task := True; 9926 9927 elsif Is_Protected_Interface (Iface_Id) then 9928 Is_Protected := True; 9929 end if; 9930 9931 if Is_Synchronized_Interface (Iface_Id) then 9932 9933 -- A consequence of 3.9.4 (6/2) and 7.3 (7.2/2) is that a private 9934 -- extension derived from a synchronized interface must explicitly 9935 -- be declared synchronized, because the full view will be a 9936 -- synchronized type. 9937 9938 if Nkind (N) = N_Private_Extension_Declaration then 9939 if not Synchronized_Present (N) then 9940 Error_Msg_NE 9941 ("private extension of& must be explicitly synchronized", 9942 N, Iface_Id); 9943 end if; 9944 9945 -- However, by 3.9.4(16/2), a full type that is a record extension 9946 -- is never allowed to derive from a synchronized interface (note 9947 -- that interfaces must be excluded from this check, because those 9948 -- are represented by derived type definitions in some cases). 9949 9950 elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition 9951 and then not Interface_Present (Type_Definition (N)) 9952 then 9953 Error_Msg_N ("record extension cannot derive from synchronized" 9954 & " interface", Error_Node); 9955 end if; 9956 end if; 9957 9958 -- Check that the characteristics of the progenitor are compatible 9959 -- with the explicit qualifier in the declaration. 9960 -- The check only applies to qualifiers that come from source. 9961 -- Limited_Present also appears in the declaration of corresponding 9962 -- records, and the check does not apply to them. 9963 9964 if Limited_Present (Type_Def) 9965 and then not 9966 Is_Concurrent_Record_Type (Defining_Identifier (N)) 9967 then 9968 if Is_Limited_Interface (Parent_Type) 9969 and then not Is_Limited_Interface (Iface_Id) 9970 then 9971 Error_Msg_NE 9972 ("progenitor& must be limited interface", 9973 Error_Node, Iface_Id); 9974 9975 elsif 9976 (Task_Present (Iface_Def) 9977 or else Protected_Present (Iface_Def) 9978 or else Synchronized_Present (Iface_Def)) 9979 and then Nkind (N) /= N_Private_Extension_Declaration 9980 and then not Error_Posted (N) 9981 then 9982 Error_Msg_NE 9983 ("progenitor& must be limited interface", 9984 Error_Node, Iface_Id); 9985 end if; 9986 9987 -- Protected interfaces can only inherit from limited, synchronized 9988 -- or protected interfaces. 9989 9990 elsif Nkind (N) = N_Full_Type_Declaration 9991 and then Protected_Present (Type_Def) 9992 then 9993 if Limited_Present (Iface_Def) 9994 or else Synchronized_Present (Iface_Def) 9995 or else Protected_Present (Iface_Def) 9996 then 9997 null; 9998 9999 elsif Task_Present (Iface_Def) then 10000 Error_Msg_N ("(Ada 2005) protected interface cannot inherit" 10001 & " from task interface", Error_Node); 10002 10003 else 10004 Error_Msg_N ("(Ada 2005) protected interface cannot inherit" 10005 & " from non-limited interface", Error_Node); 10006 end if; 10007 10008 -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from 10009 -- limited and synchronized. 10010 10011 elsif Synchronized_Present (Type_Def) then 10012 if Limited_Present (Iface_Def) 10013 or else Synchronized_Present (Iface_Def) 10014 then 10015 null; 10016 10017 elsif Protected_Present (Iface_Def) 10018 and then Nkind (N) /= N_Private_Extension_Declaration 10019 then 10020 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" 10021 & " from protected interface", Error_Node); 10022 10023 elsif Task_Present (Iface_Def) 10024 and then Nkind (N) /= N_Private_Extension_Declaration 10025 then 10026 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" 10027 & " from task interface", Error_Node); 10028 10029 elsif not Is_Limited_Interface (Iface_Id) then 10030 Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" 10031 & " from non-limited interface", Error_Node); 10032 end if; 10033 10034 -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, 10035 -- synchronized or task interfaces. 10036 10037 elsif Nkind (N) = N_Full_Type_Declaration 10038 and then Task_Present (Type_Def) 10039 then 10040 if Limited_Present (Iface_Def) 10041 or else Synchronized_Present (Iface_Def) 10042 or else Task_Present (Iface_Def) 10043 then 10044 null; 10045 10046 elsif Protected_Present (Iface_Def) then 10047 Error_Msg_N ("(Ada 2005) task interface cannot inherit from" 10048 & " protected interface", Error_Node); 10049 10050 else 10051 Error_Msg_N ("(Ada 2005) task interface cannot inherit from" 10052 & " non-limited interface", Error_Node); 10053 end if; 10054 end if; 10055 end Check_Ifaces; 10056 10057 -- Start of processing for Check_Interfaces 10058 10059 begin 10060 if Is_Interface (Parent_Type) then 10061 if Is_Task_Interface (Parent_Type) then 10062 Is_Task := True; 10063 10064 elsif Is_Protected_Interface (Parent_Type) then 10065 Is_Protected := True; 10066 end if; 10067 end if; 10068 10069 if Nkind (N) = N_Private_Extension_Declaration then 10070 10071 -- Check that progenitors are compatible with declaration 10072 10073 Iface := First (Interface_List (Def)); 10074 while Present (Iface) loop 10075 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 10076 10077 Parent_Node := Parent (Base_Type (Iface_Typ)); 10078 Iface_Def := Type_Definition (Parent_Node); 10079 10080 if not Is_Interface (Iface_Typ) then 10081 Diagnose_Interface (Iface, Iface_Typ); 10082 10083 else 10084 Check_Ifaces (Iface_Def, Iface); 10085 end if; 10086 10087 Next (Iface); 10088 end loop; 10089 10090 if Is_Task and Is_Protected then 10091 Error_Msg_N 10092 ("type cannot derive from task and protected interface", N); 10093 end if; 10094 10095 return; 10096 end if; 10097 10098 -- Full type declaration of derived type. 10099 -- Check compatibility with parent if it is interface type 10100 10101 if Nkind (Type_Definition (N)) = N_Derived_Type_Definition 10102 and then Is_Interface (Parent_Type) 10103 then 10104 Parent_Node := Parent (Parent_Type); 10105 10106 -- More detailed checks for interface varieties 10107 10108 Check_Ifaces 10109 (Iface_Def => Type_Definition (Parent_Node), 10110 Error_Node => Subtype_Indication (Type_Definition (N))); 10111 end if; 10112 10113 Iface := First (Interface_List (Def)); 10114 while Present (Iface) loop 10115 Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); 10116 10117 Parent_Node := Parent (Base_Type (Iface_Typ)); 10118 Iface_Def := Type_Definition (Parent_Node); 10119 10120 if not Is_Interface (Iface_Typ) then 10121 Diagnose_Interface (Iface, Iface_Typ); 10122 10123 else 10124 -- "The declaration of a specific descendant of an interface 10125 -- type freezes the interface type" RM 13.14 10126 10127 Freeze_Before (N, Iface_Typ); 10128 Check_Ifaces (Iface_Def, Error_Node => Iface); 10129 end if; 10130 10131 Next (Iface); 10132 end loop; 10133 10134 if Is_Task and Is_Protected then 10135 Error_Msg_N 10136 ("type cannot derive from task and protected interface", N); 10137 end if; 10138 end Check_Interfaces; 10139 10140 ------------------------------------ 10141 -- Check_Or_Process_Discriminants -- 10142 ------------------------------------ 10143 10144 -- If an incomplete or private type declaration was already given for the 10145 -- type, the discriminants may have already been processed if they were 10146 -- present on the incomplete declaration. In this case a full conformance 10147 -- check has been performed in Find_Type_Name, and we then recheck here 10148 -- some properties that can't be checked on the partial view alone. 10149 -- Otherwise we call Process_Discriminants. 10150 10151 procedure Check_Or_Process_Discriminants 10152 (N : Node_Id; 10153 T : Entity_Id; 10154 Prev : Entity_Id := Empty) 10155 is 10156 begin 10157 if Has_Discriminants (T) then 10158 10159 -- Discriminants are already set on T if they were already present 10160 -- on the partial view. Make them visible to component declarations. 10161 10162 declare 10163 D : Entity_Id; 10164 -- Discriminant on T (full view) referencing expr on partial view 10165 10166 Prev_D : Entity_Id; 10167 -- Entity of corresponding discriminant on partial view 10168 10169 New_D : Node_Id; 10170 -- Discriminant specification for full view, expression is the 10171 -- syntactic copy on full view (which has been checked for 10172 -- conformance with partial view), only used here to post error 10173 -- message. 10174 10175 begin 10176 D := First_Discriminant (T); 10177 New_D := First (Discriminant_Specifications (N)); 10178 while Present (D) loop 10179 Prev_D := Current_Entity (D); 10180 Set_Current_Entity (D); 10181 Set_Is_Immediately_Visible (D); 10182 Set_Homonym (D, Prev_D); 10183 10184 -- Handle the case where there is an untagged partial view and 10185 -- the full view is tagged: must disallow discriminants with 10186 -- defaults, unless compiling for Ada 2012, which allows a 10187 -- limited tagged type to have defaulted discriminants (see 10188 -- AI05-0214). However, suppress the error here if it was 10189 -- already reported on the default expression of the partial 10190 -- view. 10191 10192 if Is_Tagged_Type (T) 10193 and then Present (Expression (Parent (D))) 10194 and then (not Is_Limited_Type (Current_Scope) 10195 or else Ada_Version < Ada_2012) 10196 and then not Error_Posted (Expression (Parent (D))) 10197 then 10198 if Ada_Version >= Ada_2012 then 10199 Error_Msg_N 10200 ("discriminants of nonlimited tagged type cannot have" 10201 & " defaults", 10202 Expression (New_D)); 10203 else 10204 Error_Msg_N 10205 ("discriminants of tagged type cannot have defaults", 10206 Expression (New_D)); 10207 end if; 10208 end if; 10209 10210 -- Ada 2005 (AI-230): Access discriminant allowed in 10211 -- non-limited record types. 10212 10213 if Ada_Version < Ada_2005 then 10214 10215 -- This restriction gets applied to the full type here. It 10216 -- has already been applied earlier to the partial view. 10217 10218 Check_Access_Discriminant_Requires_Limited (Parent (D), N); 10219 end if; 10220 10221 Next_Discriminant (D); 10222 Next (New_D); 10223 end loop; 10224 end; 10225 10226 elsif Present (Discriminant_Specifications (N)) then 10227 Process_Discriminants (N, Prev); 10228 end if; 10229 end Check_Or_Process_Discriminants; 10230 10231 ---------------------- 10232 -- Check_Real_Bound -- 10233 ---------------------- 10234 10235 procedure Check_Real_Bound (Bound : Node_Id) is 10236 begin 10237 if not Is_Real_Type (Etype (Bound)) then 10238 Error_Msg_N 10239 ("bound in real type definition must be of real type", Bound); 10240 10241 elsif not Is_OK_Static_Expression (Bound) then 10242 Flag_Non_Static_Expr 10243 ("non-static expression used for real type bound!", Bound); 10244 10245 else 10246 return; 10247 end if; 10248 10249 Rewrite 10250 (Bound, Make_Real_Literal (Sloc (Bound), Ureal_0)); 10251 Analyze (Bound); 10252 Resolve (Bound, Standard_Float); 10253 end Check_Real_Bound; 10254 10255 ------------------------------ 10256 -- Complete_Private_Subtype -- 10257 ------------------------------ 10258 10259 procedure Complete_Private_Subtype 10260 (Priv : Entity_Id; 10261 Full : Entity_Id; 10262 Full_Base : Entity_Id; 10263 Related_Nod : Node_Id) 10264 is 10265 Save_Next_Entity : Entity_Id; 10266 Save_Homonym : Entity_Id; 10267 10268 begin 10269 -- Set semantic attributes for (implicit) private subtype completion. 10270 -- If the full type has no discriminants, then it is a copy of the full 10271 -- view of the base. Otherwise, it is a subtype of the base with a 10272 -- possible discriminant constraint. Save and restore the original 10273 -- Next_Entity field of full to ensure that the calls to Copy_Node 10274 -- do not corrupt the entity chain. 10275 10276 -- Note that the type of the full view is the same entity as the type of 10277 -- the partial view. In this fashion, the subtype has access to the 10278 -- correct view of the parent. 10279 10280 Save_Next_Entity := Next_Entity (Full); 10281 Save_Homonym := Homonym (Priv); 10282 10283 case Ekind (Full_Base) is 10284 when E_Record_Type | 10285 E_Record_Subtype | 10286 Class_Wide_Kind | 10287 Private_Kind | 10288 Task_Kind | 10289 Protected_Kind => 10290 Copy_Node (Priv, Full); 10291 10292 Set_Has_Discriminants 10293 (Full, Has_Discriminants (Full_Base)); 10294 Set_Has_Unknown_Discriminants 10295 (Full, Has_Unknown_Discriminants (Full_Base)); 10296 Set_First_Entity (Full, First_Entity (Full_Base)); 10297 Set_Last_Entity (Full, Last_Entity (Full_Base)); 10298 10299 when others => 10300 Copy_Node (Full_Base, Full); 10301 10302 Set_Chars (Full, Chars (Priv)); 10303 Conditional_Delay (Full, Priv); 10304 Set_Sloc (Full, Sloc (Priv)); 10305 end case; 10306 10307 Set_Next_Entity (Full, Save_Next_Entity); 10308 Set_Homonym (Full, Save_Homonym); 10309 Set_Associated_Node_For_Itype (Full, Related_Nod); 10310 10311 -- Set common attributes for all subtypes: kind, convention, etc. 10312 10313 Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); 10314 Set_Convention (Full, Convention (Full_Base)); 10315 10316 -- The Etype of the full view is inconsistent. Gigi needs to see the 10317 -- structural full view, which is what the current scheme gives: 10318 -- the Etype of the full view is the etype of the full base. However, 10319 -- if the full base is a derived type, the full view then looks like 10320 -- a subtype of the parent, not a subtype of the full base. If instead 10321 -- we write: 10322 10323 -- Set_Etype (Full, Full_Base); 10324 10325 -- then we get inconsistencies in the front-end (confusion between 10326 -- views). Several outstanding bugs are related to this ??? 10327 10328 Set_Is_First_Subtype (Full, False); 10329 Set_Scope (Full, Scope (Priv)); 10330 Set_Size_Info (Full, Full_Base); 10331 Set_RM_Size (Full, RM_Size (Full_Base)); 10332 Set_Is_Itype (Full); 10333 10334 -- A subtype of a private-type-without-discriminants, whose full-view 10335 -- has discriminants with default expressions, is not constrained! 10336 10337 if not Has_Discriminants (Priv) then 10338 Set_Is_Constrained (Full, Is_Constrained (Full_Base)); 10339 10340 if Has_Discriminants (Full_Base) then 10341 Set_Discriminant_Constraint 10342 (Full, Discriminant_Constraint (Full_Base)); 10343 10344 -- The partial view may have been indefinite, the full view 10345 -- might not be. 10346 10347 Set_Has_Unknown_Discriminants 10348 (Full, Has_Unknown_Discriminants (Full_Base)); 10349 end if; 10350 end if; 10351 10352 Set_First_Rep_Item (Full, First_Rep_Item (Full_Base)); 10353 Set_Depends_On_Private (Full, Has_Private_Component (Full)); 10354 10355 -- Freeze the private subtype entity if its parent is delayed, and not 10356 -- already frozen. We skip this processing if the type is an anonymous 10357 -- subtype of a record component, or is the corresponding record of a 10358 -- protected type, since ??? 10359 10360 if not Is_Type (Scope (Full)) then 10361 Set_Has_Delayed_Freeze (Full, 10362 Has_Delayed_Freeze (Full_Base) 10363 and then (not Is_Frozen (Full_Base))); 10364 end if; 10365 10366 Set_Freeze_Node (Full, Empty); 10367 Set_Is_Frozen (Full, False); 10368 Set_Full_View (Priv, Full); 10369 10370 if Has_Discriminants (Full) then 10371 Set_Stored_Constraint_From_Discriminant_Constraint (Full); 10372 Set_Stored_Constraint (Priv, Stored_Constraint (Full)); 10373 10374 if Has_Unknown_Discriminants (Full) then 10375 Set_Discriminant_Constraint (Full, No_Elist); 10376 end if; 10377 end if; 10378 10379 if Ekind (Full_Base) = E_Record_Type 10380 and then Has_Discriminants (Full_Base) 10381 and then Has_Discriminants (Priv) -- might not, if errors 10382 and then not Has_Unknown_Discriminants (Priv) 10383 and then not Is_Empty_Elmt_List (Discriminant_Constraint (Priv)) 10384 then 10385 Create_Constrained_Components 10386 (Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv)); 10387 10388 -- If the full base is itself derived from private, build a congruent 10389 -- subtype of its underlying type, for use by the back end. For a 10390 -- constrained record component, the declaration cannot be placed on 10391 -- the component list, but it must nevertheless be built an analyzed, to 10392 -- supply enough information for Gigi to compute the size of component. 10393 10394 elsif Ekind (Full_Base) in Private_Kind 10395 and then Is_Derived_Type (Full_Base) 10396 and then Has_Discriminants (Full_Base) 10397 and then (Ekind (Current_Scope) /= E_Record_Subtype) 10398 then 10399 if not Is_Itype (Priv) 10400 and then 10401 Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication 10402 then 10403 Build_Underlying_Full_View 10404 (Parent (Priv), Full, Etype (Full_Base)); 10405 10406 elsif Nkind (Related_Nod) = N_Component_Declaration then 10407 Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base)); 10408 end if; 10409 10410 elsif Is_Record_Type (Full_Base) then 10411 10412 -- Show Full is simply a renaming of Full_Base 10413 10414 Set_Cloned_Subtype (Full, Full_Base); 10415 end if; 10416 10417 -- It is unsafe to share the bounds of a scalar type, because the Itype 10418 -- is elaborated on demand, and if a bound is non-static then different 10419 -- orders of elaboration in different units will lead to different 10420 -- external symbols. 10421 10422 if Is_Scalar_Type (Full_Base) then 10423 Set_Scalar_Range (Full, 10424 Make_Range (Sloc (Related_Nod), 10425 Low_Bound => 10426 Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)), 10427 High_Bound => 10428 Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base)))); 10429 10430 -- This completion inherits the bounds of the full parent, but if 10431 -- the parent is an unconstrained floating point type, so is the 10432 -- completion. 10433 10434 if Is_Floating_Point_Type (Full_Base) then 10435 Set_Includes_Infinities 10436 (Scalar_Range (Full), Has_Infinities (Full_Base)); 10437 end if; 10438 end if; 10439 10440 -- ??? It seems that a lot of fields are missing that should be copied 10441 -- from Full_Base to Full. Here are some that are introduced in a 10442 -- non-disruptive way but a cleanup is necessary. 10443 10444 if Is_Tagged_Type (Full_Base) then 10445 Set_Is_Tagged_Type (Full); 10446 Set_Direct_Primitive_Operations (Full, 10447 Direct_Primitive_Operations (Full_Base)); 10448 10449 -- Inherit class_wide type of full_base in case the partial view was 10450 -- not tagged. Otherwise it has already been created when the private 10451 -- subtype was analyzed. 10452 10453 if No (Class_Wide_Type (Full)) then 10454 Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); 10455 end if; 10456 10457 -- If this is a subtype of a protected or task type, constrain its 10458 -- corresponding record, unless this is a subtype without constraints, 10459 -- i.e. a simple renaming as with an actual subtype in an instance. 10460 10461 elsif Is_Concurrent_Type (Full_Base) then 10462 if Has_Discriminants (Full) 10463 and then Present (Corresponding_Record_Type (Full_Base)) 10464 and then 10465 not Is_Empty_Elmt_List (Discriminant_Constraint (Full)) 10466 then 10467 Set_Corresponding_Record_Type (Full, 10468 Constrain_Corresponding_Record 10469 (Full, Corresponding_Record_Type (Full_Base), 10470 Related_Nod, Full_Base)); 10471 10472 else 10473 Set_Corresponding_Record_Type (Full, 10474 Corresponding_Record_Type (Full_Base)); 10475 end if; 10476 end if; 10477 10478 -- Link rep item chain, and also setting of Has_Predicates from private 10479 -- subtype to full subtype, since we will need these on the full subtype 10480 -- to create the predicate function. Note that the full subtype may 10481 -- already have rep items, inherited from the full view of the base 10482 -- type, so we must be sure not to overwrite these entries. 10483 10484 declare 10485 Append : Boolean; 10486 Item : Node_Id; 10487 Next_Item : Node_Id; 10488 10489 begin 10490 Item := First_Rep_Item (Full); 10491 10492 -- If no existing rep items on full type, we can just link directly 10493 -- to the list of items on the private type. 10494 10495 if No (Item) then 10496 Set_First_Rep_Item (Full, First_Rep_Item (Priv)); 10497 10498 -- Otherwise, search to the end of items currently linked to the full 10499 -- subtype and append the private items to the end. However, if Priv 10500 -- and Full already have the same list of rep items, then the append 10501 -- is not done, as that would create a circularity. 10502 10503 elsif Item /= First_Rep_Item (Priv) then 10504 Append := True; 10505 10506 loop 10507 Next_Item := Next_Rep_Item (Item); 10508 exit when No (Next_Item); 10509 Item := Next_Item; 10510 10511 -- If the private view has aspect specifications, the full view 10512 -- inherits them. Since these aspects may already have been 10513 -- attached to the full view during derivation, do not append 10514 -- them if already present. 10515 10516 if Item = First_Rep_Item (Priv) then 10517 Append := False; 10518 exit; 10519 end if; 10520 end loop; 10521 10522 -- And link the private type items at the end of the chain 10523 10524 if Append then 10525 Set_Next_Rep_Item (Item, First_Rep_Item (Priv)); 10526 end if; 10527 end if; 10528 end; 10529 10530 -- Make sure Has_Predicates is set on full type if it is set on the 10531 -- private type. Note that it may already be set on the full type and 10532 -- if so, we don't want to unset it. 10533 10534 if Has_Predicates (Priv) then 10535 Set_Has_Predicates (Full); 10536 end if; 10537 end Complete_Private_Subtype; 10538 10539 ---------------------------- 10540 -- Constant_Redeclaration -- 10541 ---------------------------- 10542 10543 procedure Constant_Redeclaration 10544 (Id : Entity_Id; 10545 N : Node_Id; 10546 T : out Entity_Id) 10547 is 10548 Prev : constant Entity_Id := Current_Entity_In_Scope (Id); 10549 Obj_Def : constant Node_Id := Object_Definition (N); 10550 New_T : Entity_Id; 10551 10552 procedure Check_Possible_Deferred_Completion 10553 (Prev_Id : Entity_Id; 10554 Prev_Obj_Def : Node_Id; 10555 Curr_Obj_Def : Node_Id); 10556 -- Determine whether the two object definitions describe the partial 10557 -- and the full view of a constrained deferred constant. Generate 10558 -- a subtype for the full view and verify that it statically matches 10559 -- the subtype of the partial view. 10560 10561 procedure Check_Recursive_Declaration (Typ : Entity_Id); 10562 -- If deferred constant is an access type initialized with an allocator, 10563 -- check whether there is an illegal recursion in the definition, 10564 -- through a default value of some record subcomponent. This is normally 10565 -- detected when generating init procs, but requires this additional 10566 -- mechanism when expansion is disabled. 10567 10568 ---------------------------------------- 10569 -- Check_Possible_Deferred_Completion -- 10570 ---------------------------------------- 10571 10572 procedure Check_Possible_Deferred_Completion 10573 (Prev_Id : Entity_Id; 10574 Prev_Obj_Def : Node_Id; 10575 Curr_Obj_Def : Node_Id) 10576 is 10577 begin 10578 if Nkind (Prev_Obj_Def) = N_Subtype_Indication 10579 and then Present (Constraint (Prev_Obj_Def)) 10580 and then Nkind (Curr_Obj_Def) = N_Subtype_Indication 10581 and then Present (Constraint (Curr_Obj_Def)) 10582 then 10583 declare 10584 Loc : constant Source_Ptr := Sloc (N); 10585 Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); 10586 Decl : constant Node_Id := 10587 Make_Subtype_Declaration (Loc, 10588 Defining_Identifier => Def_Id, 10589 Subtype_Indication => 10590 Relocate_Node (Curr_Obj_Def)); 10591 10592 begin 10593 Insert_Before_And_Analyze (N, Decl); 10594 Set_Etype (Id, Def_Id); 10595 10596 if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then 10597 Error_Msg_Sloc := Sloc (Prev_Id); 10598 Error_Msg_N ("subtype does not statically match deferred " & 10599 "declaration#", N); 10600 end if; 10601 end; 10602 end if; 10603 end Check_Possible_Deferred_Completion; 10604 10605 --------------------------------- 10606 -- Check_Recursive_Declaration -- 10607 --------------------------------- 10608 10609 procedure Check_Recursive_Declaration (Typ : Entity_Id) is 10610 Comp : Entity_Id; 10611 10612 begin 10613 if Is_Record_Type (Typ) then 10614 Comp := First_Component (Typ); 10615 while Present (Comp) loop 10616 if Comes_From_Source (Comp) then 10617 if Present (Expression (Parent (Comp))) 10618 and then Is_Entity_Name (Expression (Parent (Comp))) 10619 and then Entity (Expression (Parent (Comp))) = Prev 10620 then 10621 Error_Msg_Sloc := Sloc (Parent (Comp)); 10622 Error_Msg_NE 10623 ("illegal circularity with declaration for&#", 10624 N, Comp); 10625 return; 10626 10627 elsif Is_Record_Type (Etype (Comp)) then 10628 Check_Recursive_Declaration (Etype (Comp)); 10629 end if; 10630 end if; 10631 10632 Next_Component (Comp); 10633 end loop; 10634 end if; 10635 end Check_Recursive_Declaration; 10636 10637 -- Start of processing for Constant_Redeclaration 10638 10639 begin 10640 if Nkind (Parent (Prev)) = N_Object_Declaration then 10641 if Nkind (Object_Definition 10642 (Parent (Prev))) = N_Subtype_Indication 10643 then 10644 -- Find type of new declaration. The constraints of the two 10645 -- views must match statically, but there is no point in 10646 -- creating an itype for the full view. 10647 10648 if Nkind (Obj_Def) = N_Subtype_Indication then 10649 Find_Type (Subtype_Mark (Obj_Def)); 10650 New_T := Entity (Subtype_Mark (Obj_Def)); 10651 10652 else 10653 Find_Type (Obj_Def); 10654 New_T := Entity (Obj_Def); 10655 end if; 10656 10657 T := Etype (Prev); 10658 10659 else 10660 -- The full view may impose a constraint, even if the partial 10661 -- view does not, so construct the subtype. 10662 10663 New_T := Find_Type_Of_Object (Obj_Def, N); 10664 T := New_T; 10665 end if; 10666 10667 else 10668 -- Current declaration is illegal, diagnosed below in Enter_Name 10669 10670 T := Empty; 10671 New_T := Any_Type; 10672 end if; 10673 10674 -- If previous full declaration or a renaming declaration exists, or if 10675 -- a homograph is present, let Enter_Name handle it, either with an 10676 -- error or with the removal of an overridden implicit subprogram. 10677 10678 if Ekind (Prev) /= E_Constant 10679 or else Nkind (Parent (Prev)) = N_Object_Renaming_Declaration 10680 or else Present (Expression (Parent (Prev))) 10681 or else Present (Full_View (Prev)) 10682 then 10683 Enter_Name (Id); 10684 10685 -- Verify that types of both declarations match, or else that both types 10686 -- are anonymous access types whose designated subtypes statically match 10687 -- (as allowed in Ada 2005 by AI-385). 10688 10689 elsif Base_Type (Etype (Prev)) /= Base_Type (New_T) 10690 and then 10691 (Ekind (Etype (Prev)) /= E_Anonymous_Access_Type 10692 or else Ekind (Etype (New_T)) /= E_Anonymous_Access_Type 10693 or else Is_Access_Constant (Etype (New_T)) /= 10694 Is_Access_Constant (Etype (Prev)) 10695 or else Can_Never_Be_Null (Etype (New_T)) /= 10696 Can_Never_Be_Null (Etype (Prev)) 10697 or else Null_Exclusion_Present (Parent (Prev)) /= 10698 Null_Exclusion_Present (Parent (Id)) 10699 or else not Subtypes_Statically_Match 10700 (Designated_Type (Etype (Prev)), 10701 Designated_Type (Etype (New_T)))) 10702 then 10703 Error_Msg_Sloc := Sloc (Prev); 10704 Error_Msg_N ("type does not match declaration#", N); 10705 Set_Full_View (Prev, Id); 10706 Set_Etype (Id, Any_Type); 10707 10708 elsif 10709 Null_Exclusion_Present (Parent (Prev)) 10710 and then not Null_Exclusion_Present (N) 10711 then 10712 Error_Msg_Sloc := Sloc (Prev); 10713 Error_Msg_N ("null-exclusion does not match declaration#", N); 10714 Set_Full_View (Prev, Id); 10715 Set_Etype (Id, Any_Type); 10716 10717 -- If so, process the full constant declaration 10718 10719 else 10720 -- RM 7.4 (6): If the subtype defined by the subtype_indication in 10721 -- the deferred declaration is constrained, then the subtype defined 10722 -- by the subtype_indication in the full declaration shall match it 10723 -- statically. 10724 10725 Check_Possible_Deferred_Completion 10726 (Prev_Id => Prev, 10727 Prev_Obj_Def => Object_Definition (Parent (Prev)), 10728 Curr_Obj_Def => Obj_Def); 10729 10730 Set_Full_View (Prev, Id); 10731 Set_Is_Public (Id, Is_Public (Prev)); 10732 Set_Is_Internal (Id); 10733 Append_Entity (Id, Current_Scope); 10734 10735 -- Check ALIASED present if present before (RM 7.4(7)) 10736 10737 if Is_Aliased (Prev) 10738 and then not Aliased_Present (N) 10739 then 10740 Error_Msg_Sloc := Sloc (Prev); 10741 Error_Msg_N ("ALIASED required (see declaration#)", N); 10742 end if; 10743 10744 -- Check that placement is in private part and that the incomplete 10745 -- declaration appeared in the visible part. 10746 10747 if Ekind (Current_Scope) = E_Package 10748 and then not In_Private_Part (Current_Scope) 10749 then 10750 Error_Msg_Sloc := Sloc (Prev); 10751 Error_Msg_N 10752 ("full constant for declaration#" 10753 & " must be in private part", N); 10754 10755 elsif Ekind (Current_Scope) = E_Package 10756 and then 10757 List_Containing (Parent (Prev)) /= 10758 Visible_Declarations 10759 (Specification (Unit_Declaration_Node (Current_Scope))) 10760 then 10761 Error_Msg_N 10762 ("deferred constant must be declared in visible part", 10763 Parent (Prev)); 10764 end if; 10765 10766 if Is_Access_Type (T) 10767 and then Nkind (Expression (N)) = N_Allocator 10768 then 10769 Check_Recursive_Declaration (Designated_Type (T)); 10770 end if; 10771 10772 -- A deferred constant is a visible entity. If type has invariants, 10773 -- verify that the initial value satisfies them. 10774 10775 if Expander_Active and then Has_Invariants (T) then 10776 declare 10777 Call : constant Node_Id := 10778 Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N))); 10779 begin 10780 Insert_After (N, Call); 10781 end; 10782 end if; 10783 end if; 10784 end Constant_Redeclaration; 10785 10786 ---------------------- 10787 -- Constrain_Access -- 10788 ---------------------- 10789 10790 procedure Constrain_Access 10791 (Def_Id : in out Entity_Id; 10792 S : Node_Id; 10793 Related_Nod : Node_Id) 10794 is 10795 T : constant Entity_Id := Entity (Subtype_Mark (S)); 10796 Desig_Type : constant Entity_Id := Designated_Type (T); 10797 Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); 10798 Constraint_OK : Boolean := True; 10799 10800 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; 10801 -- Simple predicate to test for defaulted discriminants 10802 -- Shouldn't this be in sem_util??? 10803 10804 --------------------------------- 10805 -- Has_Defaulted_Discriminants -- 10806 --------------------------------- 10807 10808 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is 10809 begin 10810 return Has_Discriminants (Typ) 10811 and then Present (First_Discriminant (Typ)) 10812 and then Present 10813 (Discriminant_Default_Value (First_Discriminant (Typ))); 10814 end Has_Defaulted_Discriminants; 10815 10816 -- Start of processing for Constrain_Access 10817 10818 begin 10819 if Is_Array_Type (Desig_Type) then 10820 Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); 10821 10822 elsif (Is_Record_Type (Desig_Type) 10823 or else Is_Incomplete_Or_Private_Type (Desig_Type)) 10824 and then not Is_Constrained (Desig_Type) 10825 then 10826 -- ??? The following code is a temporary kludge to ignore a 10827 -- discriminant constraint on access type if it is constraining 10828 -- the current record. Avoid creating the implicit subtype of the 10829 -- record we are currently compiling since right now, we cannot 10830 -- handle these. For now, just return the access type itself. 10831 10832 if Desig_Type = Current_Scope 10833 and then No (Def_Id) 10834 then 10835 Set_Ekind (Desig_Subtype, E_Record_Subtype); 10836 Def_Id := Entity (Subtype_Mark (S)); 10837 10838 -- This call added to ensure that the constraint is analyzed 10839 -- (needed for a B test). Note that we still return early from 10840 -- this procedure to avoid recursive processing. ??? 10841 10842 Constrain_Discriminated_Type 10843 (Desig_Subtype, S, Related_Nod, For_Access => True); 10844 return; 10845 end if; 10846 10847 -- Enforce rule that the constraint is illegal if there is an 10848 -- unconstrained view of the designated type. This means that the 10849 -- partial view (either a private type declaration or a derivation 10850 -- from a private type) has no discriminants. (Defect Report 10851 -- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001). 10852 10853 -- Rule updated for Ada 2005: the private type is said to have 10854 -- a constrained partial view, given that objects of the type 10855 -- can be declared. Furthermore, the rule applies to all access 10856 -- types, unlike the rule concerning default discriminants (see 10857 -- RM 3.7.1(7/3)) 10858 10859 if (Ekind (T) = E_General_Access_Type 10860 or else Ada_Version >= Ada_2005) 10861 and then Has_Private_Declaration (Desig_Type) 10862 and then In_Open_Scopes (Scope (Desig_Type)) 10863 and then Has_Discriminants (Desig_Type) 10864 then 10865 declare 10866 Pack : constant Node_Id := 10867 Unit_Declaration_Node (Scope (Desig_Type)); 10868 Decls : List_Id; 10869 Decl : Node_Id; 10870 10871 begin 10872 if Nkind (Pack) = N_Package_Declaration then 10873 Decls := Visible_Declarations (Specification (Pack)); 10874 Decl := First (Decls); 10875 while Present (Decl) loop 10876 if (Nkind (Decl) = N_Private_Type_Declaration 10877 and then 10878 Chars (Defining_Identifier (Decl)) = 10879 Chars (Desig_Type)) 10880 10881 or else 10882 (Nkind (Decl) = N_Full_Type_Declaration 10883 and then 10884 Chars (Defining_Identifier (Decl)) = 10885 Chars (Desig_Type) 10886 and then Is_Derived_Type (Desig_Type) 10887 and then 10888 Has_Private_Declaration (Etype (Desig_Type))) 10889 then 10890 if No (Discriminant_Specifications (Decl)) then 10891 Error_Msg_N 10892 ("cannot constrain access type if designated " & 10893 "type has constrained partial view", S); 10894 end if; 10895 10896 exit; 10897 end if; 10898 10899 Next (Decl); 10900 end loop; 10901 end if; 10902 end; 10903 end if; 10904 10905 Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod, 10906 For_Access => True); 10907 10908 elsif (Is_Task_Type (Desig_Type) 10909 or else Is_Protected_Type (Desig_Type)) 10910 and then not Is_Constrained (Desig_Type) 10911 then 10912 Constrain_Concurrent 10913 (Desig_Subtype, S, Related_Nod, Desig_Type, ' '); 10914 10915 else 10916 Error_Msg_N ("invalid constraint on access type", S); 10917 Desig_Subtype := Desig_Type; -- Ignore invalid constraint. 10918 Constraint_OK := False; 10919 end if; 10920 10921 if No (Def_Id) then 10922 Def_Id := Create_Itype (E_Access_Subtype, Related_Nod); 10923 else 10924 Set_Ekind (Def_Id, E_Access_Subtype); 10925 end if; 10926 10927 if Constraint_OK then 10928 Set_Etype (Def_Id, Base_Type (T)); 10929 10930 if Is_Private_Type (Desig_Type) then 10931 Prepare_Private_Subtype_Completion (Desig_Subtype, Related_Nod); 10932 end if; 10933 else 10934 Set_Etype (Def_Id, Any_Type); 10935 end if; 10936 10937 Set_Size_Info (Def_Id, T); 10938 Set_Is_Constrained (Def_Id, Constraint_OK); 10939 Set_Directly_Designated_Type (Def_Id, Desig_Subtype); 10940 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 10941 Set_Is_Access_Constant (Def_Id, Is_Access_Constant (T)); 10942 10943 Conditional_Delay (Def_Id, T); 10944 10945 -- AI-363 : Subtypes of general access types whose designated types have 10946 -- default discriminants are disallowed. In instances, the rule has to 10947 -- be checked against the actual, of which T is the subtype. In a 10948 -- generic body, the rule is checked assuming that the actual type has 10949 -- defaulted discriminants. 10950 10951 if Ada_Version >= Ada_2005 or else Warn_On_Ada_2005_Compatibility then 10952 if Ekind (Base_Type (T)) = E_General_Access_Type 10953 and then Has_Defaulted_Discriminants (Desig_Type) 10954 then 10955 if Ada_Version < Ada_2005 then 10956 Error_Msg_N 10957 ("access subtype of general access type would not " & 10958 "be allowed in Ada 2005?y?", S); 10959 else 10960 Error_Msg_N 10961 ("access subtype of general access type not allowed", S); 10962 end if; 10963 10964 Error_Msg_N ("\discriminants have defaults", S); 10965 10966 elsif Is_Access_Type (T) 10967 and then Is_Generic_Type (Desig_Type) 10968 and then Has_Discriminants (Desig_Type) 10969 and then In_Package_Body (Current_Scope) 10970 then 10971 if Ada_Version < Ada_2005 then 10972 Error_Msg_N 10973 ("access subtype would not be allowed in generic body " & 10974 "in Ada 2005?y?", S); 10975 else 10976 Error_Msg_N 10977 ("access subtype not allowed in generic body", S); 10978 end if; 10979 10980 Error_Msg_N 10981 ("\designated type is a discriminated formal", S); 10982 end if; 10983 end if; 10984 end Constrain_Access; 10985 10986 --------------------- 10987 -- Constrain_Array -- 10988 --------------------- 10989 10990 procedure Constrain_Array 10991 (Def_Id : in out Entity_Id; 10992 SI : Node_Id; 10993 Related_Nod : Node_Id; 10994 Related_Id : Entity_Id; 10995 Suffix : Character) 10996 is 10997 C : constant Node_Id := Constraint (SI); 10998 Number_Of_Constraints : Nat := 0; 10999 Index : Node_Id; 11000 S, T : Entity_Id; 11001 Constraint_OK : Boolean := True; 11002 11003 begin 11004 T := Entity (Subtype_Mark (SI)); 11005 11006 if Ekind (T) in Access_Kind then 11007 T := Designated_Type (T); 11008 end if; 11009 11010 -- If an index constraint follows a subtype mark in a subtype indication 11011 -- then the type or subtype denoted by the subtype mark must not already 11012 -- impose an index constraint. The subtype mark must denote either an 11013 -- unconstrained array type or an access type whose designated type 11014 -- is such an array type... (RM 3.6.1) 11015 11016 if Is_Constrained (T) then 11017 Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); 11018 Constraint_OK := False; 11019 11020 else 11021 S := First (Constraints (C)); 11022 while Present (S) loop 11023 Number_Of_Constraints := Number_Of_Constraints + 1; 11024 Next (S); 11025 end loop; 11026 11027 -- In either case, the index constraint must provide a discrete 11028 -- range for each index of the array type and the type of each 11029 -- discrete range must be the same as that of the corresponding 11030 -- index. (RM 3.6.1) 11031 11032 if Number_Of_Constraints /= Number_Dimensions (T) then 11033 Error_Msg_NE ("incorrect number of index constraints for }", C, T); 11034 Constraint_OK := False; 11035 11036 else 11037 S := First (Constraints (C)); 11038 Index := First_Index (T); 11039 Analyze (Index); 11040 11041 -- Apply constraints to each index type 11042 11043 for J in 1 .. Number_Of_Constraints loop 11044 Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J); 11045 Next (Index); 11046 Next (S); 11047 end loop; 11048 11049 end if; 11050 end if; 11051 11052 if No (Def_Id) then 11053 Def_Id := 11054 Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix); 11055 Set_Parent (Def_Id, Related_Nod); 11056 11057 else 11058 Set_Ekind (Def_Id, E_Array_Subtype); 11059 end if; 11060 11061 Set_Size_Info (Def_Id, (T)); 11062 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 11063 Set_Etype (Def_Id, Base_Type (T)); 11064 11065 if Constraint_OK then 11066 Set_First_Index (Def_Id, First (Constraints (C))); 11067 else 11068 Set_First_Index (Def_Id, First_Index (T)); 11069 end if; 11070 11071 Set_Is_Constrained (Def_Id, True); 11072 Set_Is_Aliased (Def_Id, Is_Aliased (T)); 11073 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 11074 11075 Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T)); 11076 Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T)); 11077 11078 -- A subtype does not inherit the packed_array_type of is parent. We 11079 -- need to initialize the attribute because if Def_Id is previously 11080 -- analyzed through a limited_with clause, it will have the attributes 11081 -- of an incomplete type, one of which is an Elist that overlaps the 11082 -- Packed_Array_Type field. 11083 11084 Set_Packed_Array_Type (Def_Id, Empty); 11085 11086 -- Build a freeze node if parent still needs one. Also make sure that 11087 -- the Depends_On_Private status is set because the subtype will need 11088 -- reprocessing at the time the base type does, and also we must set a 11089 -- conditional delay. 11090 11091 Set_Depends_On_Private (Def_Id, Depends_On_Private (T)); 11092 Conditional_Delay (Def_Id, T); 11093 end Constrain_Array; 11094 11095 ------------------------------ 11096 -- Constrain_Component_Type -- 11097 ------------------------------ 11098 11099 function Constrain_Component_Type 11100 (Comp : Entity_Id; 11101 Constrained_Typ : Entity_Id; 11102 Related_Node : Node_Id; 11103 Typ : Entity_Id; 11104 Constraints : Elist_Id) return Entity_Id 11105 is 11106 Loc : constant Source_Ptr := Sloc (Constrained_Typ); 11107 Compon_Type : constant Entity_Id := Etype (Comp); 11108 11109 function Build_Constrained_Array_Type 11110 (Old_Type : Entity_Id) return Entity_Id; 11111 -- If Old_Type is an array type, one of whose indexes is constrained 11112 -- by a discriminant, build an Itype whose constraint replaces the 11113 -- discriminant with its value in the constraint. 11114 11115 function Build_Constrained_Discriminated_Type 11116 (Old_Type : Entity_Id) return Entity_Id; 11117 -- Ditto for record components 11118 11119 function Build_Constrained_Access_Type 11120 (Old_Type : Entity_Id) return Entity_Id; 11121 -- Ditto for access types. Makes use of previous two functions, to 11122 -- constrain designated type. 11123 11124 function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id; 11125 -- T is an array or discriminated type, C is a list of constraints 11126 -- that apply to T. This routine builds the constrained subtype. 11127 11128 function Is_Discriminant (Expr : Node_Id) return Boolean; 11129 -- Returns True if Expr is a discriminant 11130 11131 function Get_Discr_Value (Discrim : Entity_Id) return Node_Id; 11132 -- Find the value of discriminant Discrim in Constraint 11133 11134 ----------------------------------- 11135 -- Build_Constrained_Access_Type -- 11136 ----------------------------------- 11137 11138 function Build_Constrained_Access_Type 11139 (Old_Type : Entity_Id) return Entity_Id 11140 is 11141 Desig_Type : constant Entity_Id := Designated_Type (Old_Type); 11142 Itype : Entity_Id; 11143 Desig_Subtype : Entity_Id; 11144 Scop : Entity_Id; 11145 11146 begin 11147 -- if the original access type was not embedded in the enclosing 11148 -- type definition, there is no need to produce a new access 11149 -- subtype. In fact every access type with an explicit constraint 11150 -- generates an itype whose scope is the enclosing record. 11151 11152 if not Is_Type (Scope (Old_Type)) then 11153 return Old_Type; 11154 11155 elsif Is_Array_Type (Desig_Type) then 11156 Desig_Subtype := Build_Constrained_Array_Type (Desig_Type); 11157 11158 elsif Has_Discriminants (Desig_Type) then 11159 11160 -- This may be an access type to an enclosing record type for 11161 -- which we are constructing the constrained components. Return 11162 -- the enclosing record subtype. This is not always correct, 11163 -- but avoids infinite recursion. ??? 11164 11165 Desig_Subtype := Any_Type; 11166 11167 for J in reverse 0 .. Scope_Stack.Last loop 11168 Scop := Scope_Stack.Table (J).Entity; 11169 11170 if Is_Type (Scop) 11171 and then Base_Type (Scop) = Base_Type (Desig_Type) 11172 then 11173 Desig_Subtype := Scop; 11174 end if; 11175 11176 exit when not Is_Type (Scop); 11177 end loop; 11178 11179 if Desig_Subtype = Any_Type then 11180 Desig_Subtype := 11181 Build_Constrained_Discriminated_Type (Desig_Type); 11182 end if; 11183 11184 else 11185 return Old_Type; 11186 end if; 11187 11188 if Desig_Subtype /= Desig_Type then 11189 11190 -- The Related_Node better be here or else we won't be able 11191 -- to attach new itypes to a node in the tree. 11192 11193 pragma Assert (Present (Related_Node)); 11194 11195 Itype := Create_Itype (E_Access_Subtype, Related_Node); 11196 11197 Set_Etype (Itype, Base_Type (Old_Type)); 11198 Set_Size_Info (Itype, (Old_Type)); 11199 Set_Directly_Designated_Type (Itype, Desig_Subtype); 11200 Set_Depends_On_Private (Itype, Has_Private_Component 11201 (Old_Type)); 11202 Set_Is_Access_Constant (Itype, Is_Access_Constant 11203 (Old_Type)); 11204 11205 -- The new itype needs freezing when it depends on a not frozen 11206 -- type and the enclosing subtype needs freezing. 11207 11208 if Has_Delayed_Freeze (Constrained_Typ) 11209 and then not Is_Frozen (Constrained_Typ) 11210 then 11211 Conditional_Delay (Itype, Base_Type (Old_Type)); 11212 end if; 11213 11214 return Itype; 11215 11216 else 11217 return Old_Type; 11218 end if; 11219 end Build_Constrained_Access_Type; 11220 11221 ---------------------------------- 11222 -- Build_Constrained_Array_Type -- 11223 ---------------------------------- 11224 11225 function Build_Constrained_Array_Type 11226 (Old_Type : Entity_Id) return Entity_Id 11227 is 11228 Lo_Expr : Node_Id; 11229 Hi_Expr : Node_Id; 11230 Old_Index : Node_Id; 11231 Range_Node : Node_Id; 11232 Constr_List : List_Id; 11233 11234 Need_To_Create_Itype : Boolean := False; 11235 11236 begin 11237 Old_Index := First_Index (Old_Type); 11238 while Present (Old_Index) loop 11239 Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); 11240 11241 if Is_Discriminant (Lo_Expr) 11242 or else Is_Discriminant (Hi_Expr) 11243 then 11244 Need_To_Create_Itype := True; 11245 end if; 11246 11247 Next_Index (Old_Index); 11248 end loop; 11249 11250 if Need_To_Create_Itype then 11251 Constr_List := New_List; 11252 11253 Old_Index := First_Index (Old_Type); 11254 while Present (Old_Index) loop 11255 Get_Index_Bounds (Old_Index, Lo_Expr, Hi_Expr); 11256 11257 if Is_Discriminant (Lo_Expr) then 11258 Lo_Expr := Get_Discr_Value (Lo_Expr); 11259 end if; 11260 11261 if Is_Discriminant (Hi_Expr) then 11262 Hi_Expr := Get_Discr_Value (Hi_Expr); 11263 end if; 11264 11265 Range_Node := 11266 Make_Range 11267 (Loc, New_Copy_Tree (Lo_Expr), New_Copy_Tree (Hi_Expr)); 11268 11269 Append (Range_Node, To => Constr_List); 11270 11271 Next_Index (Old_Index); 11272 end loop; 11273 11274 return Build_Subtype (Old_Type, Constr_List); 11275 11276 else 11277 return Old_Type; 11278 end if; 11279 end Build_Constrained_Array_Type; 11280 11281 ------------------------------------------ 11282 -- Build_Constrained_Discriminated_Type -- 11283 ------------------------------------------ 11284 11285 function Build_Constrained_Discriminated_Type 11286 (Old_Type : Entity_Id) return Entity_Id 11287 is 11288 Expr : Node_Id; 11289 Constr_List : List_Id; 11290 Old_Constraint : Elmt_Id; 11291 11292 Need_To_Create_Itype : Boolean := False; 11293 11294 begin 11295 Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); 11296 while Present (Old_Constraint) loop 11297 Expr := Node (Old_Constraint); 11298 11299 if Is_Discriminant (Expr) then 11300 Need_To_Create_Itype := True; 11301 end if; 11302 11303 Next_Elmt (Old_Constraint); 11304 end loop; 11305 11306 if Need_To_Create_Itype then 11307 Constr_List := New_List; 11308 11309 Old_Constraint := First_Elmt (Discriminant_Constraint (Old_Type)); 11310 while Present (Old_Constraint) loop 11311 Expr := Node (Old_Constraint); 11312 11313 if Is_Discriminant (Expr) then 11314 Expr := Get_Discr_Value (Expr); 11315 end if; 11316 11317 Append (New_Copy_Tree (Expr), To => Constr_List); 11318 11319 Next_Elmt (Old_Constraint); 11320 end loop; 11321 11322 return Build_Subtype (Old_Type, Constr_List); 11323 11324 else 11325 return Old_Type; 11326 end if; 11327 end Build_Constrained_Discriminated_Type; 11328 11329 ------------------- 11330 -- Build_Subtype -- 11331 ------------------- 11332 11333 function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is 11334 Indic : Node_Id; 11335 Subtyp_Decl : Node_Id; 11336 Def_Id : Entity_Id; 11337 Btyp : Entity_Id := Base_Type (T); 11338 11339 begin 11340 -- The Related_Node better be here or else we won't be able to 11341 -- attach new itypes to a node in the tree. 11342 11343 pragma Assert (Present (Related_Node)); 11344 11345 -- If the view of the component's type is incomplete or private 11346 -- with unknown discriminants, then the constraint must be applied 11347 -- to the full type. 11348 11349 if Has_Unknown_Discriminants (Btyp) 11350 and then Present (Underlying_Type (Btyp)) 11351 then 11352 Btyp := Underlying_Type (Btyp); 11353 end if; 11354 11355 Indic := 11356 Make_Subtype_Indication (Loc, 11357 Subtype_Mark => New_Occurrence_Of (Btyp, Loc), 11358 Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C)); 11359 11360 Def_Id := Create_Itype (Ekind (T), Related_Node); 11361 11362 Subtyp_Decl := 11363 Make_Subtype_Declaration (Loc, 11364 Defining_Identifier => Def_Id, 11365 Subtype_Indication => Indic); 11366 11367 Set_Parent (Subtyp_Decl, Parent (Related_Node)); 11368 11369 -- Itypes must be analyzed with checks off (see package Itypes) 11370 11371 Analyze (Subtyp_Decl, Suppress => All_Checks); 11372 11373 return Def_Id; 11374 end Build_Subtype; 11375 11376 --------------------- 11377 -- Get_Discr_Value -- 11378 --------------------- 11379 11380 function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is 11381 D : Entity_Id; 11382 E : Elmt_Id; 11383 11384 begin 11385 -- The discriminant may be declared for the type, in which case we 11386 -- find it by iterating over the list of discriminants. If the 11387 -- discriminant is inherited from a parent type, it appears as the 11388 -- corresponding discriminant of the current type. This will be the 11389 -- case when constraining an inherited component whose constraint is 11390 -- given by a discriminant of the parent. 11391 11392 D := First_Discriminant (Typ); 11393 E := First_Elmt (Constraints); 11394 11395 while Present (D) loop 11396 if D = Entity (Discrim) 11397 or else D = CR_Discriminant (Entity (Discrim)) 11398 or else Corresponding_Discriminant (D) = Entity (Discrim) 11399 then 11400 return Node (E); 11401 end if; 11402 11403 Next_Discriminant (D); 11404 Next_Elmt (E); 11405 end loop; 11406 11407 -- The Corresponding_Discriminant mechanism is incomplete, because 11408 -- the correspondence between new and old discriminants is not one 11409 -- to one: one new discriminant can constrain several old ones. In 11410 -- that case, scan sequentially the stored_constraint, the list of 11411 -- discriminants of the parents, and the constraints. 11412 11413 -- Previous code checked for the present of the Stored_Constraint 11414 -- list for the derived type, but did not use it at all. Should it 11415 -- be present when the component is a discriminated task type? 11416 11417 if Is_Derived_Type (Typ) 11418 and then Scope (Entity (Discrim)) = Etype (Typ) 11419 then 11420 D := First_Discriminant (Etype (Typ)); 11421 E := First_Elmt (Constraints); 11422 while Present (D) loop 11423 if D = Entity (Discrim) then 11424 return Node (E); 11425 end if; 11426 11427 Next_Discriminant (D); 11428 Next_Elmt (E); 11429 end loop; 11430 end if; 11431 11432 -- Something is wrong if we did not find the value 11433 11434 raise Program_Error; 11435 end Get_Discr_Value; 11436 11437 --------------------- 11438 -- Is_Discriminant -- 11439 --------------------- 11440 11441 function Is_Discriminant (Expr : Node_Id) return Boolean is 11442 Discrim_Scope : Entity_Id; 11443 11444 begin 11445 if Denotes_Discriminant (Expr) then 11446 Discrim_Scope := Scope (Entity (Expr)); 11447 11448 -- Either we have a reference to one of Typ's discriminants, 11449 11450 pragma Assert (Discrim_Scope = Typ 11451 11452 -- or to the discriminants of the parent type, in the case 11453 -- of a derivation of a tagged type with variants. 11454 11455 or else Discrim_Scope = Etype (Typ) 11456 or else Full_View (Discrim_Scope) = Etype (Typ) 11457 11458 -- or same as above for the case where the discriminants 11459 -- were declared in Typ's private view. 11460 11461 or else (Is_Private_Type (Discrim_Scope) 11462 and then Chars (Discrim_Scope) = Chars (Typ)) 11463 11464 -- or else we are deriving from the full view and the 11465 -- discriminant is declared in the private entity. 11466 11467 or else (Is_Private_Type (Typ) 11468 and then Chars (Discrim_Scope) = Chars (Typ)) 11469 11470 -- Or we are constrained the corresponding record of a 11471 -- synchronized type that completes a private declaration. 11472 11473 or else (Is_Concurrent_Record_Type (Typ) 11474 and then 11475 Corresponding_Concurrent_Type (Typ) = Discrim_Scope) 11476 11477 -- or we have a class-wide type, in which case make sure the 11478 -- discriminant found belongs to the root type. 11479 11480 or else (Is_Class_Wide_Type (Typ) 11481 and then Etype (Typ) = Discrim_Scope)); 11482 11483 return True; 11484 end if; 11485 11486 -- In all other cases we have something wrong 11487 11488 return False; 11489 end Is_Discriminant; 11490 11491 -- Start of processing for Constrain_Component_Type 11492 11493 begin 11494 if Nkind (Parent (Comp)) = N_Component_Declaration 11495 and then Comes_From_Source (Parent (Comp)) 11496 and then Comes_From_Source 11497 (Subtype_Indication (Component_Definition (Parent (Comp)))) 11498 and then 11499 Is_Entity_Name 11500 (Subtype_Indication (Component_Definition (Parent (Comp)))) 11501 then 11502 return Compon_Type; 11503 11504 elsif Is_Array_Type (Compon_Type) then 11505 return Build_Constrained_Array_Type (Compon_Type); 11506 11507 elsif Has_Discriminants (Compon_Type) then 11508 return Build_Constrained_Discriminated_Type (Compon_Type); 11509 11510 elsif Is_Access_Type (Compon_Type) then 11511 return Build_Constrained_Access_Type (Compon_Type); 11512 11513 else 11514 return Compon_Type; 11515 end if; 11516 end Constrain_Component_Type; 11517 11518 -------------------------- 11519 -- Constrain_Concurrent -- 11520 -------------------------- 11521 11522 -- For concurrent types, the associated record value type carries the same 11523 -- discriminants, so when we constrain a concurrent type, we must constrain 11524 -- the corresponding record type as well. 11525 11526 procedure Constrain_Concurrent 11527 (Def_Id : in out Entity_Id; 11528 SI : Node_Id; 11529 Related_Nod : Node_Id; 11530 Related_Id : Entity_Id; 11531 Suffix : Character) 11532 is 11533 -- Retrieve Base_Type to ensure getting to the concurrent type in the 11534 -- case of a private subtype (needed when only doing semantic analysis). 11535 11536 T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI))); 11537 T_Val : Entity_Id; 11538 11539 begin 11540 if Ekind (T_Ent) in Access_Kind then 11541 T_Ent := Designated_Type (T_Ent); 11542 end if; 11543 11544 T_Val := Corresponding_Record_Type (T_Ent); 11545 11546 if Present (T_Val) then 11547 11548 if No (Def_Id) then 11549 Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 11550 end if; 11551 11552 Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); 11553 11554 Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); 11555 Set_Corresponding_Record_Type (Def_Id, 11556 Constrain_Corresponding_Record 11557 (Def_Id, T_Val, Related_Nod, Related_Id)); 11558 11559 else 11560 -- If there is no associated record, expansion is disabled and this 11561 -- is a generic context. Create a subtype in any case, so that 11562 -- semantic analysis can proceed. 11563 11564 if No (Def_Id) then 11565 Def_Id := Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 11566 end if; 11567 11568 Constrain_Discriminated_Type (Def_Id, SI, Related_Nod); 11569 end if; 11570 end Constrain_Concurrent; 11571 11572 ------------------------------------ 11573 -- Constrain_Corresponding_Record -- 11574 ------------------------------------ 11575 11576 function Constrain_Corresponding_Record 11577 (Prot_Subt : Entity_Id; 11578 Corr_Rec : Entity_Id; 11579 Related_Nod : Node_Id; 11580 Related_Id : Entity_Id) return Entity_Id 11581 is 11582 T_Sub : constant Entity_Id := 11583 Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V'); 11584 11585 begin 11586 Set_Etype (T_Sub, Corr_Rec); 11587 Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt)); 11588 Set_Is_Constrained (T_Sub, True); 11589 Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); 11590 Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec)); 11591 11592 -- As elsewhere, we do not want to create a freeze node for this itype 11593 -- if it is created for a constrained component of an enclosing record 11594 -- because references to outer discriminants will appear out of scope. 11595 11596 if Ekind (Scope (Prot_Subt)) /= E_Record_Type then 11597 Conditional_Delay (T_Sub, Corr_Rec); 11598 else 11599 Set_Is_Frozen (T_Sub); 11600 end if; 11601 11602 if Has_Discriminants (Prot_Subt) then -- False only if errors. 11603 Set_Discriminant_Constraint 11604 (T_Sub, Discriminant_Constraint (Prot_Subt)); 11605 Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub); 11606 Create_Constrained_Components 11607 (T_Sub, Related_Nod, Corr_Rec, Discriminant_Constraint (T_Sub)); 11608 end if; 11609 11610 Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub)); 11611 11612 return T_Sub; 11613 end Constrain_Corresponding_Record; 11614 11615 ----------------------- 11616 -- Constrain_Decimal -- 11617 ----------------------- 11618 11619 procedure Constrain_Decimal (Def_Id : Node_Id; S : Node_Id) is 11620 T : constant Entity_Id := Entity (Subtype_Mark (S)); 11621 C : constant Node_Id := Constraint (S); 11622 Loc : constant Source_Ptr := Sloc (C); 11623 Range_Expr : Node_Id; 11624 Digits_Expr : Node_Id; 11625 Digits_Val : Uint; 11626 Bound_Val : Ureal; 11627 11628 begin 11629 Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype); 11630 11631 if Nkind (C) = N_Range_Constraint then 11632 Range_Expr := Range_Expression (C); 11633 Digits_Val := Digits_Value (T); 11634 11635 else 11636 pragma Assert (Nkind (C) = N_Digits_Constraint); 11637 11638 Check_SPARK_Restriction ("digits constraint is not allowed", S); 11639 11640 Digits_Expr := Digits_Expression (C); 11641 Analyze_And_Resolve (Digits_Expr, Any_Integer); 11642 11643 Check_Digits_Expression (Digits_Expr); 11644 Digits_Val := Expr_Value (Digits_Expr); 11645 11646 if Digits_Val > Digits_Value (T) then 11647 Error_Msg_N 11648 ("digits expression is incompatible with subtype", C); 11649 Digits_Val := Digits_Value (T); 11650 end if; 11651 11652 if Present (Range_Constraint (C)) then 11653 Range_Expr := Range_Expression (Range_Constraint (C)); 11654 else 11655 Range_Expr := Empty; 11656 end if; 11657 end if; 11658 11659 Set_Etype (Def_Id, Base_Type (T)); 11660 Set_Size_Info (Def_Id, (T)); 11661 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 11662 Set_Delta_Value (Def_Id, Delta_Value (T)); 11663 Set_Scale_Value (Def_Id, Scale_Value (T)); 11664 Set_Small_Value (Def_Id, Small_Value (T)); 11665 Set_Machine_Radix_10 (Def_Id, Machine_Radix_10 (T)); 11666 Set_Digits_Value (Def_Id, Digits_Val); 11667 11668 -- Manufacture range from given digits value if no range present 11669 11670 if No (Range_Expr) then 11671 Bound_Val := (Ureal_10 ** Digits_Val - Ureal_1) * Small_Value (T); 11672 Range_Expr := 11673 Make_Range (Loc, 11674 Low_Bound => 11675 Convert_To (T, Make_Real_Literal (Loc, (-Bound_Val))), 11676 High_Bound => 11677 Convert_To (T, Make_Real_Literal (Loc, Bound_Val))); 11678 end if; 11679 11680 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expr, T); 11681 Set_Discrete_RM_Size (Def_Id); 11682 11683 -- Unconditionally delay the freeze, since we cannot set size 11684 -- information in all cases correctly until the freeze point. 11685 11686 Set_Has_Delayed_Freeze (Def_Id); 11687 end Constrain_Decimal; 11688 11689 ---------------------------------- 11690 -- Constrain_Discriminated_Type -- 11691 ---------------------------------- 11692 11693 procedure Constrain_Discriminated_Type 11694 (Def_Id : Entity_Id; 11695 S : Node_Id; 11696 Related_Nod : Node_Id; 11697 For_Access : Boolean := False) 11698 is 11699 E : constant Entity_Id := Entity (Subtype_Mark (S)); 11700 T : Entity_Id; 11701 C : Node_Id; 11702 Elist : Elist_Id := New_Elmt_List; 11703 11704 procedure Fixup_Bad_Constraint; 11705 -- This is called after finding a bad constraint, and after having 11706 -- posted an appropriate error message. The mission is to leave the 11707 -- entity T in as reasonable state as possible! 11708 11709 -------------------------- 11710 -- Fixup_Bad_Constraint -- 11711 -------------------------- 11712 11713 procedure Fixup_Bad_Constraint is 11714 begin 11715 -- Set a reasonable Ekind for the entity. For an incomplete type, 11716 -- we can't do much, but for other types, we can set the proper 11717 -- corresponding subtype kind. 11718 11719 if Ekind (T) = E_Incomplete_Type then 11720 Set_Ekind (Def_Id, Ekind (T)); 11721 else 11722 Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); 11723 end if; 11724 11725 -- Set Etype to the known type, to reduce chances of cascaded errors 11726 11727 Set_Etype (Def_Id, E); 11728 Set_Error_Posted (Def_Id); 11729 end Fixup_Bad_Constraint; 11730 11731 -- Start of processing for Constrain_Discriminated_Type 11732 11733 begin 11734 C := Constraint (S); 11735 11736 -- A discriminant constraint is only allowed in a subtype indication, 11737 -- after a subtype mark. This subtype mark must denote either a type 11738 -- with discriminants, or an access type whose designated type is a 11739 -- type with discriminants. A discriminant constraint specifies the 11740 -- values of these discriminants (RM 3.7.2(5)). 11741 11742 T := Base_Type (Entity (Subtype_Mark (S))); 11743 11744 if Ekind (T) in Access_Kind then 11745 T := Designated_Type (T); 11746 end if; 11747 11748 -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. 11749 -- Avoid generating an error for access-to-incomplete subtypes. 11750 11751 if Ada_Version >= Ada_2005 11752 and then Ekind (T) = E_Incomplete_Type 11753 and then Nkind (Parent (S)) = N_Subtype_Declaration 11754 and then not Is_Itype (Def_Id) 11755 then 11756 -- A little sanity check, emit an error message if the type 11757 -- has discriminants to begin with. Type T may be a regular 11758 -- incomplete type or imported via a limited with clause. 11759 11760 if Has_Discriminants (T) 11761 or else 11762 (From_With_Type (T) 11763 and then Present (Non_Limited_View (T)) 11764 and then Nkind (Parent (Non_Limited_View (T))) = 11765 N_Full_Type_Declaration 11766 and then Present (Discriminant_Specifications 11767 (Parent (Non_Limited_View (T))))) 11768 then 11769 Error_Msg_N 11770 ("(Ada 2005) incomplete subtype may not be constrained", C); 11771 else 11772 Error_Msg_N ("invalid constraint: type has no discriminant", C); 11773 end if; 11774 11775 Fixup_Bad_Constraint; 11776 return; 11777 11778 -- Check that the type has visible discriminants. The type may be 11779 -- a private type with unknown discriminants whose full view has 11780 -- discriminants which are invisible. 11781 11782 elsif not Has_Discriminants (T) 11783 or else 11784 (Has_Unknown_Discriminants (T) 11785 and then Is_Private_Type (T)) 11786 then 11787 Error_Msg_N ("invalid constraint: type has no discriminant", C); 11788 Fixup_Bad_Constraint; 11789 return; 11790 11791 elsif Is_Constrained (E) 11792 or else (Ekind (E) = E_Class_Wide_Subtype 11793 and then Present (Discriminant_Constraint (E))) 11794 then 11795 Error_Msg_N ("type is already constrained", Subtype_Mark (S)); 11796 Fixup_Bad_Constraint; 11797 return; 11798 end if; 11799 11800 -- T may be an unconstrained subtype (e.g. a generic actual). 11801 -- Constraint applies to the base type. 11802 11803 T := Base_Type (T); 11804 11805 Elist := Build_Discriminant_Constraints (T, S); 11806 11807 -- If the list returned was empty we had an error in building the 11808 -- discriminant constraint. We have also already signalled an error 11809 -- in the incomplete type case 11810 11811 if Is_Empty_Elmt_List (Elist) then 11812 Fixup_Bad_Constraint; 11813 return; 11814 end if; 11815 11816 Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access); 11817 end Constrain_Discriminated_Type; 11818 11819 --------------------------- 11820 -- Constrain_Enumeration -- 11821 --------------------------- 11822 11823 procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is 11824 T : constant Entity_Id := Entity (Subtype_Mark (S)); 11825 C : constant Node_Id := Constraint (S); 11826 11827 begin 11828 Set_Ekind (Def_Id, E_Enumeration_Subtype); 11829 11830 Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); 11831 11832 Set_Etype (Def_Id, Base_Type (T)); 11833 Set_Size_Info (Def_Id, (T)); 11834 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 11835 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 11836 11837 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 11838 11839 Set_Discrete_RM_Size (Def_Id); 11840 end Constrain_Enumeration; 11841 11842 ---------------------- 11843 -- Constrain_Float -- 11844 ---------------------- 11845 11846 procedure Constrain_Float (Def_Id : Node_Id; S : Node_Id) is 11847 T : constant Entity_Id := Entity (Subtype_Mark (S)); 11848 C : Node_Id; 11849 D : Node_Id; 11850 Rais : Node_Id; 11851 11852 begin 11853 Set_Ekind (Def_Id, E_Floating_Point_Subtype); 11854 11855 Set_Etype (Def_Id, Base_Type (T)); 11856 Set_Size_Info (Def_Id, (T)); 11857 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 11858 11859 -- Process the constraint 11860 11861 C := Constraint (S); 11862 11863 -- Digits constraint present 11864 11865 if Nkind (C) = N_Digits_Constraint then 11866 11867 Check_SPARK_Restriction ("digits constraint is not allowed", S); 11868 Check_Restriction (No_Obsolescent_Features, C); 11869 11870 if Warn_On_Obsolescent_Feature then 11871 Error_Msg_N 11872 ("subtype digits constraint is an " & 11873 "obsolescent feature (RM J.3(8))?j?", C); 11874 end if; 11875 11876 D := Digits_Expression (C); 11877 Analyze_And_Resolve (D, Any_Integer); 11878 Check_Digits_Expression (D); 11879 Set_Digits_Value (Def_Id, Expr_Value (D)); 11880 11881 -- Check that digits value is in range. Obviously we can do this 11882 -- at compile time, but it is strictly a runtime check, and of 11883 -- course there is an ACVC test that checks this! 11884 11885 if Digits_Value (Def_Id) > Digits_Value (T) then 11886 Error_Msg_Uint_1 := Digits_Value (T); 11887 Error_Msg_N ("??digits value is too large, maximum is ^", D); 11888 Rais := 11889 Make_Raise_Constraint_Error (Sloc (D), 11890 Reason => CE_Range_Check_Failed); 11891 Insert_Action (Declaration_Node (Def_Id), Rais); 11892 end if; 11893 11894 C := Range_Constraint (C); 11895 11896 -- No digits constraint present 11897 11898 else 11899 Set_Digits_Value (Def_Id, Digits_Value (T)); 11900 end if; 11901 11902 -- Range constraint present 11903 11904 if Nkind (C) = N_Range_Constraint then 11905 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 11906 11907 -- No range constraint present 11908 11909 else 11910 pragma Assert (No (C)); 11911 Set_Scalar_Range (Def_Id, Scalar_Range (T)); 11912 end if; 11913 11914 Set_Is_Constrained (Def_Id); 11915 end Constrain_Float; 11916 11917 --------------------- 11918 -- Constrain_Index -- 11919 --------------------- 11920 11921 procedure Constrain_Index 11922 (Index : Node_Id; 11923 S : Node_Id; 11924 Related_Nod : Node_Id; 11925 Related_Id : Entity_Id; 11926 Suffix : Character; 11927 Suffix_Index : Nat) 11928 is 11929 Def_Id : Entity_Id; 11930 R : Node_Id := Empty; 11931 T : constant Entity_Id := Etype (Index); 11932 11933 begin 11934 if Nkind (S) = N_Range 11935 or else 11936 (Nkind (S) = N_Attribute_Reference 11937 and then Attribute_Name (S) = Name_Range) 11938 then 11939 -- A Range attribute will be transformed into N_Range by Resolve 11940 11941 Analyze (S); 11942 Set_Etype (S, T); 11943 R := S; 11944 11945 Process_Range_Expr_In_Decl (R, T, Empty_List); 11946 11947 if not Error_Posted (S) 11948 and then 11949 (Nkind (S) /= N_Range 11950 or else not Covers (T, (Etype (Low_Bound (S)))) 11951 or else not Covers (T, (Etype (High_Bound (S))))) 11952 then 11953 if Base_Type (T) /= Any_Type 11954 and then Etype (Low_Bound (S)) /= Any_Type 11955 and then Etype (High_Bound (S)) /= Any_Type 11956 then 11957 Error_Msg_N ("range expected", S); 11958 end if; 11959 end if; 11960 11961 elsif Nkind (S) = N_Subtype_Indication then 11962 11963 -- The parser has verified that this is a discrete indication 11964 11965 Resolve_Discrete_Subtype_Indication (S, T); 11966 R := Range_Expression (Constraint (S)); 11967 11968 -- Capture values of bounds and generate temporaries for them if 11969 -- needed, since checks may cause duplication of the expressions 11970 -- which must not be reevaluated. 11971 11972 -- The forced evaluation removes side effects from expressions, 11973 -- which should occur also in Alfa mode. Otherwise, we end up with 11974 -- unexpected insertions of actions at places where this is not 11975 -- supposed to occur, e.g. on default parameters of a call. 11976 11977 if Expander_Active then 11978 Force_Evaluation (Low_Bound (R)); 11979 Force_Evaluation (High_Bound (R)); 11980 end if; 11981 11982 elsif Nkind (S) = N_Discriminant_Association then 11983 11984 -- Syntactically valid in subtype indication 11985 11986 Error_Msg_N ("invalid index constraint", S); 11987 Rewrite (S, New_Occurrence_Of (T, Sloc (S))); 11988 return; 11989 11990 -- Subtype_Mark case, no anonymous subtypes to construct 11991 11992 else 11993 Analyze (S); 11994 11995 if Is_Entity_Name (S) then 11996 if not Is_Type (Entity (S)) then 11997 Error_Msg_N ("expect subtype mark for index constraint", S); 11998 11999 elsif Base_Type (Entity (S)) /= Base_Type (T) then 12000 Wrong_Type (S, Base_Type (T)); 12001 12002 -- Check error of subtype with predicate in index constraint 12003 12004 else 12005 Bad_Predicated_Subtype_Use 12006 ("subtype& has predicate, not allowed in index constraint", 12007 S, Entity (S)); 12008 end if; 12009 12010 return; 12011 12012 else 12013 Error_Msg_N ("invalid index constraint", S); 12014 Rewrite (S, New_Occurrence_Of (T, Sloc (S))); 12015 return; 12016 end if; 12017 end if; 12018 12019 Def_Id := 12020 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix, Suffix_Index); 12021 12022 Set_Etype (Def_Id, Base_Type (T)); 12023 12024 if Is_Modular_Integer_Type (T) then 12025 Set_Ekind (Def_Id, E_Modular_Integer_Subtype); 12026 12027 elsif Is_Integer_Type (T) then 12028 Set_Ekind (Def_Id, E_Signed_Integer_Subtype); 12029 12030 else 12031 Set_Ekind (Def_Id, E_Enumeration_Subtype); 12032 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 12033 Set_First_Literal (Def_Id, First_Literal (T)); 12034 end if; 12035 12036 Set_Size_Info (Def_Id, (T)); 12037 Set_RM_Size (Def_Id, RM_Size (T)); 12038 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 12039 12040 Set_Scalar_Range (Def_Id, R); 12041 12042 Set_Etype (S, Def_Id); 12043 Set_Discrete_RM_Size (Def_Id); 12044 end Constrain_Index; 12045 12046 ----------------------- 12047 -- Constrain_Integer -- 12048 ----------------------- 12049 12050 procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is 12051 T : constant Entity_Id := Entity (Subtype_Mark (S)); 12052 C : constant Node_Id := Constraint (S); 12053 12054 begin 12055 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 12056 12057 if Is_Modular_Integer_Type (T) then 12058 Set_Ekind (Def_Id, E_Modular_Integer_Subtype); 12059 else 12060 Set_Ekind (Def_Id, E_Signed_Integer_Subtype); 12061 end if; 12062 12063 Set_Etype (Def_Id, Base_Type (T)); 12064 Set_Size_Info (Def_Id, (T)); 12065 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 12066 Set_Discrete_RM_Size (Def_Id); 12067 end Constrain_Integer; 12068 12069 ------------------------------ 12070 -- Constrain_Ordinary_Fixed -- 12071 ------------------------------ 12072 12073 procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id) is 12074 T : constant Entity_Id := Entity (Subtype_Mark (S)); 12075 C : Node_Id; 12076 D : Node_Id; 12077 Rais : Node_Id; 12078 12079 begin 12080 Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); 12081 Set_Etype (Def_Id, Base_Type (T)); 12082 Set_Size_Info (Def_Id, (T)); 12083 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 12084 Set_Small_Value (Def_Id, Small_Value (T)); 12085 12086 -- Process the constraint 12087 12088 C := Constraint (S); 12089 12090 -- Delta constraint present 12091 12092 if Nkind (C) = N_Delta_Constraint then 12093 12094 Check_SPARK_Restriction ("delta constraint is not allowed", S); 12095 Check_Restriction (No_Obsolescent_Features, C); 12096 12097 if Warn_On_Obsolescent_Feature then 12098 Error_Msg_S 12099 ("subtype delta constraint is an " & 12100 "obsolescent feature (RM J.3(7))?j?"); 12101 end if; 12102 12103 D := Delta_Expression (C); 12104 Analyze_And_Resolve (D, Any_Real); 12105 Check_Delta_Expression (D); 12106 Set_Delta_Value (Def_Id, Expr_Value_R (D)); 12107 12108 -- Check that delta value is in range. Obviously we can do this 12109 -- at compile time, but it is strictly a runtime check, and of 12110 -- course there is an ACVC test that checks this! 12111 12112 if Delta_Value (Def_Id) < Delta_Value (T) then 12113 Error_Msg_N ("??delta value is too small", D); 12114 Rais := 12115 Make_Raise_Constraint_Error (Sloc (D), 12116 Reason => CE_Range_Check_Failed); 12117 Insert_Action (Declaration_Node (Def_Id), Rais); 12118 end if; 12119 12120 C := Range_Constraint (C); 12121 12122 -- No delta constraint present 12123 12124 else 12125 Set_Delta_Value (Def_Id, Delta_Value (T)); 12126 end if; 12127 12128 -- Range constraint present 12129 12130 if Nkind (C) = N_Range_Constraint then 12131 Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); 12132 12133 -- No range constraint present 12134 12135 else 12136 pragma Assert (No (C)); 12137 Set_Scalar_Range (Def_Id, Scalar_Range (T)); 12138 12139 end if; 12140 12141 Set_Discrete_RM_Size (Def_Id); 12142 12143 -- Unconditionally delay the freeze, since we cannot set size 12144 -- information in all cases correctly until the freeze point. 12145 12146 Set_Has_Delayed_Freeze (Def_Id); 12147 end Constrain_Ordinary_Fixed; 12148 12149 ----------------------- 12150 -- Contain_Interface -- 12151 ----------------------- 12152 12153 function Contain_Interface 12154 (Iface : Entity_Id; 12155 Ifaces : Elist_Id) return Boolean 12156 is 12157 Iface_Elmt : Elmt_Id; 12158 12159 begin 12160 if Present (Ifaces) then 12161 Iface_Elmt := First_Elmt (Ifaces); 12162 while Present (Iface_Elmt) loop 12163 if Node (Iface_Elmt) = Iface then 12164 return True; 12165 end if; 12166 12167 Next_Elmt (Iface_Elmt); 12168 end loop; 12169 end if; 12170 12171 return False; 12172 end Contain_Interface; 12173 12174 --------------------------- 12175 -- Convert_Scalar_Bounds -- 12176 --------------------------- 12177 12178 procedure Convert_Scalar_Bounds 12179 (N : Node_Id; 12180 Parent_Type : Entity_Id; 12181 Derived_Type : Entity_Id; 12182 Loc : Source_Ptr) 12183 is 12184 Implicit_Base : constant Entity_Id := Base_Type (Derived_Type); 12185 12186 Lo : Node_Id; 12187 Hi : Node_Id; 12188 Rng : Node_Id; 12189 12190 begin 12191 -- Defend against previous errors 12192 12193 if No (Scalar_Range (Derived_Type)) then 12194 Check_Error_Detected; 12195 return; 12196 end if; 12197 12198 Lo := Build_Scalar_Bound 12199 (Type_Low_Bound (Derived_Type), 12200 Parent_Type, Implicit_Base); 12201 12202 Hi := Build_Scalar_Bound 12203 (Type_High_Bound (Derived_Type), 12204 Parent_Type, Implicit_Base); 12205 12206 Rng := 12207 Make_Range (Loc, 12208 Low_Bound => Lo, 12209 High_Bound => Hi); 12210 12211 Set_Includes_Infinities (Rng, Has_Infinities (Derived_Type)); 12212 12213 Set_Parent (Rng, N); 12214 Set_Scalar_Range (Derived_Type, Rng); 12215 12216 -- Analyze the bounds 12217 12218 Analyze_And_Resolve (Lo, Implicit_Base); 12219 Analyze_And_Resolve (Hi, Implicit_Base); 12220 12221 -- Analyze the range itself, except that we do not analyze it if 12222 -- the bounds are real literals, and we have a fixed-point type. 12223 -- The reason for this is that we delay setting the bounds in this 12224 -- case till we know the final Small and Size values (see circuit 12225 -- in Freeze.Freeze_Fixed_Point_Type for further details). 12226 12227 if Is_Fixed_Point_Type (Parent_Type) 12228 and then Nkind (Lo) = N_Real_Literal 12229 and then Nkind (Hi) = N_Real_Literal 12230 then 12231 return; 12232 12233 -- Here we do the analysis of the range 12234 12235 -- Note: we do this manually, since if we do a normal Analyze and 12236 -- Resolve call, there are problems with the conversions used for 12237 -- the derived type range. 12238 12239 else 12240 Set_Etype (Rng, Implicit_Base); 12241 Set_Analyzed (Rng, True); 12242 end if; 12243 end Convert_Scalar_Bounds; 12244 12245 ------------------- 12246 -- Copy_And_Swap -- 12247 ------------------- 12248 12249 procedure Copy_And_Swap (Priv, Full : Entity_Id) is 12250 begin 12251 -- Initialize new full declaration entity by copying the pertinent 12252 -- fields of the corresponding private declaration entity. 12253 12254 -- We temporarily set Ekind to a value appropriate for a type to 12255 -- avoid assert failures in Einfo from checking for setting type 12256 -- attributes on something that is not a type. Ekind (Priv) is an 12257 -- appropriate choice, since it allowed the attributes to be set 12258 -- in the first place. This Ekind value will be modified later. 12259 12260 Set_Ekind (Full, Ekind (Priv)); 12261 12262 -- Also set Etype temporarily to Any_Type, again, in the absence 12263 -- of errors, it will be properly reset, and if there are errors, 12264 -- then we want a value of Any_Type to remain. 12265 12266 Set_Etype (Full, Any_Type); 12267 12268 -- Now start copying attributes 12269 12270 Set_Has_Discriminants (Full, Has_Discriminants (Priv)); 12271 12272 if Has_Discriminants (Full) then 12273 Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv)); 12274 Set_Stored_Constraint (Full, Stored_Constraint (Priv)); 12275 end if; 12276 12277 Set_First_Rep_Item (Full, First_Rep_Item (Priv)); 12278 Set_Homonym (Full, Homonym (Priv)); 12279 Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv)); 12280 Set_Is_Public (Full, Is_Public (Priv)); 12281 Set_Is_Pure (Full, Is_Pure (Priv)); 12282 Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv)); 12283 Set_Has_Pragma_Unmodified (Full, Has_Pragma_Unmodified (Priv)); 12284 Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv)); 12285 Set_Has_Pragma_Unreferenced_Objects 12286 (Full, Has_Pragma_Unreferenced_Objects 12287 (Priv)); 12288 12289 Conditional_Delay (Full, Priv); 12290 12291 if Is_Tagged_Type (Full) then 12292 Set_Direct_Primitive_Operations (Full, 12293 Direct_Primitive_Operations (Priv)); 12294 12295 if Is_Base_Type (Priv) then 12296 Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); 12297 end if; 12298 end if; 12299 12300 Set_Is_Volatile (Full, Is_Volatile (Priv)); 12301 Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv)); 12302 Set_Scope (Full, Scope (Priv)); 12303 Set_Next_Entity (Full, Next_Entity (Priv)); 12304 Set_First_Entity (Full, First_Entity (Priv)); 12305 Set_Last_Entity (Full, Last_Entity (Priv)); 12306 12307 -- If access types have been recorded for later handling, keep them in 12308 -- the full view so that they get handled when the full view freeze 12309 -- node is expanded. 12310 12311 if Present (Freeze_Node (Priv)) 12312 and then Present (Access_Types_To_Process (Freeze_Node (Priv))) 12313 then 12314 Ensure_Freeze_Node (Full); 12315 Set_Access_Types_To_Process 12316 (Freeze_Node (Full), 12317 Access_Types_To_Process (Freeze_Node (Priv))); 12318 end if; 12319 12320 -- Swap the two entities. Now Private is the full type entity and Full 12321 -- is the private one. They will be swapped back at the end of the 12322 -- private part. This swapping ensures that the entity that is visible 12323 -- in the private part is the full declaration. 12324 12325 Exchange_Entities (Priv, Full); 12326 Append_Entity (Full, Scope (Full)); 12327 end Copy_And_Swap; 12328 12329 ------------------------------------- 12330 -- Copy_Array_Base_Type_Attributes -- 12331 ------------------------------------- 12332 12333 procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is 12334 begin 12335 Set_Component_Alignment (T1, Component_Alignment (T2)); 12336 Set_Component_Type (T1, Component_Type (T2)); 12337 Set_Component_Size (T1, Component_Size (T2)); 12338 Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); 12339 Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); 12340 Set_Has_Task (T1, Has_Task (T2)); 12341 Set_Is_Packed (T1, Is_Packed (T2)); 12342 Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); 12343 Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2)); 12344 Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2)); 12345 end Copy_Array_Base_Type_Attributes; 12346 12347 ----------------------------------- 12348 -- Copy_Array_Subtype_Attributes -- 12349 ----------------------------------- 12350 12351 procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is 12352 begin 12353 Set_Size_Info (T1, T2); 12354 12355 Set_First_Index (T1, First_Index (T2)); 12356 Set_Is_Aliased (T1, Is_Aliased (T2)); 12357 Set_Is_Volatile (T1, Is_Volatile (T2)); 12358 Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); 12359 Set_Is_Constrained (T1, Is_Constrained (T2)); 12360 Set_Depends_On_Private (T1, Has_Private_Component (T2)); 12361 Set_First_Rep_Item (T1, First_Rep_Item (T2)); 12362 Set_Convention (T1, Convention (T2)); 12363 Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2)); 12364 Set_Is_Private_Composite (T1, Is_Private_Composite (T2)); 12365 Set_Packed_Array_Type (T1, Packed_Array_Type (T2)); 12366 end Copy_Array_Subtype_Attributes; 12367 12368 ----------------------------------- 12369 -- Create_Constrained_Components -- 12370 ----------------------------------- 12371 12372 procedure Create_Constrained_Components 12373 (Subt : Entity_Id; 12374 Decl_Node : Node_Id; 12375 Typ : Entity_Id; 12376 Constraints : Elist_Id) 12377 is 12378 Loc : constant Source_Ptr := Sloc (Subt); 12379 Comp_List : constant Elist_Id := New_Elmt_List; 12380 Parent_Type : constant Entity_Id := Etype (Typ); 12381 Assoc_List : constant List_Id := New_List; 12382 Discr_Val : Elmt_Id; 12383 Errors : Boolean; 12384 New_C : Entity_Id; 12385 Old_C : Entity_Id; 12386 Is_Static : Boolean := True; 12387 12388 procedure Collect_Fixed_Components (Typ : Entity_Id); 12389 -- Collect parent type components that do not appear in a variant part 12390 12391 procedure Create_All_Components; 12392 -- Iterate over Comp_List to create the components of the subtype 12393 12394 function Create_Component (Old_Compon : Entity_Id) return Entity_Id; 12395 -- Creates a new component from Old_Compon, copying all the fields from 12396 -- it, including its Etype, inserts the new component in the Subt entity 12397 -- chain and returns the new component. 12398 12399 function Is_Variant_Record (T : Entity_Id) return Boolean; 12400 -- If true, and discriminants are static, collect only components from 12401 -- variants selected by discriminant values. 12402 12403 ------------------------------ 12404 -- Collect_Fixed_Components -- 12405 ------------------------------ 12406 12407 procedure Collect_Fixed_Components (Typ : Entity_Id) is 12408 begin 12409 -- Build association list for discriminants, and find components of the 12410 -- variant part selected by the values of the discriminants. 12411 12412 Old_C := First_Discriminant (Typ); 12413 Discr_Val := First_Elmt (Constraints); 12414 while Present (Old_C) loop 12415 Append_To (Assoc_List, 12416 Make_Component_Association (Loc, 12417 Choices => New_List (New_Occurrence_Of (Old_C, Loc)), 12418 Expression => New_Copy (Node (Discr_Val)))); 12419 12420 Next_Elmt (Discr_Val); 12421 Next_Discriminant (Old_C); 12422 end loop; 12423 12424 -- The tag and the possible parent component are unconditionally in 12425 -- the subtype. 12426 12427 if Is_Tagged_Type (Typ) 12428 or else Has_Controlled_Component (Typ) 12429 then 12430 Old_C := First_Component (Typ); 12431 while Present (Old_C) loop 12432 if Chars ((Old_C)) = Name_uTag 12433 or else Chars ((Old_C)) = Name_uParent 12434 then 12435 Append_Elmt (Old_C, Comp_List); 12436 end if; 12437 12438 Next_Component (Old_C); 12439 end loop; 12440 end if; 12441 end Collect_Fixed_Components; 12442 12443 --------------------------- 12444 -- Create_All_Components -- 12445 --------------------------- 12446 12447 procedure Create_All_Components is 12448 Comp : Elmt_Id; 12449 12450 begin 12451 Comp := First_Elmt (Comp_List); 12452 while Present (Comp) loop 12453 Old_C := Node (Comp); 12454 New_C := Create_Component (Old_C); 12455 12456 Set_Etype 12457 (New_C, 12458 Constrain_Component_Type 12459 (Old_C, Subt, Decl_Node, Typ, Constraints)); 12460 Set_Is_Public (New_C, Is_Public (Subt)); 12461 12462 Next_Elmt (Comp); 12463 end loop; 12464 end Create_All_Components; 12465 12466 ---------------------- 12467 -- Create_Component -- 12468 ---------------------- 12469 12470 function Create_Component (Old_Compon : Entity_Id) return Entity_Id is 12471 New_Compon : constant Entity_Id := New_Copy (Old_Compon); 12472 12473 begin 12474 if Ekind (Old_Compon) = E_Discriminant 12475 and then Is_Completely_Hidden (Old_Compon) 12476 then 12477 -- This is a shadow discriminant created for a discriminant of 12478 -- the parent type, which needs to be present in the subtype. 12479 -- Give the shadow discriminant an internal name that cannot 12480 -- conflict with that of visible components. 12481 12482 Set_Chars (New_Compon, New_Internal_Name ('C')); 12483 end if; 12484 12485 -- Set the parent so we have a proper link for freezing etc. This is 12486 -- not a real parent pointer, since of course our parent does not own 12487 -- up to us and reference us, we are an illegitimate child of the 12488 -- original parent! 12489 12490 Set_Parent (New_Compon, Parent (Old_Compon)); 12491 12492 -- If the old component's Esize was already determined and is a 12493 -- static value, then the new component simply inherits it. Otherwise 12494 -- the old component's size may require run-time determination, but 12495 -- the new component's size still might be statically determinable 12496 -- (if, for example it has a static constraint). In that case we want 12497 -- Layout_Type to recompute the component's size, so we reset its 12498 -- size and positional fields. 12499 12500 if Frontend_Layout_On_Target 12501 and then not Known_Static_Esize (Old_Compon) 12502 then 12503 Set_Esize (New_Compon, Uint_0); 12504 Init_Normalized_First_Bit (New_Compon); 12505 Init_Normalized_Position (New_Compon); 12506 Init_Normalized_Position_Max (New_Compon); 12507 end if; 12508 12509 -- We do not want this node marked as Comes_From_Source, since 12510 -- otherwise it would get first class status and a separate cross- 12511 -- reference line would be generated. Illegitimate children do not 12512 -- rate such recognition. 12513 12514 Set_Comes_From_Source (New_Compon, False); 12515 12516 -- But it is a real entity, and a birth certificate must be properly 12517 -- registered by entering it into the entity list. 12518 12519 Enter_Name (New_Compon); 12520 12521 return New_Compon; 12522 end Create_Component; 12523 12524 ----------------------- 12525 -- Is_Variant_Record -- 12526 ----------------------- 12527 12528 function Is_Variant_Record (T : Entity_Id) return Boolean is 12529 begin 12530 return Nkind (Parent (T)) = N_Full_Type_Declaration 12531 and then Nkind (Type_Definition (Parent (T))) = N_Record_Definition 12532 and then Present (Component_List (Type_Definition (Parent (T)))) 12533 and then 12534 Present 12535 (Variant_Part (Component_List (Type_Definition (Parent (T))))); 12536 end Is_Variant_Record; 12537 12538 -- Start of processing for Create_Constrained_Components 12539 12540 begin 12541 pragma Assert (Subt /= Base_Type (Subt)); 12542 pragma Assert (Typ = Base_Type (Typ)); 12543 12544 Set_First_Entity (Subt, Empty); 12545 Set_Last_Entity (Subt, Empty); 12546 12547 -- Check whether constraint is fully static, in which case we can 12548 -- optimize the list of components. 12549 12550 Discr_Val := First_Elmt (Constraints); 12551 while Present (Discr_Val) loop 12552 if not Is_OK_Static_Expression (Node (Discr_Val)) then 12553 Is_Static := False; 12554 exit; 12555 end if; 12556 12557 Next_Elmt (Discr_Val); 12558 end loop; 12559 12560 Set_Has_Static_Discriminants (Subt, Is_Static); 12561 12562 Push_Scope (Subt); 12563 12564 -- Inherit the discriminants of the parent type 12565 12566 Add_Discriminants : declare 12567 Num_Disc : Int; 12568 Num_Gird : Int; 12569 12570 begin 12571 Num_Disc := 0; 12572 Old_C := First_Discriminant (Typ); 12573 12574 while Present (Old_C) loop 12575 Num_Disc := Num_Disc + 1; 12576 New_C := Create_Component (Old_C); 12577 Set_Is_Public (New_C, Is_Public (Subt)); 12578 Next_Discriminant (Old_C); 12579 end loop; 12580 12581 -- For an untagged derived subtype, the number of discriminants may 12582 -- be smaller than the number of inherited discriminants, because 12583 -- several of them may be renamed by a single new discriminant or 12584 -- constrained. In this case, add the hidden discriminants back into 12585 -- the subtype, because they need to be present if the optimizer of 12586 -- the GCC 4.x back-end decides to break apart assignments between 12587 -- objects using the parent view into member-wise assignments. 12588 12589 Num_Gird := 0; 12590 12591 if Is_Derived_Type (Typ) 12592 and then not Is_Tagged_Type (Typ) 12593 then 12594 Old_C := First_Stored_Discriminant (Typ); 12595 12596 while Present (Old_C) loop 12597 Num_Gird := Num_Gird + 1; 12598 Next_Stored_Discriminant (Old_C); 12599 end loop; 12600 end if; 12601 12602 if Num_Gird > Num_Disc then 12603 12604 -- Find out multiple uses of new discriminants, and add hidden 12605 -- components for the extra renamed discriminants. We recognize 12606 -- multiple uses through the Corresponding_Discriminant of a 12607 -- new discriminant: if it constrains several old discriminants, 12608 -- this field points to the last one in the parent type. The 12609 -- stored discriminants of the derived type have the same name 12610 -- as those of the parent. 12611 12612 declare 12613 Constr : Elmt_Id; 12614 New_Discr : Entity_Id; 12615 Old_Discr : Entity_Id; 12616 12617 begin 12618 Constr := First_Elmt (Stored_Constraint (Typ)); 12619 Old_Discr := First_Stored_Discriminant (Typ); 12620 while Present (Constr) loop 12621 if Is_Entity_Name (Node (Constr)) 12622 and then Ekind (Entity (Node (Constr))) = E_Discriminant 12623 then 12624 New_Discr := Entity (Node (Constr)); 12625 12626 if Chars (Corresponding_Discriminant (New_Discr)) /= 12627 Chars (Old_Discr) 12628 then 12629 -- The new discriminant has been used to rename a 12630 -- subsequent old discriminant. Introduce a shadow 12631 -- component for the current old discriminant. 12632 12633 New_C := Create_Component (Old_Discr); 12634 Set_Original_Record_Component (New_C, Old_Discr); 12635 end if; 12636 12637 else 12638 -- The constraint has eliminated the old discriminant. 12639 -- Introduce a shadow component. 12640 12641 New_C := Create_Component (Old_Discr); 12642 Set_Original_Record_Component (New_C, Old_Discr); 12643 end if; 12644 12645 Next_Elmt (Constr); 12646 Next_Stored_Discriminant (Old_Discr); 12647 end loop; 12648 end; 12649 end if; 12650 end Add_Discriminants; 12651 12652 if Is_Static 12653 and then Is_Variant_Record (Typ) 12654 then 12655 Collect_Fixed_Components (Typ); 12656 12657 Gather_Components ( 12658 Typ, 12659 Component_List (Type_Definition (Parent (Typ))), 12660 Governed_By => Assoc_List, 12661 Into => Comp_List, 12662 Report_Errors => Errors); 12663 pragma Assert (not Errors); 12664 12665 Create_All_Components; 12666 12667 -- If the subtype declaration is created for a tagged type derivation 12668 -- with constraints, we retrieve the record definition of the parent 12669 -- type to select the components of the proper variant. 12670 12671 elsif Is_Static 12672 and then Is_Tagged_Type (Typ) 12673 and then Nkind (Parent (Typ)) = N_Full_Type_Declaration 12674 and then 12675 Nkind (Type_Definition (Parent (Typ))) = N_Derived_Type_Definition 12676 and then Is_Variant_Record (Parent_Type) 12677 then 12678 Collect_Fixed_Components (Typ); 12679 12680 Gather_Components ( 12681 Typ, 12682 Component_List (Type_Definition (Parent (Parent_Type))), 12683 Governed_By => Assoc_List, 12684 Into => Comp_List, 12685 Report_Errors => Errors); 12686 pragma Assert (not Errors); 12687 12688 -- If the tagged derivation has a type extension, collect all the 12689 -- new components therein. 12690 12691 if Present 12692 (Record_Extension_Part (Type_Definition (Parent (Typ)))) 12693 then 12694 Old_C := First_Component (Typ); 12695 while Present (Old_C) loop 12696 if Original_Record_Component (Old_C) = Old_C 12697 and then Chars (Old_C) /= Name_uTag 12698 and then Chars (Old_C) /= Name_uParent 12699 then 12700 Append_Elmt (Old_C, Comp_List); 12701 end if; 12702 12703 Next_Component (Old_C); 12704 end loop; 12705 end if; 12706 12707 Create_All_Components; 12708 12709 else 12710 -- If discriminants are not static, or if this is a multi-level type 12711 -- extension, we have to include all components of the parent type. 12712 12713 Old_C := First_Component (Typ); 12714 while Present (Old_C) loop 12715 New_C := Create_Component (Old_C); 12716 12717 Set_Etype 12718 (New_C, 12719 Constrain_Component_Type 12720 (Old_C, Subt, Decl_Node, Typ, Constraints)); 12721 Set_Is_Public (New_C, Is_Public (Subt)); 12722 12723 Next_Component (Old_C); 12724 end loop; 12725 end if; 12726 12727 End_Scope; 12728 end Create_Constrained_Components; 12729 12730 ------------------------------------------ 12731 -- Decimal_Fixed_Point_Type_Declaration -- 12732 ------------------------------------------ 12733 12734 procedure Decimal_Fixed_Point_Type_Declaration 12735 (T : Entity_Id; 12736 Def : Node_Id) 12737 is 12738 Loc : constant Source_Ptr := Sloc (Def); 12739 Digs_Expr : constant Node_Id := Digits_Expression (Def); 12740 Delta_Expr : constant Node_Id := Delta_Expression (Def); 12741 Implicit_Base : Entity_Id; 12742 Digs_Val : Uint; 12743 Delta_Val : Ureal; 12744 Scale_Val : Uint; 12745 Bound_Val : Ureal; 12746 12747 begin 12748 Check_SPARK_Restriction 12749 ("decimal fixed point type is not allowed", Def); 12750 Check_Restriction (No_Fixed_Point, Def); 12751 12752 -- Create implicit base type 12753 12754 Implicit_Base := 12755 Create_Itype (E_Decimal_Fixed_Point_Type, Parent (Def), T, 'B'); 12756 Set_Etype (Implicit_Base, Implicit_Base); 12757 12758 -- Analyze and process delta expression 12759 12760 Analyze_And_Resolve (Delta_Expr, Universal_Real); 12761 12762 Check_Delta_Expression (Delta_Expr); 12763 Delta_Val := Expr_Value_R (Delta_Expr); 12764 12765 -- Check delta is power of 10, and determine scale value from it 12766 12767 declare 12768 Val : Ureal; 12769 12770 begin 12771 Scale_Val := Uint_0; 12772 Val := Delta_Val; 12773 12774 if Val < Ureal_1 then 12775 while Val < Ureal_1 loop 12776 Val := Val * Ureal_10; 12777 Scale_Val := Scale_Val + 1; 12778 end loop; 12779 12780 if Scale_Val > 18 then 12781 Error_Msg_N ("scale exceeds maximum value of 18", Def); 12782 Scale_Val := UI_From_Int (+18); 12783 end if; 12784 12785 else 12786 while Val > Ureal_1 loop 12787 Val := Val / Ureal_10; 12788 Scale_Val := Scale_Val - 1; 12789 end loop; 12790 12791 if Scale_Val < -18 then 12792 Error_Msg_N ("scale is less than minimum value of -18", Def); 12793 Scale_Val := UI_From_Int (-18); 12794 end if; 12795 end if; 12796 12797 if Val /= Ureal_1 then 12798 Error_Msg_N ("delta expression must be a power of 10", Def); 12799 Delta_Val := Ureal_10 ** (-Scale_Val); 12800 end if; 12801 end; 12802 12803 -- Set delta, scale and small (small = delta for decimal type) 12804 12805 Set_Delta_Value (Implicit_Base, Delta_Val); 12806 Set_Scale_Value (Implicit_Base, Scale_Val); 12807 Set_Small_Value (Implicit_Base, Delta_Val); 12808 12809 -- Analyze and process digits expression 12810 12811 Analyze_And_Resolve (Digs_Expr, Any_Integer); 12812 Check_Digits_Expression (Digs_Expr); 12813 Digs_Val := Expr_Value (Digs_Expr); 12814 12815 if Digs_Val > 18 then 12816 Digs_Val := UI_From_Int (+18); 12817 Error_Msg_N ("digits value out of range, maximum is 18", Digs_Expr); 12818 end if; 12819 12820 Set_Digits_Value (Implicit_Base, Digs_Val); 12821 Bound_Val := UR_From_Uint (10 ** Digs_Val - 1) * Delta_Val; 12822 12823 -- Set range of base type from digits value for now. This will be 12824 -- expanded to represent the true underlying base range by Freeze. 12825 12826 Set_Fixed_Range (Implicit_Base, Loc, -Bound_Val, Bound_Val); 12827 12828 -- Note: We leave size as zero for now, size will be set at freeze 12829 -- time. We have to do this for ordinary fixed-point, because the size 12830 -- depends on the specified small, and we might as well do the same for 12831 -- decimal fixed-point. 12832 12833 pragma Assert (Esize (Implicit_Base) = Uint_0); 12834 12835 -- If there are bounds given in the declaration use them as the 12836 -- bounds of the first named subtype. 12837 12838 if Present (Real_Range_Specification (Def)) then 12839 declare 12840 RRS : constant Node_Id := Real_Range_Specification (Def); 12841 Low : constant Node_Id := Low_Bound (RRS); 12842 High : constant Node_Id := High_Bound (RRS); 12843 Low_Val : Ureal; 12844 High_Val : Ureal; 12845 12846 begin 12847 Analyze_And_Resolve (Low, Any_Real); 12848 Analyze_And_Resolve (High, Any_Real); 12849 Check_Real_Bound (Low); 12850 Check_Real_Bound (High); 12851 Low_Val := Expr_Value_R (Low); 12852 High_Val := Expr_Value_R (High); 12853 12854 if Low_Val < (-Bound_Val) then 12855 Error_Msg_N 12856 ("range low bound too small for digits value", Low); 12857 Low_Val := -Bound_Val; 12858 end if; 12859 12860 if High_Val > Bound_Val then 12861 Error_Msg_N 12862 ("range high bound too large for digits value", High); 12863 High_Val := Bound_Val; 12864 end if; 12865 12866 Set_Fixed_Range (T, Loc, Low_Val, High_Val); 12867 end; 12868 12869 -- If no explicit range, use range that corresponds to given 12870 -- digits value. This will end up as the final range for the 12871 -- first subtype. 12872 12873 else 12874 Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val); 12875 end if; 12876 12877 -- Complete entity for first subtype 12878 12879 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); 12880 Set_Etype (T, Implicit_Base); 12881 Set_Size_Info (T, Implicit_Base); 12882 Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); 12883 Set_Digits_Value (T, Digs_Val); 12884 Set_Delta_Value (T, Delta_Val); 12885 Set_Small_Value (T, Delta_Val); 12886 Set_Scale_Value (T, Scale_Val); 12887 Set_Is_Constrained (T); 12888 end Decimal_Fixed_Point_Type_Declaration; 12889 12890 ----------------------------------- 12891 -- Derive_Progenitor_Subprograms -- 12892 ----------------------------------- 12893 12894 procedure Derive_Progenitor_Subprograms 12895 (Parent_Type : Entity_Id; 12896 Tagged_Type : Entity_Id) 12897 is 12898 E : Entity_Id; 12899 Elmt : Elmt_Id; 12900 Iface : Entity_Id; 12901 Iface_Elmt : Elmt_Id; 12902 Iface_Subp : Entity_Id; 12903 New_Subp : Entity_Id := Empty; 12904 Prim_Elmt : Elmt_Id; 12905 Subp : Entity_Id; 12906 Typ : Entity_Id; 12907 12908 begin 12909 pragma Assert (Ada_Version >= Ada_2005 12910 and then Is_Record_Type (Tagged_Type) 12911 and then Is_Tagged_Type (Tagged_Type) 12912 and then Has_Interfaces (Tagged_Type)); 12913 12914 -- Step 1: Transfer to the full-view primitives associated with the 12915 -- partial-view that cover interface primitives. Conceptually this 12916 -- work should be done later by Process_Full_View; done here to 12917 -- simplify its implementation at later stages. It can be safely 12918 -- done here because interfaces must be visible in the partial and 12919 -- private view (RM 7.3(7.3/2)). 12920 12921 -- Small optimization: This work is only required if the parent may 12922 -- have entities whose Alias attribute reference an interface primitive. 12923 -- Such a situation may occur if the parent is an abstract type and the 12924 -- primitive has not been yet overridden or if the parent is a generic 12925 -- formal type covering interfaces. 12926 12927 -- If the tagged type is not abstract, it cannot have abstract 12928 -- primitives (the only entities in the list of primitives of 12929 -- non-abstract tagged types that can reference abstract primitives 12930 -- through its Alias attribute are the internal entities that have 12931 -- attribute Interface_Alias, and these entities are generated later 12932 -- by Add_Internal_Interface_Entities). 12933 12934 if In_Private_Part (Current_Scope) 12935 and then (Is_Abstract_Type (Parent_Type) 12936 or else 12937 Is_Generic_Type (Parent_Type)) 12938 then 12939 Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); 12940 while Present (Elmt) loop 12941 Subp := Node (Elmt); 12942 12943 -- At this stage it is not possible to have entities in the list 12944 -- of primitives that have attribute Interface_Alias. 12945 12946 pragma Assert (No (Interface_Alias (Subp))); 12947 12948 Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); 12949 12950 if Is_Interface (Typ) then 12951 E := Find_Primitive_Covering_Interface 12952 (Tagged_Type => Tagged_Type, 12953 Iface_Prim => Subp); 12954 12955 if Present (E) 12956 and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ 12957 then 12958 Replace_Elmt (Elmt, E); 12959 Remove_Homonym (Subp); 12960 end if; 12961 end if; 12962 12963 Next_Elmt (Elmt); 12964 end loop; 12965 end if; 12966 12967 -- Step 2: Add primitives of progenitors that are not implemented by 12968 -- parents of Tagged_Type. 12969 12970 if Present (Interfaces (Base_Type (Tagged_Type))) then 12971 Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type))); 12972 while Present (Iface_Elmt) loop 12973 Iface := Node (Iface_Elmt); 12974 12975 Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); 12976 while Present (Prim_Elmt) loop 12977 Iface_Subp := Node (Prim_Elmt); 12978 12979 -- Exclude derivation of predefined primitives except those 12980 -- that come from source, or are inherited from one that comes 12981 -- from source. Required to catch declarations of equality 12982 -- operators of interfaces. For example: 12983 12984 -- type Iface is interface; 12985 -- function "=" (Left, Right : Iface) return Boolean; 12986 12987 if not Is_Predefined_Dispatching_Operation (Iface_Subp) 12988 or else Comes_From_Source (Ultimate_Alias (Iface_Subp)) 12989 then 12990 E := Find_Primitive_Covering_Interface 12991 (Tagged_Type => Tagged_Type, 12992 Iface_Prim => Iface_Subp); 12993 12994 -- If not found we derive a new primitive leaving its alias 12995 -- attribute referencing the interface primitive. 12996 12997 if No (E) then 12998 Derive_Subprogram 12999 (New_Subp, Iface_Subp, Tagged_Type, Iface); 13000 13001 -- Ada 2012 (AI05-0197): If the covering primitive's name 13002 -- differs from the name of the interface primitive then it 13003 -- is a private primitive inherited from a parent type. In 13004 -- such case, given that Tagged_Type covers the interface, 13005 -- the inherited private primitive becomes visible. For such 13006 -- purpose we add a new entity that renames the inherited 13007 -- private primitive. 13008 13009 elsif Chars (E) /= Chars (Iface_Subp) then 13010 pragma Assert (Has_Suffix (E, 'P')); 13011 Derive_Subprogram 13012 (New_Subp, Iface_Subp, Tagged_Type, Iface); 13013 Set_Alias (New_Subp, E); 13014 Set_Is_Abstract_Subprogram (New_Subp, 13015 Is_Abstract_Subprogram (E)); 13016 13017 -- Propagate to the full view interface entities associated 13018 -- with the partial view. 13019 13020 elsif In_Private_Part (Current_Scope) 13021 and then Present (Alias (E)) 13022 and then Alias (E) = Iface_Subp 13023 and then 13024 List_Containing (Parent (E)) /= 13025 Private_Declarations 13026 (Specification 13027 (Unit_Declaration_Node (Current_Scope))) 13028 then 13029 Append_Elmt (E, Primitive_Operations (Tagged_Type)); 13030 end if; 13031 end if; 13032 13033 Next_Elmt (Prim_Elmt); 13034 end loop; 13035 13036 Next_Elmt (Iface_Elmt); 13037 end loop; 13038 end if; 13039 end Derive_Progenitor_Subprograms; 13040 13041 ----------------------- 13042 -- Derive_Subprogram -- 13043 ----------------------- 13044 13045 procedure Derive_Subprogram 13046 (New_Subp : in out Entity_Id; 13047 Parent_Subp : Entity_Id; 13048 Derived_Type : Entity_Id; 13049 Parent_Type : Entity_Id; 13050 Actual_Subp : Entity_Id := Empty) 13051 is 13052 Formal : Entity_Id; 13053 -- Formal parameter of parent primitive operation 13054 13055 Formal_Of_Actual : Entity_Id; 13056 -- Formal parameter of actual operation, when the derivation is to 13057 -- create a renaming for a primitive operation of an actual in an 13058 -- instantiation. 13059 13060 New_Formal : Entity_Id; 13061 -- Formal of inherited operation 13062 13063 Visible_Subp : Entity_Id := Parent_Subp; 13064 13065 function Is_Private_Overriding return Boolean; 13066 -- If Subp is a private overriding of a visible operation, the inherited 13067 -- operation derives from the overridden op (even though its body is the 13068 -- overriding one) and the inherited operation is visible now. See 13069 -- sem_disp to see the full details of the handling of the overridden 13070 -- subprogram, which is removed from the list of primitive operations of 13071 -- the type. The overridden subprogram is saved locally in Visible_Subp, 13072 -- and used to diagnose abstract operations that need overriding in the 13073 -- derived type. 13074 13075 procedure Replace_Type (Id, New_Id : Entity_Id); 13076 -- When the type is an anonymous access type, create a new access type 13077 -- designating the derived type. 13078 13079 procedure Set_Derived_Name; 13080 -- This procedure sets the appropriate Chars name for New_Subp. This 13081 -- is normally just a copy of the parent name. An exception arises for 13082 -- type support subprograms, where the name is changed to reflect the 13083 -- name of the derived type, e.g. if type foo is derived from type bar, 13084 -- then a procedure barDA is derived with a name fooDA. 13085 13086 --------------------------- 13087 -- Is_Private_Overriding -- 13088 --------------------------- 13089 13090 function Is_Private_Overriding return Boolean is 13091 Prev : Entity_Id; 13092 13093 begin 13094 -- If the parent is not a dispatching operation there is no 13095 -- need to investigate overridings 13096 13097 if not Is_Dispatching_Operation (Parent_Subp) then 13098 return False; 13099 end if; 13100 13101 -- The visible operation that is overridden is a homonym of the 13102 -- parent subprogram. We scan the homonym chain to find the one 13103 -- whose alias is the subprogram we are deriving. 13104 13105 Prev := Current_Entity (Parent_Subp); 13106 while Present (Prev) loop 13107 if Ekind (Prev) = Ekind (Parent_Subp) 13108 and then Alias (Prev) = Parent_Subp 13109 and then Scope (Parent_Subp) = Scope (Prev) 13110 and then not Is_Hidden (Prev) 13111 then 13112 Visible_Subp := Prev; 13113 return True; 13114 end if; 13115 13116 Prev := Homonym (Prev); 13117 end loop; 13118 13119 return False; 13120 end Is_Private_Overriding; 13121 13122 ------------------ 13123 -- Replace_Type -- 13124 ------------------ 13125 13126 procedure Replace_Type (Id, New_Id : Entity_Id) is 13127 Acc_Type : Entity_Id; 13128 Par : constant Node_Id := Parent (Derived_Type); 13129 13130 begin 13131 -- When the type is an anonymous access type, create a new access 13132 -- type designating the derived type. This itype must be elaborated 13133 -- at the point of the derivation, not on subsequent calls that may 13134 -- be out of the proper scope for Gigi, so we insert a reference to 13135 -- it after the derivation. 13136 13137 if Ekind (Etype (Id)) = E_Anonymous_Access_Type then 13138 declare 13139 Desig_Typ : Entity_Id := Designated_Type (Etype (Id)); 13140 13141 begin 13142 if Ekind (Desig_Typ) = E_Record_Type_With_Private 13143 and then Present (Full_View (Desig_Typ)) 13144 and then not Is_Private_Type (Parent_Type) 13145 then 13146 Desig_Typ := Full_View (Desig_Typ); 13147 end if; 13148 13149 if Base_Type (Desig_Typ) = Base_Type (Parent_Type) 13150 13151 -- Ada 2005 (AI-251): Handle also derivations of abstract 13152 -- interface primitives. 13153 13154 or else (Is_Interface (Desig_Typ) 13155 and then not Is_Class_Wide_Type (Desig_Typ)) 13156 then 13157 Acc_Type := New_Copy (Etype (Id)); 13158 Set_Etype (Acc_Type, Acc_Type); 13159 Set_Scope (Acc_Type, New_Subp); 13160 13161 -- Compute size of anonymous access type 13162 13163 if Is_Array_Type (Desig_Typ) 13164 and then not Is_Constrained (Desig_Typ) 13165 then 13166 Init_Size (Acc_Type, 2 * System_Address_Size); 13167 else 13168 Init_Size (Acc_Type, System_Address_Size); 13169 end if; 13170 13171 Init_Alignment (Acc_Type); 13172 Set_Directly_Designated_Type (Acc_Type, Derived_Type); 13173 13174 Set_Etype (New_Id, Acc_Type); 13175 Set_Scope (New_Id, New_Subp); 13176 13177 -- Create a reference to it 13178 Build_Itype_Reference (Acc_Type, Parent (Derived_Type)); 13179 13180 else 13181 Set_Etype (New_Id, Etype (Id)); 13182 end if; 13183 end; 13184 13185 elsif Base_Type (Etype (Id)) = Base_Type (Parent_Type) 13186 or else 13187 (Ekind (Etype (Id)) = E_Record_Type_With_Private 13188 and then Present (Full_View (Etype (Id))) 13189 and then 13190 Base_Type (Full_View (Etype (Id))) = Base_Type (Parent_Type)) 13191 then 13192 -- Constraint checks on formals are generated during expansion, 13193 -- based on the signature of the original subprogram. The bounds 13194 -- of the derived type are not relevant, and thus we can use 13195 -- the base type for the formals. However, the return type may be 13196 -- used in a context that requires that the proper static bounds 13197 -- be used (a case statement, for example) and for those cases 13198 -- we must use the derived type (first subtype), not its base. 13199 13200 -- If the derived_type_definition has no constraints, we know that 13201 -- the derived type has the same constraints as the first subtype 13202 -- of the parent, and we can also use it rather than its base, 13203 -- which can lead to more efficient code. 13204 13205 if Etype (Id) = Parent_Type then 13206 if Is_Scalar_Type (Parent_Type) 13207 and then 13208 Subtypes_Statically_Compatible (Parent_Type, Derived_Type) 13209 then 13210 Set_Etype (New_Id, Derived_Type); 13211 13212 elsif Nkind (Par) = N_Full_Type_Declaration 13213 and then 13214 Nkind (Type_Definition (Par)) = N_Derived_Type_Definition 13215 and then 13216 Is_Entity_Name 13217 (Subtype_Indication (Type_Definition (Par))) 13218 then 13219 Set_Etype (New_Id, Derived_Type); 13220 13221 else 13222 Set_Etype (New_Id, Base_Type (Derived_Type)); 13223 end if; 13224 13225 else 13226 Set_Etype (New_Id, Base_Type (Derived_Type)); 13227 end if; 13228 13229 else 13230 Set_Etype (New_Id, Etype (Id)); 13231 end if; 13232 end Replace_Type; 13233 13234 ---------------------- 13235 -- Set_Derived_Name -- 13236 ---------------------- 13237 13238 procedure Set_Derived_Name is 13239 Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp); 13240 begin 13241 if Nm = TSS_Null then 13242 Set_Chars (New_Subp, Chars (Parent_Subp)); 13243 else 13244 Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm)); 13245 end if; 13246 end Set_Derived_Name; 13247 13248 -- Start of processing for Derive_Subprogram 13249 13250 begin 13251 New_Subp := 13252 New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); 13253 Set_Ekind (New_Subp, Ekind (Parent_Subp)); 13254 Set_Contract (New_Subp, Make_Contract (Sloc (New_Subp))); 13255 13256 -- Check whether the inherited subprogram is a private operation that 13257 -- should be inherited but not yet made visible. Such subprograms can 13258 -- become visible at a later point (e.g., the private part of a public 13259 -- child unit) via Declare_Inherited_Private_Subprograms. If the 13260 -- following predicate is true, then this is not such a private 13261 -- operation and the subprogram simply inherits the name of the parent 13262 -- subprogram. Note the special check for the names of controlled 13263 -- operations, which are currently exempted from being inherited with 13264 -- a hidden name because they must be findable for generation of 13265 -- implicit run-time calls. 13266 13267 if not Is_Hidden (Parent_Subp) 13268 or else Is_Internal (Parent_Subp) 13269 or else Is_Private_Overriding 13270 or else Is_Internal_Name (Chars (Parent_Subp)) 13271 or else Chars (Parent_Subp) = Name_Initialize 13272 or else Chars (Parent_Subp) = Name_Adjust 13273 or else Chars (Parent_Subp) = Name_Finalize 13274 then 13275 Set_Derived_Name; 13276 13277 -- An inherited dispatching equality will be overridden by an internally 13278 -- generated one, or by an explicit one, so preserve its name and thus 13279 -- its entry in the dispatch table. Otherwise, if Parent_Subp is a 13280 -- private operation it may become invisible if the full view has 13281 -- progenitors, and the dispatch table will be malformed. 13282 -- We check that the type is limited to handle the anomalous declaration 13283 -- of Limited_Controlled, which is derived from a non-limited type, and 13284 -- which is handled specially elsewhere as well. 13285 13286 elsif Chars (Parent_Subp) = Name_Op_Eq 13287 and then Is_Dispatching_Operation (Parent_Subp) 13288 and then Etype (Parent_Subp) = Standard_Boolean 13289 and then not Is_Limited_Type (Etype (First_Formal (Parent_Subp))) 13290 and then 13291 Etype (First_Formal (Parent_Subp)) = 13292 Etype (Next_Formal (First_Formal (Parent_Subp))) 13293 then 13294 Set_Derived_Name; 13295 13296 -- If parent is hidden, this can be a regular derivation if the 13297 -- parent is immediately visible in a non-instantiating context, 13298 -- or if we are in the private part of an instance. This test 13299 -- should still be refined ??? 13300 13301 -- The test for In_Instance_Not_Visible avoids inheriting the derived 13302 -- operation as a non-visible operation in cases where the parent 13303 -- subprogram might not be visible now, but was visible within the 13304 -- original generic, so it would be wrong to make the inherited 13305 -- subprogram non-visible now. (Not clear if this test is fully 13306 -- correct; are there any cases where we should declare the inherited 13307 -- operation as not visible to avoid it being overridden, e.g., when 13308 -- the parent type is a generic actual with private primitives ???) 13309 13310 -- (they should be treated the same as other private inherited 13311 -- subprograms, but it's not clear how to do this cleanly). ??? 13312 13313 elsif (In_Open_Scopes (Scope (Base_Type (Parent_Type))) 13314 and then Is_Immediately_Visible (Parent_Subp) 13315 and then not In_Instance) 13316 or else In_Instance_Not_Visible 13317 then 13318 Set_Derived_Name; 13319 13320 -- Ada 2005 (AI-251): Regular derivation if the parent subprogram 13321 -- overrides an interface primitive because interface primitives 13322 -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) 13323 13324 elsif Ada_Version >= Ada_2005 13325 and then Is_Dispatching_Operation (Parent_Subp) 13326 and then Covers_Some_Interface (Parent_Subp) 13327 then 13328 Set_Derived_Name; 13329 13330 -- Otherwise, the type is inheriting a private operation, so enter 13331 -- it with a special name so it can't be overridden. 13332 13333 else 13334 Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P')); 13335 end if; 13336 13337 Set_Parent (New_Subp, Parent (Derived_Type)); 13338 13339 if Present (Actual_Subp) then 13340 Replace_Type (Actual_Subp, New_Subp); 13341 else 13342 Replace_Type (Parent_Subp, New_Subp); 13343 end if; 13344 13345 Conditional_Delay (New_Subp, Parent_Subp); 13346 13347 -- If we are creating a renaming for a primitive operation of an 13348 -- actual of a generic derived type, we must examine the signature 13349 -- of the actual primitive, not that of the generic formal, which for 13350 -- example may be an interface. However the name and initial value 13351 -- of the inherited operation are those of the formal primitive. 13352 13353 Formal := First_Formal (Parent_Subp); 13354 13355 if Present (Actual_Subp) then 13356 Formal_Of_Actual := First_Formal (Actual_Subp); 13357 else 13358 Formal_Of_Actual := Empty; 13359 end if; 13360 13361 while Present (Formal) loop 13362 New_Formal := New_Copy (Formal); 13363 13364 -- Normally we do not go copying parents, but in the case of 13365 -- formals, we need to link up to the declaration (which is the 13366 -- parameter specification), and it is fine to link up to the 13367 -- original formal's parameter specification in this case. 13368 13369 Set_Parent (New_Formal, Parent (Formal)); 13370 Append_Entity (New_Formal, New_Subp); 13371 13372 if Present (Formal_Of_Actual) then 13373 Replace_Type (Formal_Of_Actual, New_Formal); 13374 Next_Formal (Formal_Of_Actual); 13375 else 13376 Replace_Type (Formal, New_Formal); 13377 end if; 13378 13379 Next_Formal (Formal); 13380 end loop; 13381 13382 -- If this derivation corresponds to a tagged generic actual, then 13383 -- primitive operations rename those of the actual. Otherwise the 13384 -- primitive operations rename those of the parent type, If the parent 13385 -- renames an intrinsic operator, so does the new subprogram. We except 13386 -- concatenation, which is always properly typed, and does not get 13387 -- expanded as other intrinsic operations. 13388 13389 if No (Actual_Subp) then 13390 if Is_Intrinsic_Subprogram (Parent_Subp) then 13391 Set_Is_Intrinsic_Subprogram (New_Subp); 13392 13393 if Present (Alias (Parent_Subp)) 13394 and then Chars (Parent_Subp) /= Name_Op_Concat 13395 then 13396 Set_Alias (New_Subp, Alias (Parent_Subp)); 13397 else 13398 Set_Alias (New_Subp, Parent_Subp); 13399 end if; 13400 13401 else 13402 Set_Alias (New_Subp, Parent_Subp); 13403 end if; 13404 13405 else 13406 Set_Alias (New_Subp, Actual_Subp); 13407 end if; 13408 13409 -- Derived subprograms of a tagged type must inherit the convention 13410 -- of the parent subprogram (a requirement of AI-117). Derived 13411 -- subprograms of untagged types simply get convention Ada by default. 13412 13413 -- If the derived type is a tagged generic formal type with unknown 13414 -- discriminants, its convention is intrinsic (RM 6.3.1 (8)). 13415 13416 -- However, if the type is derived from a generic formal, the further 13417 -- inherited subprogram has the convention of the non-generic ancestor. 13418 -- Otherwise there would be no way to override the operation. 13419 -- (This is subject to forthcoming ARG discussions). 13420 13421 if Is_Tagged_Type (Derived_Type) then 13422 if Is_Generic_Type (Derived_Type) 13423 and then Has_Unknown_Discriminants (Derived_Type) 13424 then 13425 Set_Convention (New_Subp, Convention_Intrinsic); 13426 13427 else 13428 if Is_Generic_Type (Parent_Type) 13429 and then Has_Unknown_Discriminants (Parent_Type) 13430 then 13431 Set_Convention (New_Subp, Convention (Alias (Parent_Subp))); 13432 else 13433 Set_Convention (New_Subp, Convention (Parent_Subp)); 13434 end if; 13435 end if; 13436 end if; 13437 13438 -- Predefined controlled operations retain their name even if the parent 13439 -- is hidden (see above), but they are not primitive operations if the 13440 -- ancestor is not visible, for example if the parent is a private 13441 -- extension completed with a controlled extension. Note that a full 13442 -- type that is controlled can break privacy: the flag Is_Controlled is 13443 -- set on both views of the type. 13444 13445 if Is_Controlled (Parent_Type) 13446 and then 13447 (Chars (Parent_Subp) = Name_Initialize or else 13448 Chars (Parent_Subp) = Name_Adjust or else 13449 Chars (Parent_Subp) = Name_Finalize) 13450 and then Is_Hidden (Parent_Subp) 13451 and then not Is_Visibly_Controlled (Parent_Type) 13452 then 13453 Set_Is_Hidden (New_Subp); 13454 end if; 13455 13456 Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp)); 13457 Set_Is_Exported (New_Subp, Is_Exported (Parent_Subp)); 13458 13459 if Ekind (Parent_Subp) = E_Procedure then 13460 Set_Is_Valued_Procedure 13461 (New_Subp, Is_Valued_Procedure (Parent_Subp)); 13462 else 13463 Set_Has_Controlling_Result 13464 (New_Subp, Has_Controlling_Result (Parent_Subp)); 13465 end if; 13466 13467 -- No_Return must be inherited properly. If this is overridden in the 13468 -- case of a dispatching operation, then a check is made in Sem_Disp 13469 -- that the overriding operation is also No_Return (no such check is 13470 -- required for the case of non-dispatching operation. 13471 13472 Set_No_Return (New_Subp, No_Return (Parent_Subp)); 13473 13474 -- A derived function with a controlling result is abstract. If the 13475 -- Derived_Type is a nonabstract formal generic derived type, then 13476 -- inherited operations are not abstract: the required check is done at 13477 -- instantiation time. If the derivation is for a generic actual, the 13478 -- function is not abstract unless the actual is. 13479 13480 if Is_Generic_Type (Derived_Type) 13481 and then not Is_Abstract_Type (Derived_Type) 13482 then 13483 null; 13484 13485 -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" 13486 -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). 13487 13488 elsif Ada_Version >= Ada_2005 13489 and then (Is_Abstract_Subprogram (Alias (New_Subp)) 13490 or else (Is_Tagged_Type (Derived_Type) 13491 and then Etype (New_Subp) = Derived_Type 13492 and then not Is_Null_Extension (Derived_Type)) 13493 or else (Is_Tagged_Type (Derived_Type) 13494 and then Ekind (Etype (New_Subp)) = 13495 E_Anonymous_Access_Type 13496 and then Designated_Type (Etype (New_Subp)) = 13497 Derived_Type 13498 and then not Is_Null_Extension (Derived_Type))) 13499 and then No (Actual_Subp) 13500 then 13501 if not Is_Tagged_Type (Derived_Type) 13502 or else Is_Abstract_Type (Derived_Type) 13503 or else Is_Abstract_Subprogram (Alias (New_Subp)) 13504 then 13505 Set_Is_Abstract_Subprogram (New_Subp); 13506 else 13507 Set_Requires_Overriding (New_Subp); 13508 end if; 13509 13510 elsif Ada_Version < Ada_2005 13511 and then (Is_Abstract_Subprogram (Alias (New_Subp)) 13512 or else (Is_Tagged_Type (Derived_Type) 13513 and then Etype (New_Subp) = Derived_Type 13514 and then No (Actual_Subp))) 13515 then 13516 Set_Is_Abstract_Subprogram (New_Subp); 13517 13518 -- AI05-0097 : an inherited operation that dispatches on result is 13519 -- abstract if the derived type is abstract, even if the parent type 13520 -- is concrete and the derived type is a null extension. 13521 13522 elsif Has_Controlling_Result (Alias (New_Subp)) 13523 and then Is_Abstract_Type (Etype (New_Subp)) 13524 then 13525 Set_Is_Abstract_Subprogram (New_Subp); 13526 13527 -- Finally, if the parent type is abstract we must verify that all 13528 -- inherited operations are either non-abstract or overridden, or that 13529 -- the derived type itself is abstract (this check is performed at the 13530 -- end of a package declaration, in Check_Abstract_Overriding). A 13531 -- private overriding in the parent type will not be visible in the 13532 -- derivation if we are not in an inner package or in a child unit of 13533 -- the parent type, in which case the abstractness of the inherited 13534 -- operation is carried to the new subprogram. 13535 13536 elsif Is_Abstract_Type (Parent_Type) 13537 and then not In_Open_Scopes (Scope (Parent_Type)) 13538 and then Is_Private_Overriding 13539 and then Is_Abstract_Subprogram (Visible_Subp) 13540 then 13541 if No (Actual_Subp) then 13542 Set_Alias (New_Subp, Visible_Subp); 13543 Set_Is_Abstract_Subprogram (New_Subp, True); 13544 13545 else 13546 -- If this is a derivation for an instance of a formal derived 13547 -- type, abstractness comes from the primitive operation of the 13548 -- actual, not from the operation inherited from the ancestor. 13549 13550 Set_Is_Abstract_Subprogram 13551 (New_Subp, Is_Abstract_Subprogram (Actual_Subp)); 13552 end if; 13553 end if; 13554 13555 New_Overloaded_Entity (New_Subp, Derived_Type); 13556 13557 -- Check for case of a derived subprogram for the instantiation of a 13558 -- formal derived tagged type, if so mark the subprogram as dispatching 13559 -- and inherit the dispatching attributes of the actual subprogram. The 13560 -- derived subprogram is effectively renaming of the actual subprogram, 13561 -- so it needs to have the same attributes as the actual. 13562 13563 if Present (Actual_Subp) 13564 and then Is_Dispatching_Operation (Actual_Subp) 13565 then 13566 Set_Is_Dispatching_Operation (New_Subp); 13567 13568 if Present (DTC_Entity (Actual_Subp)) then 13569 Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp)); 13570 Set_DT_Position (New_Subp, DT_Position (Actual_Subp)); 13571 end if; 13572 end if; 13573 13574 -- Indicate that a derived subprogram does not require a body and that 13575 -- it does not require processing of default expressions. 13576 13577 Set_Has_Completion (New_Subp); 13578 Set_Default_Expressions_Processed (New_Subp); 13579 13580 if Ekind (New_Subp) = E_Function then 13581 Set_Mechanism (New_Subp, Mechanism (Parent_Subp)); 13582 end if; 13583 end Derive_Subprogram; 13584 13585 ------------------------ 13586 -- Derive_Subprograms -- 13587 ------------------------ 13588 13589 procedure Derive_Subprograms 13590 (Parent_Type : Entity_Id; 13591 Derived_Type : Entity_Id; 13592 Generic_Actual : Entity_Id := Empty) 13593 is 13594 Op_List : constant Elist_Id := 13595 Collect_Primitive_Operations (Parent_Type); 13596 13597 function Check_Derived_Type return Boolean; 13598 -- Check that all the entities derived from Parent_Type are found in 13599 -- the list of primitives of Derived_Type exactly in the same order. 13600 13601 procedure Derive_Interface_Subprogram 13602 (New_Subp : in out Entity_Id; 13603 Subp : Entity_Id; 13604 Actual_Subp : Entity_Id); 13605 -- Derive New_Subp from the ultimate alias of the parent subprogram Subp 13606 -- (which is an interface primitive). If Generic_Actual is present then 13607 -- Actual_Subp is the actual subprogram corresponding with the generic 13608 -- subprogram Subp. 13609 13610 function Check_Derived_Type return Boolean is 13611 E : Entity_Id; 13612 Elmt : Elmt_Id; 13613 List : Elist_Id; 13614 New_Subp : Entity_Id; 13615 Op_Elmt : Elmt_Id; 13616 Subp : Entity_Id; 13617 13618 begin 13619 -- Traverse list of entities in the current scope searching for 13620 -- an incomplete type whose full-view is derived type 13621 13622 E := First_Entity (Scope (Derived_Type)); 13623 while Present (E) and then E /= Derived_Type loop 13624 if Ekind (E) = E_Incomplete_Type 13625 and then Present (Full_View (E)) 13626 and then Full_View (E) = Derived_Type 13627 then 13628 -- Disable this test if Derived_Type completes an incomplete 13629 -- type because in such case more primitives can be added 13630 -- later to the list of primitives of Derived_Type by routine 13631 -- Process_Incomplete_Dependents 13632 13633 return True; 13634 end if; 13635 13636 E := Next_Entity (E); 13637 end loop; 13638 13639 List := Collect_Primitive_Operations (Derived_Type); 13640 Elmt := First_Elmt (List); 13641 13642 Op_Elmt := First_Elmt (Op_List); 13643 while Present (Op_Elmt) loop 13644 Subp := Node (Op_Elmt); 13645 New_Subp := Node (Elmt); 13646 13647 -- At this early stage Derived_Type has no entities with attribute 13648 -- Interface_Alias. In addition, such primitives are always 13649 -- located at the end of the list of primitives of Parent_Type. 13650 -- Therefore, if found we can safely stop processing pending 13651 -- entities. 13652 13653 exit when Present (Interface_Alias (Subp)); 13654 13655 -- Handle hidden entities 13656 13657 if not Is_Predefined_Dispatching_Operation (Subp) 13658 and then Is_Hidden (Subp) 13659 then 13660 if Present (New_Subp) 13661 and then Primitive_Names_Match (Subp, New_Subp) 13662 then 13663 Next_Elmt (Elmt); 13664 end if; 13665 13666 else 13667 if not Present (New_Subp) 13668 or else Ekind (Subp) /= Ekind (New_Subp) 13669 or else not Primitive_Names_Match (Subp, New_Subp) 13670 then 13671 return False; 13672 end if; 13673 13674 Next_Elmt (Elmt); 13675 end if; 13676 13677 Next_Elmt (Op_Elmt); 13678 end loop; 13679 13680 return True; 13681 end Check_Derived_Type; 13682 13683 --------------------------------- 13684 -- Derive_Interface_Subprogram -- 13685 --------------------------------- 13686 13687 procedure Derive_Interface_Subprogram 13688 (New_Subp : in out Entity_Id; 13689 Subp : Entity_Id; 13690 Actual_Subp : Entity_Id) 13691 is 13692 Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp); 13693 Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp); 13694 13695 begin 13696 pragma Assert (Is_Interface (Iface_Type)); 13697 13698 Derive_Subprogram 13699 (New_Subp => New_Subp, 13700 Parent_Subp => Iface_Subp, 13701 Derived_Type => Derived_Type, 13702 Parent_Type => Iface_Type, 13703 Actual_Subp => Actual_Subp); 13704 13705 -- Given that this new interface entity corresponds with a primitive 13706 -- of the parent that was not overridden we must leave it associated 13707 -- with its parent primitive to ensure that it will share the same 13708 -- dispatch table slot when overridden. 13709 13710 if No (Actual_Subp) then 13711 Set_Alias (New_Subp, Subp); 13712 13713 -- For instantiations this is not needed since the previous call to 13714 -- Derive_Subprogram leaves the entity well decorated. 13715 13716 else 13717 pragma Assert (Alias (New_Subp) = Actual_Subp); 13718 null; 13719 end if; 13720 end Derive_Interface_Subprogram; 13721 13722 -- Local variables 13723 13724 Alias_Subp : Entity_Id; 13725 Act_List : Elist_Id; 13726 Act_Elmt : Elmt_Id; 13727 Act_Subp : Entity_Id := Empty; 13728 Elmt : Elmt_Id; 13729 Need_Search : Boolean := False; 13730 New_Subp : Entity_Id := Empty; 13731 Parent_Base : Entity_Id; 13732 Subp : Entity_Id; 13733 13734 -- Start of processing for Derive_Subprograms 13735 13736 begin 13737 if Ekind (Parent_Type) = E_Record_Type_With_Private 13738 and then Has_Discriminants (Parent_Type) 13739 and then Present (Full_View (Parent_Type)) 13740 then 13741 Parent_Base := Full_View (Parent_Type); 13742 else 13743 Parent_Base := Parent_Type; 13744 end if; 13745 13746 if Present (Generic_Actual) then 13747 Act_List := Collect_Primitive_Operations (Generic_Actual); 13748 Act_Elmt := First_Elmt (Act_List); 13749 else 13750 Act_List := No_Elist; 13751 Act_Elmt := No_Elmt; 13752 end if; 13753 13754 -- Derive primitives inherited from the parent. Note that if the generic 13755 -- actual is present, this is not really a type derivation, it is a 13756 -- completion within an instance. 13757 13758 -- Case 1: Derived_Type does not implement interfaces 13759 13760 if not Is_Tagged_Type (Derived_Type) 13761 or else (not Has_Interfaces (Derived_Type) 13762 and then not (Present (Generic_Actual) 13763 and then Has_Interfaces (Generic_Actual))) 13764 then 13765 Elmt := First_Elmt (Op_List); 13766 while Present (Elmt) loop 13767 Subp := Node (Elmt); 13768 13769 -- Literals are derived earlier in the process of building the 13770 -- derived type, and are skipped here. 13771 13772 if Ekind (Subp) = E_Enumeration_Literal then 13773 null; 13774 13775 -- The actual is a direct descendant and the common primitive 13776 -- operations appear in the same order. 13777 13778 -- If the generic parent type is present, the derived type is an 13779 -- instance of a formal derived type, and within the instance its 13780 -- operations are those of the actual. We derive from the formal 13781 -- type but make the inherited operations aliases of the 13782 -- corresponding operations of the actual. 13783 13784 else 13785 pragma Assert (No (Node (Act_Elmt)) 13786 or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) 13787 and then 13788 Type_Conformant 13789 (Subp, Node (Act_Elmt), 13790 Skip_Controlling_Formals => True))); 13791 13792 Derive_Subprogram 13793 (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); 13794 13795 if Present (Act_Elmt) then 13796 Next_Elmt (Act_Elmt); 13797 end if; 13798 end if; 13799 13800 Next_Elmt (Elmt); 13801 end loop; 13802 13803 -- Case 2: Derived_Type implements interfaces 13804 13805 else 13806 -- If the parent type has no predefined primitives we remove 13807 -- predefined primitives from the list of primitives of generic 13808 -- actual to simplify the complexity of this algorithm. 13809 13810 if Present (Generic_Actual) then 13811 declare 13812 Has_Predefined_Primitives : Boolean := False; 13813 13814 begin 13815 -- Check if the parent type has predefined primitives 13816 13817 Elmt := First_Elmt (Op_List); 13818 while Present (Elmt) loop 13819 Subp := Node (Elmt); 13820 13821 if Is_Predefined_Dispatching_Operation (Subp) 13822 and then not Comes_From_Source (Ultimate_Alias (Subp)) 13823 then 13824 Has_Predefined_Primitives := True; 13825 exit; 13826 end if; 13827 13828 Next_Elmt (Elmt); 13829 end loop; 13830 13831 -- Remove predefined primitives of Generic_Actual. We must use 13832 -- an auxiliary list because in case of tagged types the value 13833 -- returned by Collect_Primitive_Operations is the value stored 13834 -- in its Primitive_Operations attribute (and we don't want to 13835 -- modify its current contents). 13836 13837 if not Has_Predefined_Primitives then 13838 declare 13839 Aux_List : constant Elist_Id := New_Elmt_List; 13840 13841 begin 13842 Elmt := First_Elmt (Act_List); 13843 while Present (Elmt) loop 13844 Subp := Node (Elmt); 13845 13846 if not Is_Predefined_Dispatching_Operation (Subp) 13847 or else Comes_From_Source (Subp) 13848 then 13849 Append_Elmt (Subp, Aux_List); 13850 end if; 13851 13852 Next_Elmt (Elmt); 13853 end loop; 13854 13855 Act_List := Aux_List; 13856 end; 13857 end if; 13858 13859 Act_Elmt := First_Elmt (Act_List); 13860 Act_Subp := Node (Act_Elmt); 13861 end; 13862 end if; 13863 13864 -- Stage 1: If the generic actual is not present we derive the 13865 -- primitives inherited from the parent type. If the generic parent 13866 -- type is present, the derived type is an instance of a formal 13867 -- derived type, and within the instance its operations are those of 13868 -- the actual. We derive from the formal type but make the inherited 13869 -- operations aliases of the corresponding operations of the actual. 13870 13871 Elmt := First_Elmt (Op_List); 13872 while Present (Elmt) loop 13873 Subp := Node (Elmt); 13874 Alias_Subp := Ultimate_Alias (Subp); 13875 13876 -- Do not derive internal entities of the parent that link 13877 -- interface primitives with their covering primitive. These 13878 -- entities will be added to this type when frozen. 13879 13880 if Present (Interface_Alias (Subp)) then 13881 goto Continue; 13882 end if; 13883 13884 -- If the generic actual is present find the corresponding 13885 -- operation in the generic actual. If the parent type is a 13886 -- direct ancestor of the derived type then, even if it is an 13887 -- interface, the operations are inherited from the primary 13888 -- dispatch table and are in the proper order. If we detect here 13889 -- that primitives are not in the same order we traverse the list 13890 -- of primitive operations of the actual to find the one that 13891 -- implements the interface primitive. 13892 13893 if Need_Search 13894 or else 13895 (Present (Generic_Actual) 13896 and then Present (Act_Subp) 13897 and then not 13898 (Primitive_Names_Match (Subp, Act_Subp) 13899 and then 13900 Type_Conformant (Subp, Act_Subp, 13901 Skip_Controlling_Formals => True))) 13902 then 13903 pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual, 13904 Use_Full_View => True)); 13905 13906 -- Remember that we need searching for all pending primitives 13907 13908 Need_Search := True; 13909 13910 -- Handle entities associated with interface primitives 13911 13912 if Present (Alias_Subp) 13913 and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) 13914 and then not Is_Predefined_Dispatching_Operation (Subp) 13915 then 13916 -- Search for the primitive in the homonym chain 13917 13918 Act_Subp := 13919 Find_Primitive_Covering_Interface 13920 (Tagged_Type => Generic_Actual, 13921 Iface_Prim => Alias_Subp); 13922 13923 -- Previous search may not locate primitives covering 13924 -- interfaces defined in generics units or instantiations. 13925 -- (it fails if the covering primitive has formals whose 13926 -- type is also defined in generics or instantiations). 13927 -- In such case we search in the list of primitives of the 13928 -- generic actual for the internal entity that links the 13929 -- interface primitive and the covering primitive. 13930 13931 if No (Act_Subp) 13932 and then Is_Generic_Type (Parent_Type) 13933 then 13934 -- This code has been designed to handle only generic 13935 -- formals that implement interfaces that are defined 13936 -- in a generic unit or instantiation. If this code is 13937 -- needed for other cases we must review it because 13938 -- (given that it relies on Original_Location to locate 13939 -- the primitive of Generic_Actual that covers the 13940 -- interface) it could leave linked through attribute 13941 -- Alias entities of unrelated instantiations). 13942 13943 pragma Assert 13944 (Is_Generic_Unit 13945 (Scope (Find_Dispatching_Type (Alias_Subp))) 13946 or else 13947 Instantiation_Depth 13948 (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); 13949 13950 declare 13951 Iface_Prim_Loc : constant Source_Ptr := 13952 Original_Location (Sloc (Alias_Subp)); 13953 13954 Elmt : Elmt_Id; 13955 Prim : Entity_Id; 13956 13957 begin 13958 Elmt := 13959 First_Elmt (Primitive_Operations (Generic_Actual)); 13960 13961 Search : while Present (Elmt) loop 13962 Prim := Node (Elmt); 13963 13964 if Present (Interface_Alias (Prim)) 13965 and then Original_Location 13966 (Sloc (Interface_Alias (Prim))) = 13967 Iface_Prim_Loc 13968 then 13969 Act_Subp := Alias (Prim); 13970 exit Search; 13971 end if; 13972 13973 Next_Elmt (Elmt); 13974 end loop Search; 13975 end; 13976 end if; 13977 13978 pragma Assert (Present (Act_Subp) 13979 or else Is_Abstract_Type (Generic_Actual) 13980 or else Serious_Errors_Detected > 0); 13981 13982 -- Handle predefined primitives plus the rest of user-defined 13983 -- primitives 13984 13985 else 13986 Act_Elmt := First_Elmt (Act_List); 13987 while Present (Act_Elmt) loop 13988 Act_Subp := Node (Act_Elmt); 13989 13990 exit when Primitive_Names_Match (Subp, Act_Subp) 13991 and then Type_Conformant 13992 (Subp, Act_Subp, 13993 Skip_Controlling_Formals => True) 13994 and then No (Interface_Alias (Act_Subp)); 13995 13996 Next_Elmt (Act_Elmt); 13997 end loop; 13998 13999 if No (Act_Elmt) then 14000 Act_Subp := Empty; 14001 end if; 14002 end if; 14003 end if; 14004 14005 -- Case 1: If the parent is a limited interface then it has the 14006 -- predefined primitives of synchronized interfaces. However, the 14007 -- actual type may be a non-limited type and hence it does not 14008 -- have such primitives. 14009 14010 if Present (Generic_Actual) 14011 and then not Present (Act_Subp) 14012 and then Is_Limited_Interface (Parent_Base) 14013 and then Is_Predefined_Interface_Primitive (Subp) 14014 then 14015 null; 14016 14017 -- Case 2: Inherit entities associated with interfaces that were 14018 -- not covered by the parent type. We exclude here null interface 14019 -- primitives because they do not need special management. 14020 14021 -- We also exclude interface operations that are renamings. If the 14022 -- subprogram is an explicit renaming of an interface primitive, 14023 -- it is a regular primitive operation, and the presence of its 14024 -- alias is not relevant: it has to be derived like any other 14025 -- primitive. 14026 14027 elsif Present (Alias (Subp)) 14028 and then Nkind (Unit_Declaration_Node (Subp)) /= 14029 N_Subprogram_Renaming_Declaration 14030 and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) 14031 and then not 14032 (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification 14033 and then Null_Present (Parent (Alias_Subp))) 14034 then 14035 -- If this is an abstract private type then we transfer the 14036 -- derivation of the interface primitive from the partial view 14037 -- to the full view. This is safe because all the interfaces 14038 -- must be visible in the partial view. Done to avoid adding 14039 -- a new interface derivation to the private part of the 14040 -- enclosing package; otherwise this new derivation would be 14041 -- decorated as hidden when the analysis of the enclosing 14042 -- package completes. 14043 14044 if Is_Abstract_Type (Derived_Type) 14045 and then In_Private_Part (Current_Scope) 14046 and then Has_Private_Declaration (Derived_Type) 14047 then 14048 declare 14049 Partial_View : Entity_Id; 14050 Elmt : Elmt_Id; 14051 Ent : Entity_Id; 14052 14053 begin 14054 Partial_View := First_Entity (Current_Scope); 14055 loop 14056 exit when No (Partial_View) 14057 or else (Has_Private_Declaration (Partial_View) 14058 and then 14059 Full_View (Partial_View) = Derived_Type); 14060 14061 Next_Entity (Partial_View); 14062 end loop; 14063 14064 -- If the partial view was not found then the source code 14065 -- has errors and the derivation is not needed. 14066 14067 if Present (Partial_View) then 14068 Elmt := 14069 First_Elmt (Primitive_Operations (Partial_View)); 14070 while Present (Elmt) loop 14071 Ent := Node (Elmt); 14072 14073 if Present (Alias (Ent)) 14074 and then Ultimate_Alias (Ent) = Alias (Subp) 14075 then 14076 Append_Elmt 14077 (Ent, Primitive_Operations (Derived_Type)); 14078 exit; 14079 end if; 14080 14081 Next_Elmt (Elmt); 14082 end loop; 14083 14084 -- If the interface primitive was not found in the 14085 -- partial view then this interface primitive was 14086 -- overridden. We add a derivation to activate in 14087 -- Derive_Progenitor_Subprograms the machinery to 14088 -- search for it. 14089 14090 if No (Elmt) then 14091 Derive_Interface_Subprogram 14092 (New_Subp => New_Subp, 14093 Subp => Subp, 14094 Actual_Subp => Act_Subp); 14095 end if; 14096 end if; 14097 end; 14098 else 14099 Derive_Interface_Subprogram 14100 (New_Subp => New_Subp, 14101 Subp => Subp, 14102 Actual_Subp => Act_Subp); 14103 end if; 14104 14105 -- Case 3: Common derivation 14106 14107 else 14108 Derive_Subprogram 14109 (New_Subp => New_Subp, 14110 Parent_Subp => Subp, 14111 Derived_Type => Derived_Type, 14112 Parent_Type => Parent_Base, 14113 Actual_Subp => Act_Subp); 14114 end if; 14115 14116 -- No need to update Act_Elm if we must search for the 14117 -- corresponding operation in the generic actual 14118 14119 if not Need_Search 14120 and then Present (Act_Elmt) 14121 then 14122 Next_Elmt (Act_Elmt); 14123 Act_Subp := Node (Act_Elmt); 14124 end if; 14125 14126 <<Continue>> 14127 Next_Elmt (Elmt); 14128 end loop; 14129 14130 -- Inherit additional operations from progenitors. If the derived 14131 -- type is a generic actual, there are not new primitive operations 14132 -- for the type because it has those of the actual, and therefore 14133 -- nothing needs to be done. The renamings generated above are not 14134 -- primitive operations, and their purpose is simply to make the 14135 -- proper operations visible within an instantiation. 14136 14137 if No (Generic_Actual) then 14138 Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); 14139 end if; 14140 end if; 14141 14142 -- Final check: Direct descendants must have their primitives in the 14143 -- same order. We exclude from this test untagged types and instances 14144 -- of formal derived types. We skip this test if we have already 14145 -- reported serious errors in the sources. 14146 14147 pragma Assert (not Is_Tagged_Type (Derived_Type) 14148 or else Present (Generic_Actual) 14149 or else Serious_Errors_Detected > 0 14150 or else Check_Derived_Type); 14151 end Derive_Subprograms; 14152 14153 -------------------------------- 14154 -- Derived_Standard_Character -- 14155 -------------------------------- 14156 14157 procedure Derived_Standard_Character 14158 (N : Node_Id; 14159 Parent_Type : Entity_Id; 14160 Derived_Type : Entity_Id) 14161 is 14162 Loc : constant Source_Ptr := Sloc (N); 14163 Def : constant Node_Id := Type_Definition (N); 14164 Indic : constant Node_Id := Subtype_Indication (Def); 14165 Parent_Base : constant Entity_Id := Base_Type (Parent_Type); 14166 Implicit_Base : constant Entity_Id := 14167 Create_Itype 14168 (E_Enumeration_Type, N, Derived_Type, 'B'); 14169 14170 Lo : Node_Id; 14171 Hi : Node_Id; 14172 14173 begin 14174 Discard_Node (Process_Subtype (Indic, N)); 14175 14176 Set_Etype (Implicit_Base, Parent_Base); 14177 Set_Size_Info (Implicit_Base, Root_Type (Parent_Type)); 14178 Set_RM_Size (Implicit_Base, RM_Size (Root_Type (Parent_Type))); 14179 14180 Set_Is_Character_Type (Implicit_Base, True); 14181 Set_Has_Delayed_Freeze (Implicit_Base); 14182 14183 -- The bounds of the implicit base are the bounds of the parent base. 14184 -- Note that their type is the parent base. 14185 14186 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base)); 14187 Hi := New_Copy_Tree (Type_High_Bound (Parent_Base)); 14188 14189 Set_Scalar_Range (Implicit_Base, 14190 Make_Range (Loc, 14191 Low_Bound => Lo, 14192 High_Bound => Hi)); 14193 14194 Conditional_Delay (Derived_Type, Parent_Type); 14195 14196 Set_Ekind (Derived_Type, E_Enumeration_Subtype); 14197 Set_Etype (Derived_Type, Implicit_Base); 14198 Set_Size_Info (Derived_Type, Parent_Type); 14199 14200 if Unknown_RM_Size (Derived_Type) then 14201 Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); 14202 end if; 14203 14204 Set_Is_Character_Type (Derived_Type, True); 14205 14206 if Nkind (Indic) /= N_Subtype_Indication then 14207 14208 -- If no explicit constraint, the bounds are those 14209 -- of the parent type. 14210 14211 Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type)); 14212 Hi := New_Copy_Tree (Type_High_Bound (Parent_Type)); 14213 Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi)); 14214 end if; 14215 14216 Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); 14217 14218 -- Because the implicit base is used in the conversion of the bounds, we 14219 -- have to freeze it now. This is similar to what is done for numeric 14220 -- types, and it equally suspicious, but otherwise a non-static bound 14221 -- will have a reference to an unfrozen type, which is rejected by Gigi 14222 -- (???). This requires specific care for definition of stream 14223 -- attributes. For details, see comments at the end of 14224 -- Build_Derived_Numeric_Type. 14225 14226 Freeze_Before (N, Implicit_Base); 14227 end Derived_Standard_Character; 14228 14229 ------------------------------ 14230 -- Derived_Type_Declaration -- 14231 ------------------------------ 14232 14233 procedure Derived_Type_Declaration 14234 (T : Entity_Id; 14235 N : Node_Id; 14236 Is_Completion : Boolean) 14237 is 14238 Parent_Type : Entity_Id; 14239 14240 function Comes_From_Generic (Typ : Entity_Id) return Boolean; 14241 -- Check whether the parent type is a generic formal, or derives 14242 -- directly or indirectly from one. 14243 14244 ------------------------ 14245 -- Comes_From_Generic -- 14246 ------------------------ 14247 14248 function Comes_From_Generic (Typ : Entity_Id) return Boolean is 14249 begin 14250 if Is_Generic_Type (Typ) then 14251 return True; 14252 14253 elsif Is_Generic_Type (Root_Type (Parent_Type)) then 14254 return True; 14255 14256 elsif Is_Private_Type (Typ) 14257 and then Present (Full_View (Typ)) 14258 and then Is_Generic_Type (Root_Type (Full_View (Typ))) 14259 then 14260 return True; 14261 14262 elsif Is_Generic_Actual_Type (Typ) then 14263 return True; 14264 14265 else 14266 return False; 14267 end if; 14268 end Comes_From_Generic; 14269 14270 -- Local variables 14271 14272 Def : constant Node_Id := Type_Definition (N); 14273 Iface_Def : Node_Id; 14274 Indic : constant Node_Id := Subtype_Indication (Def); 14275 Extension : constant Node_Id := Record_Extension_Part (Def); 14276 Parent_Node : Node_Id; 14277 Taggd : Boolean; 14278 14279 -- Start of processing for Derived_Type_Declaration 14280 14281 begin 14282 Parent_Type := Find_Type_Of_Subtype_Indic (Indic); 14283 14284 -- Ada 2005 (AI-251): In case of interface derivation check that the 14285 -- parent is also an interface. 14286 14287 if Interface_Present (Def) then 14288 Check_SPARK_Restriction ("interface is not allowed", Def); 14289 14290 if not Is_Interface (Parent_Type) then 14291 Diagnose_Interface (Indic, Parent_Type); 14292 14293 else 14294 Parent_Node := Parent (Base_Type (Parent_Type)); 14295 Iface_Def := Type_Definition (Parent_Node); 14296 14297 -- Ada 2005 (AI-251): Limited interfaces can only inherit from 14298 -- other limited interfaces. 14299 14300 if Limited_Present (Def) then 14301 if Limited_Present (Iface_Def) then 14302 null; 14303 14304 elsif Protected_Present (Iface_Def) then 14305 Error_Msg_NE 14306 ("descendant of& must be declared" 14307 & " as a protected interface", 14308 N, Parent_Type); 14309 14310 elsif Synchronized_Present (Iface_Def) then 14311 Error_Msg_NE 14312 ("descendant of& must be declared" 14313 & " as a synchronized interface", 14314 N, Parent_Type); 14315 14316 elsif Task_Present (Iface_Def) then 14317 Error_Msg_NE 14318 ("descendant of& must be declared as a task interface", 14319 N, Parent_Type); 14320 14321 else 14322 Error_Msg_N 14323 ("(Ada 2005) limited interface cannot " 14324 & "inherit from non-limited interface", Indic); 14325 end if; 14326 14327 -- Ada 2005 (AI-345): Non-limited interfaces can only inherit 14328 -- from non-limited or limited interfaces. 14329 14330 elsif not Protected_Present (Def) 14331 and then not Synchronized_Present (Def) 14332 and then not Task_Present (Def) 14333 then 14334 if Limited_Present (Iface_Def) then 14335 null; 14336 14337 elsif Protected_Present (Iface_Def) then 14338 Error_Msg_NE 14339 ("descendant of& must be declared" 14340 & " as a protected interface", 14341 N, Parent_Type); 14342 14343 elsif Synchronized_Present (Iface_Def) then 14344 Error_Msg_NE 14345 ("descendant of& must be declared" 14346 & " as a synchronized interface", 14347 N, Parent_Type); 14348 14349 elsif Task_Present (Iface_Def) then 14350 Error_Msg_NE 14351 ("descendant of& must be declared as a task interface", 14352 N, Parent_Type); 14353 else 14354 null; 14355 end if; 14356 end if; 14357 end if; 14358 end if; 14359 14360 if Is_Tagged_Type (Parent_Type) 14361 and then Is_Concurrent_Type (Parent_Type) 14362 and then not Is_Interface (Parent_Type) 14363 then 14364 Error_Msg_N 14365 ("parent type of a record extension cannot be " 14366 & "a synchronized tagged type (RM 3.9.1 (3/1))", N); 14367 Set_Etype (T, Any_Type); 14368 return; 14369 end if; 14370 14371 -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor 14372 -- interfaces 14373 14374 if Is_Tagged_Type (Parent_Type) 14375 and then Is_Non_Empty_List (Interface_List (Def)) 14376 then 14377 declare 14378 Intf : Node_Id; 14379 T : Entity_Id; 14380 14381 begin 14382 Intf := First (Interface_List (Def)); 14383 while Present (Intf) loop 14384 T := Find_Type_Of_Subtype_Indic (Intf); 14385 14386 if not Is_Interface (T) then 14387 Diagnose_Interface (Intf, T); 14388 14389 -- Check the rules of 3.9.4(12/2) and 7.5(2/2) that disallow 14390 -- a limited type from having a nonlimited progenitor. 14391 14392 elsif (Limited_Present (Def) 14393 or else (not Is_Interface (Parent_Type) 14394 and then Is_Limited_Type (Parent_Type))) 14395 and then not Is_Limited_Interface (T) 14396 then 14397 Error_Msg_NE 14398 ("progenitor interface& of limited type must be limited", 14399 N, T); 14400 end if; 14401 14402 Next (Intf); 14403 end loop; 14404 end; 14405 end if; 14406 14407 if Parent_Type = Any_Type 14408 or else Etype (Parent_Type) = Any_Type 14409 or else (Is_Class_Wide_Type (Parent_Type) 14410 and then Etype (Parent_Type) = T) 14411 then 14412 -- If Parent_Type is undefined or illegal, make new type into a 14413 -- subtype of Any_Type, and set a few attributes to prevent cascaded 14414 -- errors. If this is a self-definition, emit error now. 14415 14416 if T = Parent_Type 14417 or else T = Etype (Parent_Type) 14418 then 14419 Error_Msg_N ("type cannot be used in its own definition", Indic); 14420 end if; 14421 14422 Set_Ekind (T, Ekind (Parent_Type)); 14423 Set_Etype (T, Any_Type); 14424 Set_Scalar_Range (T, Scalar_Range (Any_Type)); 14425 14426 if Is_Tagged_Type (T) 14427 and then Is_Record_Type (T) 14428 then 14429 Set_Direct_Primitive_Operations (T, New_Elmt_List); 14430 end if; 14431 14432 return; 14433 end if; 14434 14435 -- Ada 2005 (AI-251): The case in which the parent of the full-view is 14436 -- an interface is special because the list of interfaces in the full 14437 -- view can be given in any order. For example: 14438 14439 -- type A is interface; 14440 -- type B is interface and A; 14441 -- type D is new B with private; 14442 -- private 14443 -- type D is new A and B with null record; -- 1 -- 14444 14445 -- In this case we perform the following transformation of -1-: 14446 14447 -- type D is new B and A with null record; 14448 14449 -- If the parent of the full-view covers the parent of the partial-view 14450 -- we have two possible cases: 14451 14452 -- 1) They have the same parent 14453 -- 2) The parent of the full-view implements some further interfaces 14454 14455 -- In both cases we do not need to perform the transformation. In the 14456 -- first case the source program is correct and the transformation is 14457 -- not needed; in the second case the source program does not fulfill 14458 -- the no-hidden interfaces rule (AI-396) and the error will be reported 14459 -- later. 14460 14461 -- This transformation not only simplifies the rest of the analysis of 14462 -- this type declaration but also simplifies the correct generation of 14463 -- the object layout to the expander. 14464 14465 if In_Private_Part (Current_Scope) 14466 and then Is_Interface (Parent_Type) 14467 then 14468 declare 14469 Iface : Node_Id; 14470 Partial_View : Entity_Id; 14471 Partial_View_Parent : Entity_Id; 14472 New_Iface : Node_Id; 14473 14474 begin 14475 -- Look for the associated private type declaration 14476 14477 Partial_View := First_Entity (Current_Scope); 14478 loop 14479 exit when No (Partial_View) 14480 or else (Has_Private_Declaration (Partial_View) 14481 and then Full_View (Partial_View) = T); 14482 14483 Next_Entity (Partial_View); 14484 end loop; 14485 14486 -- If the partial view was not found then the source code has 14487 -- errors and the transformation is not needed. 14488 14489 if Present (Partial_View) then 14490 Partial_View_Parent := Etype (Partial_View); 14491 14492 -- If the parent of the full-view covers the parent of the 14493 -- partial-view we have nothing else to do. 14494 14495 if Interface_Present_In_Ancestor 14496 (Parent_Type, Partial_View_Parent) 14497 then 14498 null; 14499 14500 -- Traverse the list of interfaces of the full-view to look 14501 -- for the parent of the partial-view and perform the tree 14502 -- transformation. 14503 14504 else 14505 Iface := First (Interface_List (Def)); 14506 while Present (Iface) loop 14507 if Etype (Iface) = Etype (Partial_View) then 14508 Rewrite (Subtype_Indication (Def), 14509 New_Copy (Subtype_Indication 14510 (Parent (Partial_View)))); 14511 14512 New_Iface := 14513 Make_Identifier (Sloc (N), Chars (Parent_Type)); 14514 Append (New_Iface, Interface_List (Def)); 14515 14516 -- Analyze the transformed code 14517 14518 Derived_Type_Declaration (T, N, Is_Completion); 14519 return; 14520 end if; 14521 14522 Next (Iface); 14523 end loop; 14524 end if; 14525 end if; 14526 end; 14527 end if; 14528 14529 -- Only composite types other than array types are allowed to have 14530 -- discriminants. In SPARK, no types are allowed to have discriminants. 14531 14532 if Present (Discriminant_Specifications (N)) then 14533 if (Is_Elementary_Type (Parent_Type) 14534 or else Is_Array_Type (Parent_Type)) 14535 and then not Error_Posted (N) 14536 then 14537 Error_Msg_N 14538 ("elementary or array type cannot have discriminants", 14539 Defining_Identifier (First (Discriminant_Specifications (N)))); 14540 Set_Has_Discriminants (T, False); 14541 else 14542 Check_SPARK_Restriction ("discriminant type is not allowed", N); 14543 end if; 14544 end if; 14545 14546 -- In Ada 83, a derived type defined in a package specification cannot 14547 -- be used for further derivation until the end of its visible part. 14548 -- Note that derivation in the private part of the package is allowed. 14549 14550 if Ada_Version = Ada_83 14551 and then Is_Derived_Type (Parent_Type) 14552 and then In_Visible_Part (Scope (Parent_Type)) 14553 then 14554 if Ada_Version = Ada_83 and then Comes_From_Source (Indic) then 14555 Error_Msg_N 14556 ("(Ada 83): premature use of type for derivation", Indic); 14557 end if; 14558 end if; 14559 14560 -- Check for early use of incomplete or private type 14561 14562 if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then 14563 Error_Msg_N ("premature derivation of incomplete type", Indic); 14564 return; 14565 14566 elsif (Is_Incomplete_Or_Private_Type (Parent_Type) 14567 and then not Comes_From_Generic (Parent_Type)) 14568 or else Has_Private_Component (Parent_Type) 14569 then 14570 -- The ancestor type of a formal type can be incomplete, in which 14571 -- case only the operations of the partial view are available in the 14572 -- generic. Subsequent checks may be required when the full view is 14573 -- analyzed to verify that a derivation from a tagged type has an 14574 -- extension. 14575 14576 if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then 14577 null; 14578 14579 elsif No (Underlying_Type (Parent_Type)) 14580 or else Has_Private_Component (Parent_Type) 14581 then 14582 Error_Msg_N 14583 ("premature derivation of derived or private type", Indic); 14584 14585 -- Flag the type itself as being in error, this prevents some 14586 -- nasty problems with subsequent uses of the malformed type. 14587 14588 Set_Error_Posted (T); 14589 14590 -- Check that within the immediate scope of an untagged partial 14591 -- view it's illegal to derive from the partial view if the 14592 -- full view is tagged. (7.3(7)) 14593 14594 -- We verify that the Parent_Type is a partial view by checking 14595 -- that it is not a Full_Type_Declaration (i.e. a private type or 14596 -- private extension declaration), to distinguish a partial view 14597 -- from a derivation from a private type which also appears as 14598 -- E_Private_Type. If the parent base type is not declared in an 14599 -- enclosing scope there is no need to check. 14600 14601 elsif Present (Full_View (Parent_Type)) 14602 and then Nkind (Parent (Parent_Type)) /= N_Full_Type_Declaration 14603 and then not Is_Tagged_Type (Parent_Type) 14604 and then Is_Tagged_Type (Full_View (Parent_Type)) 14605 and then In_Open_Scopes (Scope (Base_Type (Parent_Type))) 14606 then 14607 Error_Msg_N 14608 ("premature derivation from type with tagged full view", 14609 Indic); 14610 end if; 14611 end if; 14612 14613 -- Check that form of derivation is appropriate 14614 14615 Taggd := Is_Tagged_Type (Parent_Type); 14616 14617 -- Perhaps the parent type should be changed to the class-wide type's 14618 -- specific type in this case to prevent cascading errors ??? 14619 14620 if Present (Extension) and then Is_Class_Wide_Type (Parent_Type) then 14621 Error_Msg_N ("parent type must not be a class-wide type", Indic); 14622 return; 14623 end if; 14624 14625 if Present (Extension) and then not Taggd then 14626 Error_Msg_N 14627 ("type derived from untagged type cannot have extension", Indic); 14628 14629 elsif No (Extension) and then Taggd then 14630 14631 -- If this declaration is within a private part (or body) of a 14632 -- generic instantiation then the derivation is allowed (the parent 14633 -- type can only appear tagged in this case if it's a generic actual 14634 -- type, since it would otherwise have been rejected in the analysis 14635 -- of the generic template). 14636 14637 if not Is_Generic_Actual_Type (Parent_Type) 14638 or else In_Visible_Part (Scope (Parent_Type)) 14639 then 14640 if Is_Class_Wide_Type (Parent_Type) then 14641 Error_Msg_N 14642 ("parent type must not be a class-wide type", Indic); 14643 14644 -- Use specific type to prevent cascaded errors. 14645 14646 Parent_Type := Etype (Parent_Type); 14647 14648 else 14649 Error_Msg_N 14650 ("type derived from tagged type must have extension", Indic); 14651 end if; 14652 end if; 14653 end if; 14654 14655 -- AI-443: Synchronized formal derived types require a private 14656 -- extension. There is no point in checking the ancestor type or 14657 -- the progenitors since the construct is wrong to begin with. 14658 14659 if Ada_Version >= Ada_2005 14660 and then Is_Generic_Type (T) 14661 and then Present (Original_Node (N)) 14662 then 14663 declare 14664 Decl : constant Node_Id := Original_Node (N); 14665 14666 begin 14667 if Nkind (Decl) = N_Formal_Type_Declaration 14668 and then Nkind (Formal_Type_Definition (Decl)) = 14669 N_Formal_Derived_Type_Definition 14670 and then Synchronized_Present (Formal_Type_Definition (Decl)) 14671 and then No (Extension) 14672 14673 -- Avoid emitting a duplicate error message 14674 14675 and then not Error_Posted (Indic) 14676 then 14677 Error_Msg_N 14678 ("synchronized derived type must have extension", N); 14679 end if; 14680 end; 14681 end if; 14682 14683 if Null_Exclusion_Present (Def) 14684 and then not Is_Access_Type (Parent_Type) 14685 then 14686 Error_Msg_N ("null exclusion can only apply to an access type", N); 14687 end if; 14688 14689 -- Avoid deriving parent primitives of underlying record views 14690 14691 Build_Derived_Type (N, Parent_Type, T, Is_Completion, 14692 Derive_Subps => not Is_Underlying_Record_View (T)); 14693 14694 -- AI-419: The parent type of an explicitly limited derived type must 14695 -- be a limited type or a limited interface. 14696 14697 if Limited_Present (Def) then 14698 Set_Is_Limited_Record (T); 14699 14700 if Is_Interface (T) then 14701 Set_Is_Limited_Interface (T); 14702 end if; 14703 14704 if not Is_Limited_Type (Parent_Type) 14705 and then 14706 (not Is_Interface (Parent_Type) 14707 or else not Is_Limited_Interface (Parent_Type)) 14708 then 14709 -- AI05-0096: a derivation in the private part of an instance is 14710 -- legal if the generic formal is untagged limited, and the actual 14711 -- is non-limited. 14712 14713 if Is_Generic_Actual_Type (Parent_Type) 14714 and then In_Private_Part (Current_Scope) 14715 and then 14716 not Is_Tagged_Type 14717 (Generic_Parent_Type (Parent (Parent_Type))) 14718 then 14719 null; 14720 14721 else 14722 Error_Msg_NE 14723 ("parent type& of limited type must be limited", 14724 N, Parent_Type); 14725 end if; 14726 end if; 14727 end if; 14728 14729 -- In SPARK, there are no derived type definitions other than type 14730 -- extensions of tagged record types. 14731 14732 if No (Extension) then 14733 Check_SPARK_Restriction ("derived type is not allowed", N); 14734 end if; 14735 end Derived_Type_Declaration; 14736 14737 ------------------------ 14738 -- Diagnose_Interface -- 14739 ------------------------ 14740 14741 procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is 14742 begin 14743 if not Is_Interface (E) 14744 and then E /= Any_Type 14745 then 14746 Error_Msg_NE ("(Ada 2005) & must be an interface", N, E); 14747 end if; 14748 end Diagnose_Interface; 14749 14750 ---------------------------------- 14751 -- Enumeration_Type_Declaration -- 14752 ---------------------------------- 14753 14754 procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is 14755 Ev : Uint; 14756 L : Node_Id; 14757 R_Node : Node_Id; 14758 B_Node : Node_Id; 14759 14760 begin 14761 -- Create identifier node representing lower bound 14762 14763 B_Node := New_Node (N_Identifier, Sloc (Def)); 14764 L := First (Literals (Def)); 14765 Set_Chars (B_Node, Chars (L)); 14766 Set_Entity (B_Node, L); 14767 Set_Etype (B_Node, T); 14768 Set_Is_Static_Expression (B_Node, True); 14769 14770 R_Node := New_Node (N_Range, Sloc (Def)); 14771 Set_Low_Bound (R_Node, B_Node); 14772 14773 Set_Ekind (T, E_Enumeration_Type); 14774 Set_First_Literal (T, L); 14775 Set_Etype (T, T); 14776 Set_Is_Constrained (T); 14777 14778 Ev := Uint_0; 14779 14780 -- Loop through literals of enumeration type setting pos and rep values 14781 -- except that if the Ekind is already set, then it means the literal 14782 -- was already constructed (case of a derived type declaration and we 14783 -- should not disturb the Pos and Rep values. 14784 14785 while Present (L) loop 14786 if Ekind (L) /= E_Enumeration_Literal then 14787 Set_Ekind (L, E_Enumeration_Literal); 14788 Set_Enumeration_Pos (L, Ev); 14789 Set_Enumeration_Rep (L, Ev); 14790 Set_Is_Known_Valid (L, True); 14791 end if; 14792 14793 Set_Etype (L, T); 14794 New_Overloaded_Entity (L); 14795 Generate_Definition (L); 14796 Set_Convention (L, Convention_Intrinsic); 14797 14798 -- Case of character literal 14799 14800 if Nkind (L) = N_Defining_Character_Literal then 14801 Set_Is_Character_Type (T, True); 14802 14803 -- Check violation of No_Wide_Characters 14804 14805 if Restriction_Check_Required (No_Wide_Characters) then 14806 Get_Name_String (Chars (L)); 14807 14808 if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then 14809 Check_Restriction (No_Wide_Characters, L); 14810 end if; 14811 end if; 14812 end if; 14813 14814 Ev := Ev + 1; 14815 Next (L); 14816 end loop; 14817 14818 -- Now create a node representing upper bound 14819 14820 B_Node := New_Node (N_Identifier, Sloc (Def)); 14821 Set_Chars (B_Node, Chars (Last (Literals (Def)))); 14822 Set_Entity (B_Node, Last (Literals (Def))); 14823 Set_Etype (B_Node, T); 14824 Set_Is_Static_Expression (B_Node, True); 14825 14826 Set_High_Bound (R_Node, B_Node); 14827 14828 -- Initialize various fields of the type. Some of this information 14829 -- may be overwritten later through rep.clauses. 14830 14831 Set_Scalar_Range (T, R_Node); 14832 Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); 14833 Set_Enum_Esize (T); 14834 Set_Enum_Pos_To_Rep (T, Empty); 14835 14836 -- Set Discard_Names if configuration pragma set, or if there is 14837 -- a parameterless pragma in the current declarative region 14838 14839 if Global_Discard_Names or else Discard_Names (Scope (T)) then 14840 Set_Discard_Names (T); 14841 end if; 14842 14843 -- Process end label if there is one 14844 14845 if Present (Def) then 14846 Process_End_Label (Def, 'e', T); 14847 end if; 14848 end Enumeration_Type_Declaration; 14849 14850 --------------------------------- 14851 -- Expand_To_Stored_Constraint -- 14852 --------------------------------- 14853 14854 function Expand_To_Stored_Constraint 14855 (Typ : Entity_Id; 14856 Constraint : Elist_Id) return Elist_Id 14857 is 14858 Explicitly_Discriminated_Type : Entity_Id; 14859 Expansion : Elist_Id; 14860 Discriminant : Entity_Id; 14861 14862 function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id; 14863 -- Find the nearest type that actually specifies discriminants 14864 14865 --------------------------------- 14866 -- Type_With_Explicit_Discrims -- 14867 --------------------------------- 14868 14869 function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id is 14870 Typ : constant E := Base_Type (Id); 14871 14872 begin 14873 if Ekind (Typ) in Incomplete_Or_Private_Kind then 14874 if Present (Full_View (Typ)) then 14875 return Type_With_Explicit_Discrims (Full_View (Typ)); 14876 end if; 14877 14878 else 14879 if Has_Discriminants (Typ) then 14880 return Typ; 14881 end if; 14882 end if; 14883 14884 if Etype (Typ) = Typ then 14885 return Empty; 14886 elsif Has_Discriminants (Typ) then 14887 return Typ; 14888 else 14889 return Type_With_Explicit_Discrims (Etype (Typ)); 14890 end if; 14891 14892 end Type_With_Explicit_Discrims; 14893 14894 -- Start of processing for Expand_To_Stored_Constraint 14895 14896 begin 14897 if No (Constraint) 14898 or else Is_Empty_Elmt_List (Constraint) 14899 then 14900 return No_Elist; 14901 end if; 14902 14903 Explicitly_Discriminated_Type := Type_With_Explicit_Discrims (Typ); 14904 14905 if No (Explicitly_Discriminated_Type) then 14906 return No_Elist; 14907 end if; 14908 14909 Expansion := New_Elmt_List; 14910 14911 Discriminant := 14912 First_Stored_Discriminant (Explicitly_Discriminated_Type); 14913 while Present (Discriminant) loop 14914 Append_Elmt ( 14915 Get_Discriminant_Value ( 14916 Discriminant, Explicitly_Discriminated_Type, Constraint), 14917 Expansion); 14918 Next_Stored_Discriminant (Discriminant); 14919 end loop; 14920 14921 return Expansion; 14922 end Expand_To_Stored_Constraint; 14923 14924 --------------------------- 14925 -- Find_Hidden_Interface -- 14926 --------------------------- 14927 14928 function Find_Hidden_Interface 14929 (Src : Elist_Id; 14930 Dest : Elist_Id) return Entity_Id 14931 is 14932 Iface : Entity_Id; 14933 Iface_Elmt : Elmt_Id; 14934 14935 begin 14936 if Present (Src) and then Present (Dest) then 14937 Iface_Elmt := First_Elmt (Src); 14938 while Present (Iface_Elmt) loop 14939 Iface := Node (Iface_Elmt); 14940 14941 if Is_Interface (Iface) 14942 and then not Contain_Interface (Iface, Dest) 14943 then 14944 return Iface; 14945 end if; 14946 14947 Next_Elmt (Iface_Elmt); 14948 end loop; 14949 end if; 14950 14951 return Empty; 14952 end Find_Hidden_Interface; 14953 14954 -------------------- 14955 -- Find_Type_Name -- 14956 -------------------- 14957 14958 function Find_Type_Name (N : Node_Id) return Entity_Id is 14959 Id : constant Entity_Id := Defining_Identifier (N); 14960 Prev : Entity_Id; 14961 New_Id : Entity_Id; 14962 Prev_Par : Node_Id; 14963 14964 procedure Check_Duplicate_Aspects; 14965 -- Check that aspects specified in a completion have not been specified 14966 -- already in the partial view. Type_Invariant and others can be 14967 -- specified on either view but never on both. 14968 14969 procedure Tag_Mismatch; 14970 -- Diagnose a tagged partial view whose full view is untagged. 14971 -- We post the message on the full view, with a reference to 14972 -- the previous partial view. The partial view can be private 14973 -- or incomplete, and these are handled in a different manner, 14974 -- so we determine the position of the error message from the 14975 -- respective slocs of both. 14976 14977 ----------------------------- 14978 -- Check_Duplicate_Aspects -- 14979 ----------------------------- 14980 procedure Check_Duplicate_Aspects is 14981 Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par); 14982 Full_Aspects : constant List_Id := Aspect_Specifications (N); 14983 F_Spec, P_Spec : Node_Id; 14984 14985 begin 14986 if Present (Prev_Aspects) and then Present (Full_Aspects) then 14987 F_Spec := First (Full_Aspects); 14988 while Present (F_Spec) loop 14989 P_Spec := First (Prev_Aspects); 14990 while Present (P_Spec) loop 14991 if 14992 Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec)) 14993 then 14994 Error_Msg_N 14995 ("aspect already specified in private declaration", 14996 F_Spec); 14997 Remove (F_Spec); 14998 return; 14999 end if; 15000 15001 Next (P_Spec); 15002 end loop; 15003 15004 Next (F_Spec); 15005 end loop; 15006 end if; 15007 end Check_Duplicate_Aspects; 15008 15009 ------------------ 15010 -- Tag_Mismatch -- 15011 ------------------ 15012 15013 procedure Tag_Mismatch is 15014 begin 15015 if Sloc (Prev) < Sloc (Id) then 15016 if Ada_Version >= Ada_2012 15017 and then Nkind (N) = N_Private_Type_Declaration 15018 then 15019 Error_Msg_NE 15020 ("declaration of private } must be a tagged type ", Id, Prev); 15021 else 15022 Error_Msg_NE 15023 ("full declaration of } must be a tagged type ", Id, Prev); 15024 end if; 15025 else 15026 if Ada_Version >= Ada_2012 15027 and then Nkind (N) = N_Private_Type_Declaration 15028 then 15029 Error_Msg_NE 15030 ("declaration of private } must be a tagged type ", Prev, Id); 15031 else 15032 Error_Msg_NE 15033 ("full declaration of } must be a tagged type ", Prev, Id); 15034 end if; 15035 end if; 15036 end Tag_Mismatch; 15037 15038 -- Start of processing for Find_Type_Name 15039 15040 begin 15041 -- Find incomplete declaration, if one was given 15042 15043 Prev := Current_Entity_In_Scope (Id); 15044 15045 -- New type declaration 15046 15047 if No (Prev) then 15048 Enter_Name (Id); 15049 return Id; 15050 15051 -- Previous declaration exists 15052 15053 else 15054 Prev_Par := Parent (Prev); 15055 15056 -- Error if not incomplete/private case except if previous 15057 -- declaration is implicit, etc. Enter_Name will emit error if 15058 -- appropriate. 15059 15060 if not Is_Incomplete_Or_Private_Type (Prev) then 15061 Enter_Name (Id); 15062 New_Id := Id; 15063 15064 -- Check invalid completion of private or incomplete type 15065 15066 elsif not Nkind_In (N, N_Full_Type_Declaration, 15067 N_Task_Type_Declaration, 15068 N_Protected_Type_Declaration) 15069 and then 15070 (Ada_Version < Ada_2012 15071 or else not Is_Incomplete_Type (Prev) 15072 or else not Nkind_In (N, N_Private_Type_Declaration, 15073 N_Private_Extension_Declaration)) 15074 then 15075 -- Completion must be a full type declarations (RM 7.3(4)) 15076 15077 Error_Msg_Sloc := Sloc (Prev); 15078 Error_Msg_NE ("invalid completion of }", Id, Prev); 15079 15080 -- Set scope of Id to avoid cascaded errors. Entity is never 15081 -- examined again, except when saving globals in generics. 15082 15083 Set_Scope (Id, Current_Scope); 15084 New_Id := Id; 15085 15086 -- If this is a repeated incomplete declaration, no further 15087 -- checks are possible. 15088 15089 if Nkind (N) = N_Incomplete_Type_Declaration then 15090 return Prev; 15091 end if; 15092 15093 -- Case of full declaration of incomplete type 15094 15095 elsif Ekind (Prev) = E_Incomplete_Type 15096 and then (Ada_Version < Ada_2012 15097 or else No (Full_View (Prev)) 15098 or else not Is_Private_Type (Full_View (Prev))) 15099 then 15100 15101 -- Indicate that the incomplete declaration has a matching full 15102 -- declaration. The defining occurrence of the incomplete 15103 -- declaration remains the visible one, and the procedure 15104 -- Get_Full_View dereferences it whenever the type is used. 15105 15106 if Present (Full_View (Prev)) then 15107 Error_Msg_NE ("invalid redeclaration of }", Id, Prev); 15108 end if; 15109 15110 Set_Full_View (Prev, Id); 15111 Append_Entity (Id, Current_Scope); 15112 Set_Is_Public (Id, Is_Public (Prev)); 15113 Set_Is_Internal (Id); 15114 New_Id := Prev; 15115 15116 -- If the incomplete view is tagged, a class_wide type has been 15117 -- created already. Use it for the private type as well, in order 15118 -- to prevent multiple incompatible class-wide types that may be 15119 -- created for self-referential anonymous access components. 15120 15121 if Is_Tagged_Type (Prev) 15122 and then Present (Class_Wide_Type (Prev)) 15123 then 15124 Set_Ekind (Id, Ekind (Prev)); -- will be reset later 15125 Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); 15126 15127 -- If the incomplete type is completed by a private declaration 15128 -- the class-wide type remains associated with the incomplete 15129 -- type, to prevent order-of-elaboration issues in gigi, else 15130 -- we associate the class-wide type with the known full view. 15131 15132 if Nkind (N) /= N_Private_Type_Declaration then 15133 Set_Etype (Class_Wide_Type (Id), Id); 15134 end if; 15135 end if; 15136 15137 -- Case of full declaration of private type 15138 15139 else 15140 -- If the private type was a completion of an incomplete type then 15141 -- update Prev to reference the private type 15142 15143 if Ada_Version >= Ada_2012 15144 and then Ekind (Prev) = E_Incomplete_Type 15145 and then Present (Full_View (Prev)) 15146 and then Is_Private_Type (Full_View (Prev)) 15147 then 15148 Prev := Full_View (Prev); 15149 Prev_Par := Parent (Prev); 15150 end if; 15151 15152 if Nkind (Parent (Prev)) /= N_Private_Extension_Declaration then 15153 if Etype (Prev) /= Prev then 15154 15155 -- Prev is a private subtype or a derived type, and needs 15156 -- no completion. 15157 15158 Error_Msg_NE ("invalid redeclaration of }", Id, Prev); 15159 New_Id := Id; 15160 15161 elsif Ekind (Prev) = E_Private_Type 15162 and then Nkind_In (N, N_Task_Type_Declaration, 15163 N_Protected_Type_Declaration) 15164 then 15165 Error_Msg_N 15166 ("completion of nonlimited type cannot be limited", N); 15167 15168 elsif Ekind (Prev) = E_Record_Type_With_Private 15169 and then Nkind_In (N, N_Task_Type_Declaration, 15170 N_Protected_Type_Declaration) 15171 then 15172 if not Is_Limited_Record (Prev) then 15173 Error_Msg_N 15174 ("completion of nonlimited type cannot be limited", N); 15175 15176 elsif No (Interface_List (N)) then 15177 Error_Msg_N 15178 ("completion of tagged private type must be tagged", 15179 N); 15180 end if; 15181 15182 elsif Nkind (N) = N_Full_Type_Declaration 15183 and then 15184 Nkind (Type_Definition (N)) = N_Record_Definition 15185 and then Interface_Present (Type_Definition (N)) 15186 then 15187 Error_Msg_N 15188 ("completion of private type cannot be an interface", N); 15189 end if; 15190 15191 -- Ada 2005 (AI-251): Private extension declaration of a task 15192 -- type or a protected type. This case arises when covering 15193 -- interface types. 15194 15195 elsif Nkind_In (N, N_Task_Type_Declaration, 15196 N_Protected_Type_Declaration) 15197 then 15198 null; 15199 15200 elsif Nkind (N) /= N_Full_Type_Declaration 15201 or else Nkind (Type_Definition (N)) /= N_Derived_Type_Definition 15202 then 15203 Error_Msg_N 15204 ("full view of private extension must be an extension", N); 15205 15206 elsif not (Abstract_Present (Parent (Prev))) 15207 and then Abstract_Present (Type_Definition (N)) 15208 then 15209 Error_Msg_N 15210 ("full view of non-abstract extension cannot be abstract", N); 15211 end if; 15212 15213 if not In_Private_Part (Current_Scope) then 15214 Error_Msg_N 15215 ("declaration of full view must appear in private part", N); 15216 end if; 15217 15218 if Ada_Version >= Ada_2012 then 15219 Check_Duplicate_Aspects; 15220 end if; 15221 15222 Copy_And_Swap (Prev, Id); 15223 Set_Has_Private_Declaration (Prev); 15224 Set_Has_Private_Declaration (Id); 15225 15226 -- Preserve aspect and iterator flags that may have been set on 15227 -- the partial view. 15228 15229 Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id)); 15230 Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id)); 15231 15232 -- If no error, propagate freeze_node from private to full view. 15233 -- It may have been generated for an early operational item. 15234 15235 if Present (Freeze_Node (Id)) 15236 and then Serious_Errors_Detected = 0 15237 and then No (Full_View (Id)) 15238 then 15239 Set_Freeze_Node (Prev, Freeze_Node (Id)); 15240 Set_Freeze_Node (Id, Empty); 15241 Set_First_Rep_Item (Prev, First_Rep_Item (Id)); 15242 end if; 15243 15244 Set_Full_View (Id, Prev); 15245 New_Id := Prev; 15246 end if; 15247 15248 -- Verify that full declaration conforms to partial one 15249 15250 if Is_Incomplete_Or_Private_Type (Prev) 15251 and then Present (Discriminant_Specifications (Prev_Par)) 15252 then 15253 if Present (Discriminant_Specifications (N)) then 15254 if Ekind (Prev) = E_Incomplete_Type then 15255 Check_Discriminant_Conformance (N, Prev, Prev); 15256 else 15257 Check_Discriminant_Conformance (N, Prev, Id); 15258 end if; 15259 15260 else 15261 Error_Msg_N 15262 ("missing discriminants in full type declaration", N); 15263 15264 -- To avoid cascaded errors on subsequent use, share the 15265 -- discriminants of the partial view. 15266 15267 Set_Discriminant_Specifications (N, 15268 Discriminant_Specifications (Prev_Par)); 15269 end if; 15270 end if; 15271 15272 -- A prior untagged partial view can have an associated class-wide 15273 -- type due to use of the class attribute, and in this case the full 15274 -- type must also be tagged. This Ada 95 usage is deprecated in favor 15275 -- of incomplete tagged declarations, but we check for it. 15276 15277 if Is_Type (Prev) 15278 and then (Is_Tagged_Type (Prev) 15279 or else Present (Class_Wide_Type (Prev))) 15280 then 15281 -- Ada 2012 (AI05-0162): A private type may be the completion of 15282 -- an incomplete type 15283 15284 if Ada_Version >= Ada_2012 15285 and then Is_Incomplete_Type (Prev) 15286 and then Nkind_In (N, N_Private_Type_Declaration, 15287 N_Private_Extension_Declaration) 15288 then 15289 -- No need to check private extensions since they are tagged 15290 15291 if Nkind (N) = N_Private_Type_Declaration 15292 and then not Tagged_Present (N) 15293 then 15294 Tag_Mismatch; 15295 end if; 15296 15297 -- The full declaration is either a tagged type (including 15298 -- a synchronized type that implements interfaces) or a 15299 -- type extension, otherwise this is an error. 15300 15301 elsif Nkind_In (N, N_Task_Type_Declaration, 15302 N_Protected_Type_Declaration) 15303 then 15304 if No (Interface_List (N)) 15305 and then not Error_Posted (N) 15306 then 15307 Tag_Mismatch; 15308 end if; 15309 15310 elsif Nkind (Type_Definition (N)) = N_Record_Definition then 15311 15312 -- Indicate that the previous declaration (tagged incomplete 15313 -- or private declaration) requires the same on the full one. 15314 15315 if not Tagged_Present (Type_Definition (N)) then 15316 Tag_Mismatch; 15317 Set_Is_Tagged_Type (Id); 15318 end if; 15319 15320 elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then 15321 if No (Record_Extension_Part (Type_Definition (N))) then 15322 Error_Msg_NE 15323 ("full declaration of } must be a record extension", 15324 Prev, Id); 15325 15326 -- Set some attributes to produce a usable full view 15327 15328 Set_Is_Tagged_Type (Id); 15329 end if; 15330 15331 else 15332 Tag_Mismatch; 15333 end if; 15334 end if; 15335 15336 if Present (Prev) 15337 and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration 15338 and then Present (Premature_Use (Parent (Prev))) 15339 then 15340 Error_Msg_Sloc := Sloc (N); 15341 Error_Msg_N 15342 ("\full declaration #", Premature_Use (Parent (Prev))); 15343 end if; 15344 15345 return New_Id; 15346 end if; 15347 end Find_Type_Name; 15348 15349 ------------------------- 15350 -- Find_Type_Of_Object -- 15351 ------------------------- 15352 15353 function Find_Type_Of_Object 15354 (Obj_Def : Node_Id; 15355 Related_Nod : Node_Id) return Entity_Id 15356 is 15357 Def_Kind : constant Node_Kind := Nkind (Obj_Def); 15358 P : Node_Id := Parent (Obj_Def); 15359 T : Entity_Id; 15360 Nam : Name_Id; 15361 15362 begin 15363 -- If the parent is a component_definition node we climb to the 15364 -- component_declaration node 15365 15366 if Nkind (P) = N_Component_Definition then 15367 P := Parent (P); 15368 end if; 15369 15370 -- Case of an anonymous array subtype 15371 15372 if Nkind_In (Def_Kind, N_Constrained_Array_Definition, 15373 N_Unconstrained_Array_Definition) 15374 then 15375 T := Empty; 15376 Array_Type_Declaration (T, Obj_Def); 15377 15378 -- Create an explicit subtype whenever possible 15379 15380 elsif Nkind (P) /= N_Component_Declaration 15381 and then Def_Kind = N_Subtype_Indication 15382 then 15383 -- Base name of subtype on object name, which will be unique in 15384 -- the current scope. 15385 15386 -- If this is a duplicate declaration, return base type, to avoid 15387 -- generating duplicate anonymous types. 15388 15389 if Error_Posted (P) then 15390 Analyze (Subtype_Mark (Obj_Def)); 15391 return Entity (Subtype_Mark (Obj_Def)); 15392 end if; 15393 15394 Nam := 15395 New_External_Name 15396 (Chars (Defining_Identifier (Related_Nod)), 'S', 0, 'T'); 15397 15398 T := Make_Defining_Identifier (Sloc (P), Nam); 15399 15400 Insert_Action (Obj_Def, 15401 Make_Subtype_Declaration (Sloc (P), 15402 Defining_Identifier => T, 15403 Subtype_Indication => Relocate_Node (Obj_Def))); 15404 15405 -- This subtype may need freezing, and this will not be done 15406 -- automatically if the object declaration is not in declarative 15407 -- part. Since this is an object declaration, the type cannot always 15408 -- be frozen here. Deferred constants do not freeze their type 15409 -- (which often enough will be private). 15410 15411 if Nkind (P) = N_Object_Declaration 15412 and then Constant_Present (P) 15413 and then No (Expression (P)) 15414 then 15415 null; 15416 else 15417 Insert_Actions (Obj_Def, Freeze_Entity (T, P)); 15418 end if; 15419 15420 -- Ada 2005 AI-406: the object definition in an object declaration 15421 -- can be an access definition. 15422 15423 elsif Def_Kind = N_Access_Definition then 15424 T := Access_Definition (Related_Nod, Obj_Def); 15425 15426 Set_Is_Local_Anonymous_Access 15427 (T, 15428 V => (Ada_Version < Ada_2012) 15429 or else (Nkind (P) /= N_Object_Declaration) 15430 or else Is_Library_Level_Entity (Defining_Identifier (P))); 15431 15432 -- Otherwise, the object definition is just a subtype_mark 15433 15434 else 15435 T := Process_Subtype (Obj_Def, Related_Nod); 15436 15437 -- If expansion is disabled an object definition that is an aggregate 15438 -- will not get expanded and may lead to scoping problems in the back 15439 -- end, if the object is referenced in an inner scope. In that case 15440 -- create an itype reference for the object definition now. This 15441 -- may be redundant in some cases, but harmless. 15442 15443 if Is_Itype (T) 15444 and then Nkind (Related_Nod) = N_Object_Declaration 15445 and then ASIS_Mode 15446 then 15447 Build_Itype_Reference (T, Related_Nod); 15448 end if; 15449 end if; 15450 15451 return T; 15452 end Find_Type_Of_Object; 15453 15454 -------------------------------- 15455 -- Find_Type_Of_Subtype_Indic -- 15456 -------------------------------- 15457 15458 function Find_Type_Of_Subtype_Indic (S : Node_Id) return Entity_Id is 15459 Typ : Entity_Id; 15460 15461 begin 15462 -- Case of subtype mark with a constraint 15463 15464 if Nkind (S) = N_Subtype_Indication then 15465 Find_Type (Subtype_Mark (S)); 15466 Typ := Entity (Subtype_Mark (S)); 15467 15468 if not 15469 Is_Valid_Constraint_Kind (Ekind (Typ), Nkind (Constraint (S))) 15470 then 15471 Error_Msg_N 15472 ("incorrect constraint for this kind of type", Constraint (S)); 15473 Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); 15474 end if; 15475 15476 -- Otherwise we have a subtype mark without a constraint 15477 15478 elsif Error_Posted (S) then 15479 Rewrite (S, New_Occurrence_Of (Any_Id, Sloc (S))); 15480 return Any_Type; 15481 15482 else 15483 Find_Type (S); 15484 Typ := Entity (S); 15485 end if; 15486 15487 -- Check No_Wide_Characters restriction 15488 15489 Check_Wide_Character_Restriction (Typ, S); 15490 15491 return Typ; 15492 end Find_Type_Of_Subtype_Indic; 15493 15494 ------------------------------------- 15495 -- Floating_Point_Type_Declaration -- 15496 ------------------------------------- 15497 15498 procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is 15499 Digs : constant Node_Id := Digits_Expression (Def); 15500 Max_Digs_Val : constant Uint := Digits_Value (Standard_Long_Long_Float); 15501 Digs_Val : Uint; 15502 Base_Typ : Entity_Id; 15503 Implicit_Base : Entity_Id; 15504 Bound : Node_Id; 15505 15506 function Can_Derive_From (E : Entity_Id) return Boolean; 15507 -- Find if given digits value, and possibly a specified range, allows 15508 -- derivation from specified type 15509 15510 function Find_Base_Type return Entity_Id; 15511 -- Find a predefined base type that Def can derive from, or generate 15512 -- an error and substitute Long_Long_Float if none exists. 15513 15514 --------------------- 15515 -- Can_Derive_From -- 15516 --------------------- 15517 15518 function Can_Derive_From (E : Entity_Id) return Boolean is 15519 Spec : constant Entity_Id := Real_Range_Specification (Def); 15520 15521 begin 15522 -- Check specified "digits" constraint 15523 15524 if Digs_Val > Digits_Value (E) then 15525 return False; 15526 end if; 15527 15528 -- Avoid types not matching pragma Float_Representation, if present 15529 15530 if (Opt.Float_Format = 'I' and then Float_Rep (E) /= IEEE_Binary) 15531 or else 15532 (Opt.Float_Format = 'V' and then Float_Rep (E) /= VAX_Native) 15533 then 15534 return False; 15535 end if; 15536 15537 -- Check for matching range, if specified 15538 15539 if Present (Spec) then 15540 if Expr_Value_R (Type_Low_Bound (E)) > 15541 Expr_Value_R (Low_Bound (Spec)) 15542 then 15543 return False; 15544 end if; 15545 15546 if Expr_Value_R (Type_High_Bound (E)) < 15547 Expr_Value_R (High_Bound (Spec)) 15548 then 15549 return False; 15550 end if; 15551 end if; 15552 15553 return True; 15554 end Can_Derive_From; 15555 15556 -------------------- 15557 -- Find_Base_Type -- 15558 -------------------- 15559 15560 function Find_Base_Type return Entity_Id is 15561 Choice : Elmt_Id := First_Elmt (Predefined_Float_Types); 15562 15563 begin 15564 -- Iterate over the predefined types in order, returning the first 15565 -- one that Def can derive from. 15566 15567 while Present (Choice) loop 15568 if Can_Derive_From (Node (Choice)) then 15569 return Node (Choice); 15570 end if; 15571 15572 Next_Elmt (Choice); 15573 end loop; 15574 15575 -- If we can't derive from any existing type, use Long_Long_Float 15576 -- and give appropriate message explaining the problem. 15577 15578 if Digs_Val > Max_Digs_Val then 15579 -- It might be the case that there is a type with the requested 15580 -- range, just not the combination of digits and range. 15581 15582 Error_Msg_N 15583 ("no predefined type has requested range and precision", 15584 Real_Range_Specification (Def)); 15585 15586 else 15587 Error_Msg_N 15588 ("range too large for any predefined type", 15589 Real_Range_Specification (Def)); 15590 end if; 15591 15592 return Standard_Long_Long_Float; 15593 end Find_Base_Type; 15594 15595 -- Start of processing for Floating_Point_Type_Declaration 15596 15597 begin 15598 Check_Restriction (No_Floating_Point, Def); 15599 15600 -- Create an implicit base type 15601 15602 Implicit_Base := 15603 Create_Itype (E_Floating_Point_Type, Parent (Def), T, 'B'); 15604 15605 -- Analyze and verify digits value 15606 15607 Analyze_And_Resolve (Digs, Any_Integer); 15608 Check_Digits_Expression (Digs); 15609 Digs_Val := Expr_Value (Digs); 15610 15611 -- Process possible range spec and find correct type to derive from 15612 15613 Process_Real_Range_Specification (Def); 15614 15615 -- Check that requested number of digits is not too high. 15616 15617 if Digs_Val > Max_Digs_Val then 15618 -- The check for Max_Base_Digits may be somewhat expensive, as it 15619 -- requires reading System, so only do it when necessary. 15620 15621 declare 15622 Max_Base_Digits : constant Uint := 15623 Expr_Value 15624 (Expression 15625 (Parent (RTE (RE_Max_Base_Digits)))); 15626 15627 begin 15628 if Digs_Val > Max_Base_Digits then 15629 Error_Msg_Uint_1 := Max_Base_Digits; 15630 Error_Msg_N ("digits value out of range, maximum is ^", Digs); 15631 15632 elsif No (Real_Range_Specification (Def)) then 15633 Error_Msg_Uint_1 := Max_Digs_Val; 15634 Error_Msg_N ("types with more than ^ digits need range spec " 15635 & "(RM 3.5.7(6))", Digs); 15636 end if; 15637 end; 15638 end if; 15639 15640 -- Find a suitable type to derive from or complain and use a substitute 15641 15642 Base_Typ := Find_Base_Type; 15643 15644 -- If there are bounds given in the declaration use them as the bounds 15645 -- of the type, otherwise use the bounds of the predefined base type 15646 -- that was chosen based on the Digits value. 15647 15648 if Present (Real_Range_Specification (Def)) then 15649 Set_Scalar_Range (T, Real_Range_Specification (Def)); 15650 Set_Is_Constrained (T); 15651 15652 -- The bounds of this range must be converted to machine numbers 15653 -- in accordance with RM 4.9(38). 15654 15655 Bound := Type_Low_Bound (T); 15656 15657 if Nkind (Bound) = N_Real_Literal then 15658 Set_Realval 15659 (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); 15660 Set_Is_Machine_Number (Bound); 15661 end if; 15662 15663 Bound := Type_High_Bound (T); 15664 15665 if Nkind (Bound) = N_Real_Literal then 15666 Set_Realval 15667 (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); 15668 Set_Is_Machine_Number (Bound); 15669 end if; 15670 15671 else 15672 Set_Scalar_Range (T, Scalar_Range (Base_Typ)); 15673 end if; 15674 15675 -- Complete definition of implicit base and declared first subtype 15676 15677 Set_Etype (Implicit_Base, Base_Typ); 15678 15679 Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); 15680 Set_Size_Info (Implicit_Base, (Base_Typ)); 15681 Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); 15682 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); 15683 Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); 15684 Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); 15685 15686 Set_Ekind (T, E_Floating_Point_Subtype); 15687 Set_Etype (T, Implicit_Base); 15688 15689 Set_Size_Info (T, (Implicit_Base)); 15690 Set_RM_Size (T, RM_Size (Implicit_Base)); 15691 Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); 15692 Set_Digits_Value (T, Digs_Val); 15693 end Floating_Point_Type_Declaration; 15694 15695 ---------------------------- 15696 -- Get_Discriminant_Value -- 15697 ---------------------------- 15698 15699 -- This is the situation: 15700 15701 -- There is a non-derived type 15702 15703 -- type T0 (Dx, Dy, Dz...) 15704 15705 -- There are zero or more levels of derivation, with each derivation 15706 -- either purely inheriting the discriminants, or defining its own. 15707 15708 -- type Ti is new Ti-1 15709 -- or 15710 -- type Ti (Dw) is new Ti-1(Dw, 1, X+Y) 15711 -- or 15712 -- subtype Ti is ... 15713 15714 -- The subtype issue is avoided by the use of Original_Record_Component, 15715 -- and the fact that derived subtypes also derive the constraints. 15716 15717 -- This chain leads back from 15718 15719 -- Typ_For_Constraint 15720 15721 -- Typ_For_Constraint has discriminants, and the value for each 15722 -- discriminant is given by its corresponding Elmt of Constraints. 15723 15724 -- Discriminant is some discriminant in this hierarchy 15725 15726 -- We need to return its value 15727 15728 -- We do this by recursively searching each level, and looking for 15729 -- Discriminant. Once we get to the bottom, we start backing up 15730 -- returning the value for it which may in turn be a discriminant 15731 -- further up, so on the backup we continue the substitution. 15732 15733 function Get_Discriminant_Value 15734 (Discriminant : Entity_Id; 15735 Typ_For_Constraint : Entity_Id; 15736 Constraint : Elist_Id) return Node_Id 15737 is 15738 function Root_Corresponding_Discriminant 15739 (Discr : Entity_Id) return Entity_Id; 15740 -- Given a discriminant, traverse the chain of inherited discriminants 15741 -- and return the topmost discriminant. 15742 15743 function Search_Derivation_Levels 15744 (Ti : Entity_Id; 15745 Discrim_Values : Elist_Id; 15746 Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id; 15747 -- This is the routine that performs the recursive search of levels 15748 -- as described above. 15749 15750 ------------------------------------- 15751 -- Root_Corresponding_Discriminant -- 15752 ------------------------------------- 15753 15754 function Root_Corresponding_Discriminant 15755 (Discr : Entity_Id) return Entity_Id 15756 is 15757 D : Entity_Id; 15758 15759 begin 15760 D := Discr; 15761 while Present (Corresponding_Discriminant (D)) loop 15762 D := Corresponding_Discriminant (D); 15763 end loop; 15764 15765 return D; 15766 end Root_Corresponding_Discriminant; 15767 15768 ------------------------------ 15769 -- Search_Derivation_Levels -- 15770 ------------------------------ 15771 15772 function Search_Derivation_Levels 15773 (Ti : Entity_Id; 15774 Discrim_Values : Elist_Id; 15775 Stored_Discrim_Values : Boolean) return Node_Or_Entity_Id 15776 is 15777 Assoc : Elmt_Id; 15778 Disc : Entity_Id; 15779 Result : Node_Or_Entity_Id; 15780 Result_Entity : Node_Id; 15781 15782 begin 15783 -- If inappropriate type, return Error, this happens only in 15784 -- cascaded error situations, and we want to avoid a blow up. 15785 15786 if not Is_Composite_Type (Ti) or else Is_Array_Type (Ti) then 15787 return Error; 15788 end if; 15789 15790 -- Look deeper if possible. Use Stored_Constraints only for 15791 -- untagged types. For tagged types use the given constraint. 15792 -- This asymmetry needs explanation??? 15793 15794 if not Stored_Discrim_Values 15795 and then Present (Stored_Constraint (Ti)) 15796 and then not Is_Tagged_Type (Ti) 15797 then 15798 Result := 15799 Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True); 15800 else 15801 declare 15802 Td : constant Entity_Id := Etype (Ti); 15803 15804 begin 15805 if Td = Ti then 15806 Result := Discriminant; 15807 15808 else 15809 if Present (Stored_Constraint (Ti)) then 15810 Result := 15811 Search_Derivation_Levels 15812 (Td, Stored_Constraint (Ti), True); 15813 else 15814 Result := 15815 Search_Derivation_Levels 15816 (Td, Discrim_Values, Stored_Discrim_Values); 15817 end if; 15818 end if; 15819 end; 15820 end if; 15821 15822 -- Extra underlying places to search, if not found above. For 15823 -- concurrent types, the relevant discriminant appears in the 15824 -- corresponding record. For a type derived from a private type 15825 -- without discriminant, the full view inherits the discriminants 15826 -- of the full view of the parent. 15827 15828 if Result = Discriminant then 15829 if Is_Concurrent_Type (Ti) 15830 and then Present (Corresponding_Record_Type (Ti)) 15831 then 15832 Result := 15833 Search_Derivation_Levels ( 15834 Corresponding_Record_Type (Ti), 15835 Discrim_Values, 15836 Stored_Discrim_Values); 15837 15838 elsif Is_Private_Type (Ti) 15839 and then not Has_Discriminants (Ti) 15840 and then Present (Full_View (Ti)) 15841 and then Etype (Full_View (Ti)) /= Ti 15842 then 15843 Result := 15844 Search_Derivation_Levels ( 15845 Full_View (Ti), 15846 Discrim_Values, 15847 Stored_Discrim_Values); 15848 end if; 15849 end if; 15850 15851 -- If Result is not a (reference to a) discriminant, return it, 15852 -- otherwise set Result_Entity to the discriminant. 15853 15854 if Nkind (Result) = N_Defining_Identifier then 15855 pragma Assert (Result = Discriminant); 15856 Result_Entity := Result; 15857 15858 else 15859 if not Denotes_Discriminant (Result) then 15860 return Result; 15861 end if; 15862 15863 Result_Entity := Entity (Result); 15864 end if; 15865 15866 -- See if this level of derivation actually has discriminants 15867 -- because tagged derivations can add them, hence the lower 15868 -- levels need not have any. 15869 15870 if not Has_Discriminants (Ti) then 15871 return Result; 15872 end if; 15873 15874 -- Scan Ti's discriminants for Result_Entity, 15875 -- and return its corresponding value, if any. 15876 15877 Result_Entity := Original_Record_Component (Result_Entity); 15878 15879 Assoc := First_Elmt (Discrim_Values); 15880 15881 if Stored_Discrim_Values then 15882 Disc := First_Stored_Discriminant (Ti); 15883 else 15884 Disc := First_Discriminant (Ti); 15885 end if; 15886 15887 while Present (Disc) loop 15888 pragma Assert (Present (Assoc)); 15889 15890 if Original_Record_Component (Disc) = Result_Entity then 15891 return Node (Assoc); 15892 end if; 15893 15894 Next_Elmt (Assoc); 15895 15896 if Stored_Discrim_Values then 15897 Next_Stored_Discriminant (Disc); 15898 else 15899 Next_Discriminant (Disc); 15900 end if; 15901 end loop; 15902 15903 -- Could not find it 15904 -- 15905 return Result; 15906 end Search_Derivation_Levels; 15907 15908 -- Local Variables 15909 15910 Result : Node_Or_Entity_Id; 15911 15912 -- Start of processing for Get_Discriminant_Value 15913 15914 begin 15915 -- ??? This routine is a gigantic mess and will be deleted. For the 15916 -- time being just test for the trivial case before calling recurse. 15917 15918 if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then 15919 declare 15920 D : Entity_Id; 15921 E : Elmt_Id; 15922 15923 begin 15924 D := First_Discriminant (Typ_For_Constraint); 15925 E := First_Elmt (Constraint); 15926 while Present (D) loop 15927 if Chars (D) = Chars (Discriminant) then 15928 return Node (E); 15929 end if; 15930 15931 Next_Discriminant (D); 15932 Next_Elmt (E); 15933 end loop; 15934 end; 15935 end if; 15936 15937 Result := Search_Derivation_Levels 15938 (Typ_For_Constraint, Constraint, False); 15939 15940 -- ??? hack to disappear when this routine is gone 15941 15942 if Nkind (Result) = N_Defining_Identifier then 15943 declare 15944 D : Entity_Id; 15945 E : Elmt_Id; 15946 15947 begin 15948 D := First_Discriminant (Typ_For_Constraint); 15949 E := First_Elmt (Constraint); 15950 while Present (D) loop 15951 if Root_Corresponding_Discriminant (D) = Discriminant then 15952 return Node (E); 15953 end if; 15954 15955 Next_Discriminant (D); 15956 Next_Elmt (E); 15957 end loop; 15958 end; 15959 end if; 15960 15961 pragma Assert (Nkind (Result) /= N_Defining_Identifier); 15962 return Result; 15963 end Get_Discriminant_Value; 15964 15965 -------------------------- 15966 -- Has_Range_Constraint -- 15967 -------------------------- 15968 15969 function Has_Range_Constraint (N : Node_Id) return Boolean is 15970 C : constant Node_Id := Constraint (N); 15971 15972 begin 15973 if Nkind (C) = N_Range_Constraint then 15974 return True; 15975 15976 elsif Nkind (C) = N_Digits_Constraint then 15977 return 15978 Is_Decimal_Fixed_Point_Type (Entity (Subtype_Mark (N))) 15979 or else 15980 Present (Range_Constraint (C)); 15981 15982 elsif Nkind (C) = N_Delta_Constraint then 15983 return Present (Range_Constraint (C)); 15984 15985 else 15986 return False; 15987 end if; 15988 end Has_Range_Constraint; 15989 15990 ------------------------ 15991 -- Inherit_Components -- 15992 ------------------------ 15993 15994 function Inherit_Components 15995 (N : Node_Id; 15996 Parent_Base : Entity_Id; 15997 Derived_Base : Entity_Id; 15998 Is_Tagged : Boolean; 15999 Inherit_Discr : Boolean; 16000 Discs : Elist_Id) return Elist_Id 16001 is 16002 Assoc_List : constant Elist_Id := New_Elmt_List; 16003 16004 procedure Inherit_Component 16005 (Old_C : Entity_Id; 16006 Plain_Discrim : Boolean := False; 16007 Stored_Discrim : Boolean := False); 16008 -- Inherits component Old_C from Parent_Base to the Derived_Base. If 16009 -- Plain_Discrim is True, Old_C is a discriminant. If Stored_Discrim is 16010 -- True, Old_C is a stored discriminant. If they are both false then 16011 -- Old_C is a regular component. 16012 16013 ----------------------- 16014 -- Inherit_Component -- 16015 ----------------------- 16016 16017 procedure Inherit_Component 16018 (Old_C : Entity_Id; 16019 Plain_Discrim : Boolean := False; 16020 Stored_Discrim : Boolean := False) 16021 is 16022 procedure Set_Anonymous_Type (Id : Entity_Id); 16023 -- Id denotes the entity of an access discriminant or anonymous 16024 -- access component. Set the type of Id to either the same type of 16025 -- Old_C or create a new one depending on whether the parent and 16026 -- the child types are in the same scope. 16027 16028 ------------------------ 16029 -- Set_Anonymous_Type -- 16030 ------------------------ 16031 16032 procedure Set_Anonymous_Type (Id : Entity_Id) is 16033 Old_Typ : constant Entity_Id := Etype (Old_C); 16034 16035 begin 16036 if Scope (Parent_Base) = Scope (Derived_Base) then 16037 Set_Etype (Id, Old_Typ); 16038 16039 -- The parent and the derived type are in two different scopes. 16040 -- Reuse the type of the original discriminant / component by 16041 -- copying it in order to preserve all attributes. 16042 16043 else 16044 declare 16045 Typ : constant Entity_Id := New_Copy (Old_Typ); 16046 16047 begin 16048 Set_Etype (Id, Typ); 16049 16050 -- Since we do not generate component declarations for 16051 -- inherited components, associate the itype with the 16052 -- derived type. 16053 16054 Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base)); 16055 Set_Scope (Typ, Derived_Base); 16056 end; 16057 end if; 16058 end Set_Anonymous_Type; 16059 16060 -- Local variables and constants 16061 16062 New_C : constant Entity_Id := New_Copy (Old_C); 16063 16064 Corr_Discrim : Entity_Id; 16065 Discrim : Entity_Id; 16066 16067 -- Start of processing for Inherit_Component 16068 16069 begin 16070 pragma Assert (not Is_Tagged or else not Stored_Discrim); 16071 16072 Set_Parent (New_C, Parent (Old_C)); 16073 16074 -- Regular discriminants and components must be inserted in the scope 16075 -- of the Derived_Base. Do it here. 16076 16077 if not Stored_Discrim then 16078 Enter_Name (New_C); 16079 end if; 16080 16081 -- For tagged types the Original_Record_Component must point to 16082 -- whatever this field was pointing to in the parent type. This has 16083 -- already been achieved by the call to New_Copy above. 16084 16085 if not Is_Tagged then 16086 Set_Original_Record_Component (New_C, New_C); 16087 end if; 16088 16089 -- Set the proper type of an access discriminant 16090 16091 if Ekind (New_C) = E_Discriminant 16092 and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type 16093 then 16094 Set_Anonymous_Type (New_C); 16095 end if; 16096 16097 -- If we have inherited a component then see if its Etype contains 16098 -- references to Parent_Base discriminants. In this case, replace 16099 -- these references with the constraints given in Discs. We do not 16100 -- do this for the partial view of private types because this is 16101 -- not needed (only the components of the full view will be used 16102 -- for code generation) and cause problem. We also avoid this 16103 -- transformation in some error situations. 16104 16105 if Ekind (New_C) = E_Component then 16106 16107 -- Set the proper type of an anonymous access component 16108 16109 if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then 16110 Set_Anonymous_Type (New_C); 16111 16112 elsif (Is_Private_Type (Derived_Base) 16113 and then not Is_Generic_Type (Derived_Base)) 16114 or else (Is_Empty_Elmt_List (Discs) 16115 and then not Expander_Active) 16116 then 16117 Set_Etype (New_C, Etype (Old_C)); 16118 16119 else 16120 -- The current component introduces a circularity of the 16121 -- following kind: 16122 16123 -- limited with Pack_2; 16124 -- package Pack_1 is 16125 -- type T_1 is tagged record 16126 -- Comp : access Pack_2.T_2; 16127 -- ... 16128 -- end record; 16129 -- end Pack_1; 16130 16131 -- with Pack_1; 16132 -- package Pack_2 is 16133 -- type T_2 is new Pack_1.T_1 with ...; 16134 -- end Pack_2; 16135 16136 Set_Etype 16137 (New_C, 16138 Constrain_Component_Type 16139 (Old_C, Derived_Base, N, Parent_Base, Discs)); 16140 end if; 16141 end if; 16142 16143 -- In derived tagged types it is illegal to reference a non 16144 -- discriminant component in the parent type. To catch this, mark 16145 -- these components with an Ekind of E_Void. This will be reset in 16146 -- Record_Type_Definition after processing the record extension of 16147 -- the derived type. 16148 16149 -- If the declaration is a private extension, there is no further 16150 -- record extension to process, and the components retain their 16151 -- current kind, because they are visible at this point. 16152 16153 if Is_Tagged and then Ekind (New_C) = E_Component 16154 and then Nkind (N) /= N_Private_Extension_Declaration 16155 then 16156 Set_Ekind (New_C, E_Void); 16157 end if; 16158 16159 if Plain_Discrim then 16160 Set_Corresponding_Discriminant (New_C, Old_C); 16161 Build_Discriminal (New_C); 16162 16163 -- If we are explicitly inheriting a stored discriminant it will be 16164 -- completely hidden. 16165 16166 elsif Stored_Discrim then 16167 Set_Corresponding_Discriminant (New_C, Empty); 16168 Set_Discriminal (New_C, Empty); 16169 Set_Is_Completely_Hidden (New_C); 16170 16171 -- Set the Original_Record_Component of each discriminant in the 16172 -- derived base to point to the corresponding stored that we just 16173 -- created. 16174 16175 Discrim := First_Discriminant (Derived_Base); 16176 while Present (Discrim) loop 16177 Corr_Discrim := Corresponding_Discriminant (Discrim); 16178 16179 -- Corr_Discrim could be missing in an error situation 16180 16181 if Present (Corr_Discrim) 16182 and then Original_Record_Component (Corr_Discrim) = Old_C 16183 then 16184 Set_Original_Record_Component (Discrim, New_C); 16185 end if; 16186 16187 Next_Discriminant (Discrim); 16188 end loop; 16189 16190 Append_Entity (New_C, Derived_Base); 16191 end if; 16192 16193 if not Is_Tagged then 16194 Append_Elmt (Old_C, Assoc_List); 16195 Append_Elmt (New_C, Assoc_List); 16196 end if; 16197 end Inherit_Component; 16198 16199 -- Variables local to Inherit_Component 16200 16201 Loc : constant Source_Ptr := Sloc (N); 16202 16203 Parent_Discrim : Entity_Id; 16204 Stored_Discrim : Entity_Id; 16205 D : Entity_Id; 16206 Component : Entity_Id; 16207 16208 -- Start of processing for Inherit_Components 16209 16210 begin 16211 if not Is_Tagged then 16212 Append_Elmt (Parent_Base, Assoc_List); 16213 Append_Elmt (Derived_Base, Assoc_List); 16214 end if; 16215 16216 -- Inherit parent discriminants if needed 16217 16218 if Inherit_Discr then 16219 Parent_Discrim := First_Discriminant (Parent_Base); 16220 while Present (Parent_Discrim) loop 16221 Inherit_Component (Parent_Discrim, Plain_Discrim => True); 16222 Next_Discriminant (Parent_Discrim); 16223 end loop; 16224 end if; 16225 16226 -- Create explicit stored discrims for untagged types when necessary 16227 16228 if not Has_Unknown_Discriminants (Derived_Base) 16229 and then Has_Discriminants (Parent_Base) 16230 and then not Is_Tagged 16231 and then 16232 (not Inherit_Discr 16233 or else First_Discriminant (Parent_Base) /= 16234 First_Stored_Discriminant (Parent_Base)) 16235 then 16236 Stored_Discrim := First_Stored_Discriminant (Parent_Base); 16237 while Present (Stored_Discrim) loop 16238 Inherit_Component (Stored_Discrim, Stored_Discrim => True); 16239 Next_Stored_Discriminant (Stored_Discrim); 16240 end loop; 16241 end if; 16242 16243 -- See if we can apply the second transformation for derived types, as 16244 -- explained in point 6. in the comments above Build_Derived_Record_Type 16245 -- This is achieved by appending Derived_Base discriminants into Discs, 16246 -- which has the side effect of returning a non empty Discs list to the 16247 -- caller of Inherit_Components, which is what we want. This must be 16248 -- done for private derived types if there are explicit stored 16249 -- discriminants, to ensure that we can retrieve the values of the 16250 -- constraints provided in the ancestors. 16251 16252 if Inherit_Discr 16253 and then Is_Empty_Elmt_List (Discs) 16254 and then Present (First_Discriminant (Derived_Base)) 16255 and then 16256 (not Is_Private_Type (Derived_Base) 16257 or else Is_Completely_Hidden 16258 (First_Stored_Discriminant (Derived_Base)) 16259 or else Is_Generic_Type (Derived_Base)) 16260 then 16261 D := First_Discriminant (Derived_Base); 16262 while Present (D) loop 16263 Append_Elmt (New_Reference_To (D, Loc), Discs); 16264 Next_Discriminant (D); 16265 end loop; 16266 end if; 16267 16268 -- Finally, inherit non-discriminant components unless they are not 16269 -- visible because defined or inherited from the full view of the 16270 -- parent. Don't inherit the _parent field of the parent type. 16271 16272 Component := First_Entity (Parent_Base); 16273 while Present (Component) loop 16274 16275 -- Ada 2005 (AI-251): Do not inherit components associated with 16276 -- secondary tags of the parent. 16277 16278 if Ekind (Component) = E_Component 16279 and then Present (Related_Type (Component)) 16280 then 16281 null; 16282 16283 elsif Ekind (Component) /= E_Component 16284 or else Chars (Component) = Name_uParent 16285 then 16286 null; 16287 16288 -- If the derived type is within the parent type's declarative 16289 -- region, then the components can still be inherited even though 16290 -- they aren't visible at this point. This can occur for cases 16291 -- such as within public child units where the components must 16292 -- become visible upon entering the child unit's private part. 16293 16294 elsif not Is_Visible_Component (Component) 16295 and then not In_Open_Scopes (Scope (Parent_Base)) 16296 then 16297 null; 16298 16299 elsif Ekind_In (Derived_Base, E_Private_Type, 16300 E_Limited_Private_Type) 16301 then 16302 null; 16303 16304 else 16305 Inherit_Component (Component); 16306 end if; 16307 16308 Next_Entity (Component); 16309 end loop; 16310 16311 -- For tagged derived types, inherited discriminants cannot be used in 16312 -- component declarations of the record extension part. To achieve this 16313 -- we mark the inherited discriminants as not visible. 16314 16315 if Is_Tagged and then Inherit_Discr then 16316 D := First_Discriminant (Derived_Base); 16317 while Present (D) loop 16318 Set_Is_Immediately_Visible (D, False); 16319 Next_Discriminant (D); 16320 end loop; 16321 end if; 16322 16323 return Assoc_List; 16324 end Inherit_Components; 16325 16326 ----------------------- 16327 -- Is_Constant_Bound -- 16328 ----------------------- 16329 16330 function Is_Constant_Bound (Exp : Node_Id) return Boolean is 16331 begin 16332 if Compile_Time_Known_Value (Exp) then 16333 return True; 16334 16335 elsif Is_Entity_Name (Exp) 16336 and then Present (Entity (Exp)) 16337 then 16338 return Is_Constant_Object (Entity (Exp)) 16339 or else Ekind (Entity (Exp)) = E_Enumeration_Literal; 16340 16341 elsif Nkind (Exp) in N_Binary_Op then 16342 return Is_Constant_Bound (Left_Opnd (Exp)) 16343 and then Is_Constant_Bound (Right_Opnd (Exp)) 16344 and then Scope (Entity (Exp)) = Standard_Standard; 16345 16346 else 16347 return False; 16348 end if; 16349 end Is_Constant_Bound; 16350 16351 ----------------------- 16352 -- Is_Null_Extension -- 16353 ----------------------- 16354 16355 function Is_Null_Extension (T : Entity_Id) return Boolean is 16356 Type_Decl : constant Node_Id := Parent (Base_Type (T)); 16357 Comp_List : Node_Id; 16358 Comp : Node_Id; 16359 16360 begin 16361 if Nkind (Type_Decl) /= N_Full_Type_Declaration 16362 or else not Is_Tagged_Type (T) 16363 or else Nkind (Type_Definition (Type_Decl)) /= 16364 N_Derived_Type_Definition 16365 or else No (Record_Extension_Part (Type_Definition (Type_Decl))) 16366 then 16367 return False; 16368 end if; 16369 16370 Comp_List := 16371 Component_List (Record_Extension_Part (Type_Definition (Type_Decl))); 16372 16373 if Present (Discriminant_Specifications (Type_Decl)) then 16374 return False; 16375 16376 elsif Present (Comp_List) 16377 and then Is_Non_Empty_List (Component_Items (Comp_List)) 16378 then 16379 Comp := First (Component_Items (Comp_List)); 16380 16381 -- Only user-defined components are relevant. The component list 16382 -- may also contain a parent component and internal components 16383 -- corresponding to secondary tags, but these do not determine 16384 -- whether this is a null extension. 16385 16386 while Present (Comp) loop 16387 if Comes_From_Source (Comp) then 16388 return False; 16389 end if; 16390 16391 Next (Comp); 16392 end loop; 16393 16394 return True; 16395 else 16396 return True; 16397 end if; 16398 end Is_Null_Extension; 16399 16400 ------------------------------ 16401 -- Is_Valid_Constraint_Kind -- 16402 ------------------------------ 16403 16404 function Is_Valid_Constraint_Kind 16405 (T_Kind : Type_Kind; 16406 Constraint_Kind : Node_Kind) return Boolean 16407 is 16408 begin 16409 case T_Kind is 16410 when Enumeration_Kind | 16411 Integer_Kind => 16412 return Constraint_Kind = N_Range_Constraint; 16413 16414 when Decimal_Fixed_Point_Kind => 16415 return Nkind_In (Constraint_Kind, N_Digits_Constraint, 16416 N_Range_Constraint); 16417 16418 when Ordinary_Fixed_Point_Kind => 16419 return Nkind_In (Constraint_Kind, N_Delta_Constraint, 16420 N_Range_Constraint); 16421 16422 when Float_Kind => 16423 return Nkind_In (Constraint_Kind, N_Digits_Constraint, 16424 N_Range_Constraint); 16425 16426 when Access_Kind | 16427 Array_Kind | 16428 E_Record_Type | 16429 E_Record_Subtype | 16430 Class_Wide_Kind | 16431 E_Incomplete_Type | 16432 Private_Kind | 16433 Concurrent_Kind => 16434 return Constraint_Kind = N_Index_Or_Discriminant_Constraint; 16435 16436 when others => 16437 return True; -- Error will be detected later 16438 end case; 16439 end Is_Valid_Constraint_Kind; 16440 16441 -------------------------- 16442 -- Is_Visible_Component -- 16443 -------------------------- 16444 16445 function Is_Visible_Component 16446 (C : Entity_Id; 16447 N : Node_Id := Empty) return Boolean 16448 is 16449 Original_Comp : Entity_Id := Empty; 16450 Original_Scope : Entity_Id; 16451 Type_Scope : Entity_Id; 16452 16453 function Is_Local_Type (Typ : Entity_Id) return Boolean; 16454 -- Check whether parent type of inherited component is declared locally, 16455 -- possibly within a nested package or instance. The current scope is 16456 -- the derived record itself. 16457 16458 ------------------- 16459 -- Is_Local_Type -- 16460 ------------------- 16461 16462 function Is_Local_Type (Typ : Entity_Id) return Boolean is 16463 Scop : Entity_Id; 16464 16465 begin 16466 Scop := Scope (Typ); 16467 while Present (Scop) 16468 and then Scop /= Standard_Standard 16469 loop 16470 if Scop = Scope (Current_Scope) then 16471 return True; 16472 end if; 16473 16474 Scop := Scope (Scop); 16475 end loop; 16476 16477 return False; 16478 end Is_Local_Type; 16479 16480 -- Start of processing for Is_Visible_Component 16481 16482 begin 16483 if Ekind_In (C, E_Component, E_Discriminant) then 16484 Original_Comp := Original_Record_Component (C); 16485 end if; 16486 16487 if No (Original_Comp) then 16488 16489 -- Premature usage, or previous error 16490 16491 return False; 16492 16493 else 16494 Original_Scope := Scope (Original_Comp); 16495 Type_Scope := Scope (Base_Type (Scope (C))); 16496 end if; 16497 16498 -- This test only concerns tagged types 16499 16500 if not Is_Tagged_Type (Original_Scope) then 16501 return True; 16502 16503 -- If it is _Parent or _Tag, there is no visibility issue 16504 16505 elsif not Comes_From_Source (Original_Comp) then 16506 return True; 16507 16508 -- Discriminants are visible unless the (private) type has unknown 16509 -- discriminants. If the discriminant reference is inserted for a 16510 -- discriminant check on a full view it is also visible. 16511 16512 elsif Ekind (Original_Comp) = E_Discriminant 16513 and then 16514 (not Has_Unknown_Discriminants (Original_Scope) 16515 or else (Present (N) 16516 and then Nkind (N) = N_Selected_Component 16517 and then Nkind (Prefix (N)) = N_Type_Conversion 16518 and then not Comes_From_Source (Prefix (N)))) 16519 then 16520 return True; 16521 16522 -- In the body of an instantiation, no need to check for the visibility 16523 -- of a component. 16524 16525 elsif In_Instance_Body then 16526 return True; 16527 16528 -- If the component has been declared in an ancestor which is currently 16529 -- a private type, then it is not visible. The same applies if the 16530 -- component's containing type is not in an open scope and the original 16531 -- component's enclosing type is a visible full view of a private type 16532 -- (which can occur in cases where an attempt is being made to reference 16533 -- a component in a sibling package that is inherited from a visible 16534 -- component of a type in an ancestor package; the component in the 16535 -- sibling package should not be visible even though the component it 16536 -- inherited from is visible). This does not apply however in the case 16537 -- where the scope of the type is a private child unit, or when the 16538 -- parent comes from a local package in which the ancestor is currently 16539 -- visible. The latter suppression of visibility is needed for cases 16540 -- that are tested in B730006. 16541 16542 elsif Is_Private_Type (Original_Scope) 16543 or else 16544 (not Is_Private_Descendant (Type_Scope) 16545 and then not In_Open_Scopes (Type_Scope) 16546 and then Has_Private_Declaration (Original_Scope)) 16547 then 16548 -- If the type derives from an entity in a formal package, there 16549 -- are no additional visible components. 16550 16551 if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) = 16552 N_Formal_Package_Declaration 16553 then 16554 return False; 16555 16556 -- if we are not in the private part of the current package, there 16557 -- are no additional visible components. 16558 16559 elsif Ekind (Scope (Current_Scope)) = E_Package 16560 and then not In_Private_Part (Scope (Current_Scope)) 16561 then 16562 return False; 16563 else 16564 return 16565 Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) 16566 and then In_Open_Scopes (Scope (Original_Scope)) 16567 and then Is_Local_Type (Type_Scope); 16568 end if; 16569 16570 -- There is another weird way in which a component may be invisible 16571 -- when the private and the full view are not derived from the same 16572 -- ancestor. Here is an example : 16573 16574 -- type A1 is tagged record F1 : integer; end record; 16575 -- type A2 is new A1 with record F2 : integer; end record; 16576 -- type T is new A1 with private; 16577 -- private 16578 -- type T is new A2 with null record; 16579 16580 -- In this case, the full view of T inherits F1 and F2 but the private 16581 -- view inherits only F1 16582 16583 else 16584 declare 16585 Ancestor : Entity_Id := Scope (C); 16586 16587 begin 16588 loop 16589 if Ancestor = Original_Scope then 16590 return True; 16591 elsif Ancestor = Etype (Ancestor) then 16592 return False; 16593 end if; 16594 16595 Ancestor := Etype (Ancestor); 16596 end loop; 16597 end; 16598 end if; 16599 end Is_Visible_Component; 16600 16601 -------------------------- 16602 -- Make_Class_Wide_Type -- 16603 -------------------------- 16604 16605 procedure Make_Class_Wide_Type (T : Entity_Id) is 16606 CW_Type : Entity_Id; 16607 CW_Name : Name_Id; 16608 Next_E : Entity_Id; 16609 16610 begin 16611 if Present (Class_Wide_Type (T)) then 16612 16613 -- The class-wide type is a partially decorated entity created for a 16614 -- unanalyzed tagged type referenced through a limited with clause. 16615 -- When the tagged type is analyzed, its class-wide type needs to be 16616 -- redecorated. Note that we reuse the entity created by Decorate_ 16617 -- Tagged_Type in order to preserve all links. 16618 16619 if Materialize_Entity (Class_Wide_Type (T)) then 16620 CW_Type := Class_Wide_Type (T); 16621 Set_Materialize_Entity (CW_Type, False); 16622 16623 -- The class wide type can have been defined by the partial view, in 16624 -- which case everything is already done. 16625 16626 else 16627 return; 16628 end if; 16629 16630 -- Default case, we need to create a new class-wide type 16631 16632 else 16633 CW_Type := 16634 New_External_Entity (E_Void, Scope (T), Sloc (T), T, 'C', 0, 'T'); 16635 end if; 16636 16637 -- Inherit root type characteristics 16638 16639 CW_Name := Chars (CW_Type); 16640 Next_E := Next_Entity (CW_Type); 16641 Copy_Node (T, CW_Type); 16642 Set_Comes_From_Source (CW_Type, False); 16643 Set_Chars (CW_Type, CW_Name); 16644 Set_Parent (CW_Type, Parent (T)); 16645 Set_Next_Entity (CW_Type, Next_E); 16646 16647 -- Ensure we have a new freeze node for the class-wide type. The partial 16648 -- view may have freeze action of its own, requiring a proper freeze 16649 -- node, and the same freeze node cannot be shared between the two 16650 -- types. 16651 16652 Set_Has_Delayed_Freeze (CW_Type); 16653 Set_Freeze_Node (CW_Type, Empty); 16654 16655 -- Customize the class-wide type: It has no prim. op., it cannot be 16656 -- abstract and its Etype points back to the specific root type. 16657 16658 Set_Ekind (CW_Type, E_Class_Wide_Type); 16659 Set_Is_Tagged_Type (CW_Type, True); 16660 Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); 16661 Set_Is_Abstract_Type (CW_Type, False); 16662 Set_Is_Constrained (CW_Type, False); 16663 Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); 16664 16665 if Ekind (T) = E_Class_Wide_Subtype then 16666 Set_Etype (CW_Type, Etype (Base_Type (T))); 16667 else 16668 Set_Etype (CW_Type, T); 16669 end if; 16670 16671 -- If this is the class_wide type of a constrained subtype, it does 16672 -- not have discriminants. 16673 16674 Set_Has_Discriminants (CW_Type, 16675 Has_Discriminants (T) and then not Is_Constrained (T)); 16676 16677 Set_Has_Unknown_Discriminants (CW_Type, True); 16678 Set_Class_Wide_Type (T, CW_Type); 16679 Set_Equivalent_Type (CW_Type, Empty); 16680 16681 -- The class-wide type of a class-wide type is itself (RM 3.9(14)) 16682 16683 Set_Class_Wide_Type (CW_Type, CW_Type); 16684 end Make_Class_Wide_Type; 16685 16686 ---------------- 16687 -- Make_Index -- 16688 ---------------- 16689 16690 procedure Make_Index 16691 (I : Node_Id; 16692 Related_Nod : Node_Id; 16693 Related_Id : Entity_Id := Empty; 16694 Suffix_Index : Nat := 1; 16695 In_Iter_Schm : Boolean := False) 16696 is 16697 R : Node_Id; 16698 T : Entity_Id; 16699 Def_Id : Entity_Id := Empty; 16700 Found : Boolean := False; 16701 16702 begin 16703 -- For a discrete range used in a constrained array definition and 16704 -- defined by a range, an implicit conversion to the predefined type 16705 -- INTEGER is assumed if each bound is either a numeric literal, a named 16706 -- number, or an attribute, and the type of both bounds (prior to the 16707 -- implicit conversion) is the type universal_integer. Otherwise, both 16708 -- bounds must be of the same discrete type, other than universal 16709 -- integer; this type must be determinable independently of the 16710 -- context, but using the fact that the type must be discrete and that 16711 -- both bounds must have the same type. 16712 16713 -- Character literals also have a universal type in the absence of 16714 -- of additional context, and are resolved to Standard_Character. 16715 16716 if Nkind (I) = N_Range then 16717 16718 -- The index is given by a range constraint. The bounds are known 16719 -- to be of a consistent type. 16720 16721 if not Is_Overloaded (I) then 16722 T := Etype (I); 16723 16724 -- For universal bounds, choose the specific predefined type 16725 16726 if T = Universal_Integer then 16727 T := Standard_Integer; 16728 16729 elsif T = Any_Character then 16730 Ambiguous_Character (Low_Bound (I)); 16731 16732 T := Standard_Character; 16733 end if; 16734 16735 -- The node may be overloaded because some user-defined operators 16736 -- are available, but if a universal interpretation exists it is 16737 -- also the selected one. 16738 16739 elsif Universal_Interpretation (I) = Universal_Integer then 16740 T := Standard_Integer; 16741 16742 else 16743 T := Any_Type; 16744 16745 declare 16746 Ind : Interp_Index; 16747 It : Interp; 16748 16749 begin 16750 Get_First_Interp (I, Ind, It); 16751 while Present (It.Typ) loop 16752 if Is_Discrete_Type (It.Typ) then 16753 16754 if Found 16755 and then not Covers (It.Typ, T) 16756 and then not Covers (T, It.Typ) 16757 then 16758 Error_Msg_N ("ambiguous bounds in discrete range", I); 16759 exit; 16760 else 16761 T := It.Typ; 16762 Found := True; 16763 end if; 16764 end if; 16765 16766 Get_Next_Interp (Ind, It); 16767 end loop; 16768 16769 if T = Any_Type then 16770 Error_Msg_N ("discrete type required for range", I); 16771 Set_Etype (I, Any_Type); 16772 return; 16773 16774 elsif T = Universal_Integer then 16775 T := Standard_Integer; 16776 end if; 16777 end; 16778 end if; 16779 16780 if not Is_Discrete_Type (T) then 16781 Error_Msg_N ("discrete type required for range", I); 16782 Set_Etype (I, Any_Type); 16783 return; 16784 end if; 16785 16786 if Nkind (Low_Bound (I)) = N_Attribute_Reference 16787 and then Attribute_Name (Low_Bound (I)) = Name_First 16788 and then Is_Entity_Name (Prefix (Low_Bound (I))) 16789 and then Is_Type (Entity (Prefix (Low_Bound (I)))) 16790 and then Is_Discrete_Type (Entity (Prefix (Low_Bound (I)))) 16791 then 16792 -- The type of the index will be the type of the prefix, as long 16793 -- as the upper bound is 'Last of the same type. 16794 16795 Def_Id := Entity (Prefix (Low_Bound (I))); 16796 16797 if Nkind (High_Bound (I)) /= N_Attribute_Reference 16798 or else Attribute_Name (High_Bound (I)) /= Name_Last 16799 or else not Is_Entity_Name (Prefix (High_Bound (I))) 16800 or else Entity (Prefix (High_Bound (I))) /= Def_Id 16801 then 16802 Def_Id := Empty; 16803 end if; 16804 end if; 16805 16806 R := I; 16807 Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm); 16808 16809 elsif Nkind (I) = N_Subtype_Indication then 16810 16811 -- The index is given by a subtype with a range constraint 16812 16813 T := Base_Type (Entity (Subtype_Mark (I))); 16814 16815 if not Is_Discrete_Type (T) then 16816 Error_Msg_N ("discrete type required for range", I); 16817 Set_Etype (I, Any_Type); 16818 return; 16819 end if; 16820 16821 R := Range_Expression (Constraint (I)); 16822 16823 Resolve (R, T); 16824 Process_Range_Expr_In_Decl 16825 (R, Entity (Subtype_Mark (I)), In_Iter_Schm => In_Iter_Schm); 16826 16827 elsif Nkind (I) = N_Attribute_Reference then 16828 16829 -- The parser guarantees that the attribute is a RANGE attribute 16830 16831 -- If the node denotes the range of a type mark, that is also the 16832 -- resulting type, and we do no need to create an Itype for it. 16833 16834 if Is_Entity_Name (Prefix (I)) 16835 and then Comes_From_Source (I) 16836 and then Is_Type (Entity (Prefix (I))) 16837 and then Is_Discrete_Type (Entity (Prefix (I))) 16838 then 16839 Def_Id := Entity (Prefix (I)); 16840 end if; 16841 16842 Analyze_And_Resolve (I); 16843 T := Etype (I); 16844 R := I; 16845 16846 -- If none of the above, must be a subtype. We convert this to a 16847 -- range attribute reference because in the case of declared first 16848 -- named subtypes, the types in the range reference can be different 16849 -- from the type of the entity. A range attribute normalizes the 16850 -- reference and obtains the correct types for the bounds. 16851 16852 -- This transformation is in the nature of an expansion, is only 16853 -- done if expansion is active. In particular, it is not done on 16854 -- formal generic types, because we need to retain the name of the 16855 -- original index for instantiation purposes. 16856 16857 else 16858 if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then 16859 Error_Msg_N ("invalid subtype mark in discrete range ", I); 16860 Set_Etype (I, Any_Integer); 16861 return; 16862 16863 else 16864 -- The type mark may be that of an incomplete type. It is only 16865 -- now that we can get the full view, previous analysis does 16866 -- not look specifically for a type mark. 16867 16868 Set_Entity (I, Get_Full_View (Entity (I))); 16869 Set_Etype (I, Entity (I)); 16870 Def_Id := Entity (I); 16871 16872 if not Is_Discrete_Type (Def_Id) then 16873 Error_Msg_N ("discrete type required for index", I); 16874 Set_Etype (I, Any_Type); 16875 return; 16876 end if; 16877 end if; 16878 16879 if Expander_Active then 16880 Rewrite (I, 16881 Make_Attribute_Reference (Sloc (I), 16882 Attribute_Name => Name_Range, 16883 Prefix => Relocate_Node (I))); 16884 16885 -- The original was a subtype mark that does not freeze. This 16886 -- means that the rewritten version must not freeze either. 16887 16888 Set_Must_Not_Freeze (I); 16889 Set_Must_Not_Freeze (Prefix (I)); 16890 Analyze_And_Resolve (I); 16891 T := Etype (I); 16892 R := I; 16893 16894 -- If expander is inactive, type is legal, nothing else to construct 16895 16896 else 16897 return; 16898 end if; 16899 end if; 16900 16901 if not Is_Discrete_Type (T) then 16902 Error_Msg_N ("discrete type required for range", I); 16903 Set_Etype (I, Any_Type); 16904 return; 16905 16906 elsif T = Any_Type then 16907 Set_Etype (I, Any_Type); 16908 return; 16909 end if; 16910 16911 -- We will now create the appropriate Itype to describe the range, but 16912 -- first a check. If we originally had a subtype, then we just label 16913 -- the range with this subtype. Not only is there no need to construct 16914 -- a new subtype, but it is wrong to do so for two reasons: 16915 16916 -- 1. A legality concern, if we have a subtype, it must not freeze, 16917 -- and the Itype would cause freezing incorrectly 16918 16919 -- 2. An efficiency concern, if we created an Itype, it would not be 16920 -- recognized as the same type for the purposes of eliminating 16921 -- checks in some circumstances. 16922 16923 -- We signal this case by setting the subtype entity in Def_Id 16924 16925 if No (Def_Id) then 16926 Def_Id := 16927 Create_Itype (E_Void, Related_Nod, Related_Id, 'D', Suffix_Index); 16928 Set_Etype (Def_Id, Base_Type (T)); 16929 16930 if Is_Signed_Integer_Type (T) then 16931 Set_Ekind (Def_Id, E_Signed_Integer_Subtype); 16932 16933 elsif Is_Modular_Integer_Type (T) then 16934 Set_Ekind (Def_Id, E_Modular_Integer_Subtype); 16935 16936 else 16937 Set_Ekind (Def_Id, E_Enumeration_Subtype); 16938 Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); 16939 Set_First_Literal (Def_Id, First_Literal (T)); 16940 end if; 16941 16942 Set_Size_Info (Def_Id, (T)); 16943 Set_RM_Size (Def_Id, RM_Size (T)); 16944 Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); 16945 16946 Set_Scalar_Range (Def_Id, R); 16947 Conditional_Delay (Def_Id, T); 16948 16949 -- In the subtype indication case, if the immediate parent of the 16950 -- new subtype is non-static, then the subtype we create is non- 16951 -- static, even if its bounds are static. 16952 16953 if Nkind (I) = N_Subtype_Indication 16954 and then not Is_Static_Subtype (Entity (Subtype_Mark (I))) 16955 then 16956 Set_Is_Non_Static_Subtype (Def_Id); 16957 end if; 16958 end if; 16959 16960 -- Final step is to label the index with this constructed type 16961 16962 Set_Etype (I, Def_Id); 16963 end Make_Index; 16964 16965 ------------------------------ 16966 -- Modular_Type_Declaration -- 16967 ------------------------------ 16968 16969 procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is 16970 Mod_Expr : constant Node_Id := Expression (Def); 16971 M_Val : Uint; 16972 16973 procedure Set_Modular_Size (Bits : Int); 16974 -- Sets RM_Size to Bits, and Esize to normal word size above this 16975 16976 ---------------------- 16977 -- Set_Modular_Size -- 16978 ---------------------- 16979 16980 procedure Set_Modular_Size (Bits : Int) is 16981 begin 16982 Set_RM_Size (T, UI_From_Int (Bits)); 16983 16984 if Bits <= 8 then 16985 Init_Esize (T, 8); 16986 16987 elsif Bits <= 16 then 16988 Init_Esize (T, 16); 16989 16990 elsif Bits <= 32 then 16991 Init_Esize (T, 32); 16992 16993 else 16994 Init_Esize (T, System_Max_Binary_Modulus_Power); 16995 end if; 16996 16997 if not Non_Binary_Modulus (T) 16998 and then Esize (T) = RM_Size (T) 16999 then 17000 Set_Is_Known_Valid (T); 17001 end if; 17002 end Set_Modular_Size; 17003 17004 -- Start of processing for Modular_Type_Declaration 17005 17006 begin 17007 -- If the mod expression is (exactly) 2 * literal, where literal is 17008 -- 64 or less,then almost certainly the * was meant to be **. Warn! 17009 17010 if Warn_On_Suspicious_Modulus_Value 17011 and then Nkind (Mod_Expr) = N_Op_Multiply 17012 and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal 17013 and then Intval (Left_Opnd (Mod_Expr)) = Uint_2 17014 and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal 17015 and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64 17016 then 17017 Error_Msg_N 17018 ("suspicious MOD value, was '*'* intended'??M?", Mod_Expr); 17019 end if; 17020 17021 -- Proceed with analysis of mod expression 17022 17023 Analyze_And_Resolve (Mod_Expr, Any_Integer); 17024 Set_Etype (T, T); 17025 Set_Ekind (T, E_Modular_Integer_Type); 17026 Init_Alignment (T); 17027 Set_Is_Constrained (T); 17028 17029 if not Is_OK_Static_Expression (Mod_Expr) then 17030 Flag_Non_Static_Expr 17031 ("non-static expression used for modular type bound!", Mod_Expr); 17032 M_Val := 2 ** System_Max_Binary_Modulus_Power; 17033 else 17034 M_Val := Expr_Value (Mod_Expr); 17035 end if; 17036 17037 if M_Val < 1 then 17038 Error_Msg_N ("modulus value must be positive", Mod_Expr); 17039 M_Val := 2 ** System_Max_Binary_Modulus_Power; 17040 end if; 17041 17042 Set_Modulus (T, M_Val); 17043 17044 -- Create bounds for the modular type based on the modulus given in 17045 -- the type declaration and then analyze and resolve those bounds. 17046 17047 Set_Scalar_Range (T, 17048 Make_Range (Sloc (Mod_Expr), 17049 Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), 0), 17050 High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), M_Val - 1))); 17051 17052 -- Properly analyze the literals for the range. We do this manually 17053 -- because we can't go calling Resolve, since we are resolving these 17054 -- bounds with the type, and this type is certainly not complete yet! 17055 17056 Set_Etype (Low_Bound (Scalar_Range (T)), T); 17057 Set_Etype (High_Bound (Scalar_Range (T)), T); 17058 Set_Is_Static_Expression (Low_Bound (Scalar_Range (T))); 17059 Set_Is_Static_Expression (High_Bound (Scalar_Range (T))); 17060 17061 -- Loop through powers of two to find number of bits required 17062 17063 for Bits in Int range 0 .. System_Max_Binary_Modulus_Power loop 17064 17065 -- Binary case 17066 17067 if M_Val = 2 ** Bits then 17068 Set_Modular_Size (Bits); 17069 return; 17070 17071 -- Non-binary case 17072 17073 elsif M_Val < 2 ** Bits then 17074 Check_SPARK_Restriction ("modulus should be a power of 2", T); 17075 Set_Non_Binary_Modulus (T); 17076 17077 if Bits > System_Max_Nonbinary_Modulus_Power then 17078 Error_Msg_Uint_1 := 17079 UI_From_Int (System_Max_Nonbinary_Modulus_Power); 17080 Error_Msg_F 17081 ("nonbinary modulus exceeds limit (2 '*'*^ - 1)", Mod_Expr); 17082 Set_Modular_Size (System_Max_Binary_Modulus_Power); 17083 return; 17084 17085 else 17086 -- In the non-binary case, set size as per RM 13.3(55) 17087 17088 Set_Modular_Size (Bits); 17089 return; 17090 end if; 17091 end if; 17092 17093 end loop; 17094 17095 -- If we fall through, then the size exceed System.Max_Binary_Modulus 17096 -- so we just signal an error and set the maximum size. 17097 17098 Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power); 17099 Error_Msg_F ("modulus exceeds limit (2 '*'*^)", Mod_Expr); 17100 17101 Set_Modular_Size (System_Max_Binary_Modulus_Power); 17102 Init_Alignment (T); 17103 17104 end Modular_Type_Declaration; 17105 17106 -------------------------- 17107 -- New_Concatenation_Op -- 17108 -------------------------- 17109 17110 procedure New_Concatenation_Op (Typ : Entity_Id) is 17111 Loc : constant Source_Ptr := Sloc (Typ); 17112 Op : Entity_Id; 17113 17114 function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id; 17115 -- Create abbreviated declaration for the formal of a predefined 17116 -- Operator 'Op' of type 'Typ' 17117 17118 -------------------- 17119 -- Make_Op_Formal -- 17120 -------------------- 17121 17122 function Make_Op_Formal (Typ, Op : Entity_Id) return Entity_Id is 17123 Formal : Entity_Id; 17124 begin 17125 Formal := New_Internal_Entity (E_In_Parameter, Op, Loc, 'P'); 17126 Set_Etype (Formal, Typ); 17127 Set_Mechanism (Formal, Default_Mechanism); 17128 return Formal; 17129 end Make_Op_Formal; 17130 17131 -- Start of processing for New_Concatenation_Op 17132 17133 begin 17134 Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); 17135 17136 Set_Ekind (Op, E_Operator); 17137 Set_Scope (Op, Current_Scope); 17138 Set_Etype (Op, Typ); 17139 Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); 17140 Set_Is_Immediately_Visible (Op); 17141 Set_Is_Intrinsic_Subprogram (Op); 17142 Set_Has_Completion (Op); 17143 Append_Entity (Op, Current_Scope); 17144 17145 Set_Name_Entity_Id (Name_Op_Concat, Op); 17146 17147 Append_Entity (Make_Op_Formal (Typ, Op), Op); 17148 Append_Entity (Make_Op_Formal (Typ, Op), Op); 17149 end New_Concatenation_Op; 17150 17151 ------------------------- 17152 -- OK_For_Limited_Init -- 17153 ------------------------- 17154 17155 -- ???Check all calls of this, and compare the conditions under which it's 17156 -- called. 17157 17158 function OK_For_Limited_Init 17159 (Typ : Entity_Id; 17160 Exp : Node_Id) return Boolean 17161 is 17162 begin 17163 return Is_CPP_Constructor_Call (Exp) 17164 or else (Ada_Version >= Ada_2005 17165 and then not Debug_Flag_Dot_L 17166 and then OK_For_Limited_Init_In_05 (Typ, Exp)); 17167 end OK_For_Limited_Init; 17168 17169 ------------------------------- 17170 -- OK_For_Limited_Init_In_05 -- 17171 ------------------------------- 17172 17173 function OK_For_Limited_Init_In_05 17174 (Typ : Entity_Id; 17175 Exp : Node_Id) return Boolean 17176 is 17177 begin 17178 -- An object of a limited interface type can be initialized with any 17179 -- expression of a nonlimited descendant type. 17180 17181 if Is_Class_Wide_Type (Typ) 17182 and then Is_Limited_Interface (Typ) 17183 and then not Is_Limited_Type (Etype (Exp)) 17184 then 17185 return True; 17186 end if; 17187 17188 -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in 17189 -- case of limited aggregates (including extension aggregates), and 17190 -- function calls. The function call may have been given in prefixed 17191 -- notation, in which case the original node is an indexed component. 17192 -- If the function is parameterless, the original node was an explicit 17193 -- dereference. The function may also be parameterless, in which case 17194 -- the source node is just an identifier. 17195 17196 case Nkind (Original_Node (Exp)) is 17197 when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op => 17198 return True; 17199 17200 when N_Identifier => 17201 return Present (Entity (Original_Node (Exp))) 17202 and then Ekind (Entity (Original_Node (Exp))) = E_Function; 17203 17204 when N_Qualified_Expression => 17205 return 17206 OK_For_Limited_Init_In_05 17207 (Typ, Expression (Original_Node (Exp))); 17208 17209 -- Ada 2005 (AI-251): If a class-wide interface object is initialized 17210 -- with a function call, the expander has rewritten the call into an 17211 -- N_Type_Conversion node to force displacement of the pointer to 17212 -- reference the component containing the secondary dispatch table. 17213 -- Otherwise a type conversion is not a legal context. 17214 -- A return statement for a build-in-place function returning a 17215 -- synchronized type also introduces an unchecked conversion. 17216 17217 when N_Type_Conversion | 17218 N_Unchecked_Type_Conversion => 17219 return not Comes_From_Source (Exp) 17220 and then 17221 OK_For_Limited_Init_In_05 17222 (Typ, Expression (Original_Node (Exp))); 17223 17224 when N_Indexed_Component | 17225 N_Selected_Component | 17226 N_Explicit_Dereference => 17227 return Nkind (Exp) = N_Function_Call; 17228 17229 -- A use of 'Input is a function call, hence allowed. Normally the 17230 -- attribute will be changed to a call, but the attribute by itself 17231 -- can occur with -gnatc. 17232 17233 when N_Attribute_Reference => 17234 return Attribute_Name (Original_Node (Exp)) = Name_Input; 17235 17236 -- For a case expression, all dependent expressions must be legal 17237 17238 when N_Case_Expression => 17239 declare 17240 Alt : Node_Id; 17241 17242 begin 17243 Alt := First (Alternatives (Original_Node (Exp))); 17244 while Present (Alt) loop 17245 if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then 17246 return False; 17247 end if; 17248 17249 Next (Alt); 17250 end loop; 17251 17252 return True; 17253 end; 17254 17255 -- For an if expression, all dependent expressions must be legal 17256 17257 when N_If_Expression => 17258 declare 17259 Then_Expr : constant Node_Id := 17260 Next (First (Expressions (Original_Node (Exp)))); 17261 Else_Expr : constant Node_Id := Next (Then_Expr); 17262 begin 17263 return OK_For_Limited_Init_In_05 (Typ, Then_Expr) 17264 and then 17265 OK_For_Limited_Init_In_05 (Typ, Else_Expr); 17266 end; 17267 17268 when others => 17269 return False; 17270 end case; 17271 end OK_For_Limited_Init_In_05; 17272 17273 ------------------------------------------- 17274 -- Ordinary_Fixed_Point_Type_Declaration -- 17275 ------------------------------------------- 17276 17277 procedure Ordinary_Fixed_Point_Type_Declaration 17278 (T : Entity_Id; 17279 Def : Node_Id) 17280 is 17281 Loc : constant Source_Ptr := Sloc (Def); 17282 Delta_Expr : constant Node_Id := Delta_Expression (Def); 17283 RRS : constant Node_Id := Real_Range_Specification (Def); 17284 Implicit_Base : Entity_Id; 17285 Delta_Val : Ureal; 17286 Small_Val : Ureal; 17287 Low_Val : Ureal; 17288 High_Val : Ureal; 17289 17290 begin 17291 Check_Restriction (No_Fixed_Point, Def); 17292 17293 -- Create implicit base type 17294 17295 Implicit_Base := 17296 Create_Itype (E_Ordinary_Fixed_Point_Type, Parent (Def), T, 'B'); 17297 Set_Etype (Implicit_Base, Implicit_Base); 17298 17299 -- Analyze and process delta expression 17300 17301 Analyze_And_Resolve (Delta_Expr, Any_Real); 17302 17303 Check_Delta_Expression (Delta_Expr); 17304 Delta_Val := Expr_Value_R (Delta_Expr); 17305 17306 Set_Delta_Value (Implicit_Base, Delta_Val); 17307 17308 -- Compute default small from given delta, which is the largest power 17309 -- of two that does not exceed the given delta value. 17310 17311 declare 17312 Tmp : Ureal; 17313 Scale : Int; 17314 17315 begin 17316 Tmp := Ureal_1; 17317 Scale := 0; 17318 17319 if Delta_Val < Ureal_1 then 17320 while Delta_Val < Tmp loop 17321 Tmp := Tmp / Ureal_2; 17322 Scale := Scale + 1; 17323 end loop; 17324 17325 else 17326 loop 17327 Tmp := Tmp * Ureal_2; 17328 exit when Tmp > Delta_Val; 17329 Scale := Scale - 1; 17330 end loop; 17331 end if; 17332 17333 Small_Val := UR_From_Components (Uint_1, UI_From_Int (Scale), 2); 17334 end; 17335 17336 Set_Small_Value (Implicit_Base, Small_Val); 17337 17338 -- If no range was given, set a dummy range 17339 17340 if RRS <= Empty_Or_Error then 17341 Low_Val := -Small_Val; 17342 High_Val := Small_Val; 17343 17344 -- Otherwise analyze and process given range 17345 17346 else 17347 declare 17348 Low : constant Node_Id := Low_Bound (RRS); 17349 High : constant Node_Id := High_Bound (RRS); 17350 17351 begin 17352 Analyze_And_Resolve (Low, Any_Real); 17353 Analyze_And_Resolve (High, Any_Real); 17354 Check_Real_Bound (Low); 17355 Check_Real_Bound (High); 17356 17357 -- Obtain and set the range 17358 17359 Low_Val := Expr_Value_R (Low); 17360 High_Val := Expr_Value_R (High); 17361 17362 if Low_Val > High_Val then 17363 Error_Msg_NE ("??fixed point type& has null range", Def, T); 17364 end if; 17365 end; 17366 end if; 17367 17368 -- The range for both the implicit base and the declared first subtype 17369 -- cannot be set yet, so we use the special routine Set_Fixed_Range to 17370 -- set a temporary range in place. Note that the bounds of the base 17371 -- type will be widened to be symmetrical and to fill the available 17372 -- bits when the type is frozen. 17373 17374 -- We could do this with all discrete types, and probably should, but 17375 -- we absolutely have to do it for fixed-point, since the end-points 17376 -- of the range and the size are determined by the small value, which 17377 -- could be reset before the freeze point. 17378 17379 Set_Fixed_Range (Implicit_Base, Loc, Low_Val, High_Val); 17380 Set_Fixed_Range (T, Loc, Low_Val, High_Val); 17381 17382 -- Complete definition of first subtype 17383 17384 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); 17385 Set_Etype (T, Implicit_Base); 17386 Init_Size_Align (T); 17387 Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); 17388 Set_Small_Value (T, Small_Val); 17389 Set_Delta_Value (T, Delta_Val); 17390 Set_Is_Constrained (T); 17391 17392 end Ordinary_Fixed_Point_Type_Declaration; 17393 17394 ---------------------------------------- 17395 -- Prepare_Private_Subtype_Completion -- 17396 ---------------------------------------- 17397 17398 procedure Prepare_Private_Subtype_Completion 17399 (Id : Entity_Id; 17400 Related_Nod : Node_Id) 17401 is 17402 Id_B : constant Entity_Id := Base_Type (Id); 17403 Full_B : constant Entity_Id := Full_View (Id_B); 17404 Full : Entity_Id; 17405 17406 begin 17407 if Present (Full_B) then 17408 17409 -- The Base_Type is already completed, we can complete the subtype 17410 -- now. We have to create a new entity with the same name, Thus we 17411 -- can't use Create_Itype. 17412 17413 -- This is messy, should be fixed ??? 17414 17415 Full := Make_Defining_Identifier (Sloc (Id), Chars (Id)); 17416 Set_Is_Itype (Full); 17417 Set_Associated_Node_For_Itype (Full, Related_Nod); 17418 Complete_Private_Subtype (Id, Full, Full_B, Related_Nod); 17419 end if; 17420 17421 -- The parent subtype may be private, but the base might not, in some 17422 -- nested instances. In that case, the subtype does not need to be 17423 -- exchanged. It would still be nice to make private subtypes and their 17424 -- bases consistent at all times ??? 17425 17426 if Is_Private_Type (Id_B) then 17427 Append_Elmt (Id, Private_Dependents (Id_B)); 17428 end if; 17429 end Prepare_Private_Subtype_Completion; 17430 17431 --------------------------- 17432 -- Process_Discriminants -- 17433 --------------------------- 17434 17435 procedure Process_Discriminants 17436 (N : Node_Id; 17437 Prev : Entity_Id := Empty) 17438 is 17439 Elist : constant Elist_Id := New_Elmt_List; 17440 Id : Node_Id; 17441 Discr : Node_Id; 17442 Discr_Number : Uint; 17443 Discr_Type : Entity_Id; 17444 Default_Present : Boolean := False; 17445 Default_Not_Present : Boolean := False; 17446 17447 begin 17448 -- A composite type other than an array type can have discriminants. 17449 -- On entry, the current scope is the composite type. 17450 17451 -- The discriminants are initially entered into the scope of the type 17452 -- via Enter_Name with the default Ekind of E_Void to prevent premature 17453 -- use, as explained at the end of this procedure. 17454 17455 Discr := First (Discriminant_Specifications (N)); 17456 while Present (Discr) loop 17457 Enter_Name (Defining_Identifier (Discr)); 17458 17459 -- For navigation purposes we add a reference to the discriminant 17460 -- in the entity for the type. If the current declaration is a 17461 -- completion, place references on the partial view. Otherwise the 17462 -- type is the current scope. 17463 17464 if Present (Prev) then 17465 17466 -- The references go on the partial view, if present. If the 17467 -- partial view has discriminants, the references have been 17468 -- generated already. 17469 17470 if not Has_Discriminants (Prev) then 17471 Generate_Reference (Prev, Defining_Identifier (Discr), 'd'); 17472 end if; 17473 else 17474 Generate_Reference 17475 (Current_Scope, Defining_Identifier (Discr), 'd'); 17476 end if; 17477 17478 if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then 17479 Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr)); 17480 17481 -- Ada 2005 (AI-254) 17482 17483 if Present (Access_To_Subprogram_Definition 17484 (Discriminant_Type (Discr))) 17485 and then Protected_Present (Access_To_Subprogram_Definition 17486 (Discriminant_Type (Discr))) 17487 then 17488 Discr_Type := 17489 Replace_Anonymous_Access_To_Protected_Subprogram (Discr); 17490 end if; 17491 17492 else 17493 Find_Type (Discriminant_Type (Discr)); 17494 Discr_Type := Etype (Discriminant_Type (Discr)); 17495 17496 if Error_Posted (Discriminant_Type (Discr)) then 17497 Discr_Type := Any_Type; 17498 end if; 17499 end if; 17500 17501 if Is_Access_Type (Discr_Type) then 17502 17503 -- Ada 2005 (AI-230): Access discriminant allowed in non-limited 17504 -- record types 17505 17506 if Ada_Version < Ada_2005 then 17507 Check_Access_Discriminant_Requires_Limited 17508 (Discr, Discriminant_Type (Discr)); 17509 end if; 17510 17511 if Ada_Version = Ada_83 and then Comes_From_Source (Discr) then 17512 Error_Msg_N 17513 ("(Ada 83) access discriminant not allowed", Discr); 17514 end if; 17515 17516 elsif not Is_Discrete_Type (Discr_Type) then 17517 Error_Msg_N ("discriminants must have a discrete or access type", 17518 Discriminant_Type (Discr)); 17519 end if; 17520 17521 Set_Etype (Defining_Identifier (Discr), Discr_Type); 17522 17523 -- If a discriminant specification includes the assignment compound 17524 -- delimiter followed by an expression, the expression is the default 17525 -- expression of the discriminant; the default expression must be of 17526 -- the type of the discriminant. (RM 3.7.1) Since this expression is 17527 -- a default expression, we do the special preanalysis, since this 17528 -- expression does not freeze (see "Handling of Default and Per- 17529 -- Object Expressions" in spec of package Sem). 17530 17531 if Present (Expression (Discr)) then 17532 Preanalyze_Spec_Expression (Expression (Discr), Discr_Type); 17533 17534 if Nkind (N) = N_Formal_Type_Declaration then 17535 Error_Msg_N 17536 ("discriminant defaults not allowed for formal type", 17537 Expression (Discr)); 17538 17539 -- Flag an error for a tagged type with defaulted discriminants, 17540 -- excluding limited tagged types when compiling for Ada 2012 17541 -- (see AI05-0214). 17542 17543 elsif Is_Tagged_Type (Current_Scope) 17544 and then (not Is_Limited_Type (Current_Scope) 17545 or else Ada_Version < Ada_2012) 17546 and then Comes_From_Source (N) 17547 then 17548 -- Note: see similar test in Check_Or_Process_Discriminants, to 17549 -- handle the (illegal) case of the completion of an untagged 17550 -- view with discriminants with defaults by a tagged full view. 17551 -- We skip the check if Discr does not come from source, to 17552 -- account for the case of an untagged derived type providing 17553 -- defaults for a renamed discriminant from a private untagged 17554 -- ancestor with a tagged full view (ACATS B460006). 17555 17556 if Ada_Version >= Ada_2012 then 17557 Error_Msg_N 17558 ("discriminants of nonlimited tagged type cannot have" 17559 & " defaults", 17560 Expression (Discr)); 17561 else 17562 Error_Msg_N 17563 ("discriminants of tagged type cannot have defaults", 17564 Expression (Discr)); 17565 end if; 17566 17567 else 17568 Default_Present := True; 17569 Append_Elmt (Expression (Discr), Elist); 17570 17571 -- Tag the defining identifiers for the discriminants with 17572 -- their corresponding default expressions from the tree. 17573 17574 Set_Discriminant_Default_Value 17575 (Defining_Identifier (Discr), Expression (Discr)); 17576 end if; 17577 17578 else 17579 Default_Not_Present := True; 17580 end if; 17581 17582 -- Ada 2005 (AI-231): Create an Itype that is a duplicate of 17583 -- Discr_Type but with the null-exclusion attribute 17584 17585 if Ada_Version >= Ada_2005 then 17586 17587 -- Ada 2005 (AI-231): Static checks 17588 17589 if Can_Never_Be_Null (Discr_Type) then 17590 Null_Exclusion_Static_Checks (Discr); 17591 17592 elsif Is_Access_Type (Discr_Type) 17593 and then Null_Exclusion_Present (Discr) 17594 17595 -- No need to check itypes because in their case this check 17596 -- was done at their point of creation 17597 17598 and then not Is_Itype (Discr_Type) 17599 then 17600 if Can_Never_Be_Null (Discr_Type) then 17601 Error_Msg_NE 17602 ("`NOT NULL` not allowed (& already excludes null)", 17603 Discr, 17604 Discr_Type); 17605 end if; 17606 17607 Set_Etype (Defining_Identifier (Discr), 17608 Create_Null_Excluding_Itype 17609 (T => Discr_Type, 17610 Related_Nod => Discr)); 17611 17612 -- Check for improper null exclusion if the type is otherwise 17613 -- legal for a discriminant. 17614 17615 elsif Null_Exclusion_Present (Discr) 17616 and then Is_Discrete_Type (Discr_Type) 17617 then 17618 Error_Msg_N 17619 ("null exclusion can only apply to an access type", Discr); 17620 end if; 17621 17622 -- Ada 2005 (AI-402): access discriminants of nonlimited types 17623 -- can't have defaults. Synchronized types, or types that are 17624 -- explicitly limited are fine, but special tests apply to derived 17625 -- types in generics: in a generic body we have to assume the 17626 -- worst, and therefore defaults are not allowed if the parent is 17627 -- a generic formal private type (see ACATS B370001). 17628 17629 if Is_Access_Type (Discr_Type) and then Default_Present then 17630 if Ekind (Discr_Type) /= E_Anonymous_Access_Type 17631 or else Is_Limited_Record (Current_Scope) 17632 or else Is_Concurrent_Type (Current_Scope) 17633 or else Is_Concurrent_Record_Type (Current_Scope) 17634 or else Ekind (Current_Scope) = E_Limited_Private_Type 17635 then 17636 if not Is_Derived_Type (Current_Scope) 17637 or else not Is_Generic_Type (Etype (Current_Scope)) 17638 or else not In_Package_Body (Scope (Etype (Current_Scope))) 17639 or else Limited_Present 17640 (Type_Definition (Parent (Current_Scope))) 17641 then 17642 null; 17643 17644 else 17645 Error_Msg_N ("access discriminants of nonlimited types", 17646 Expression (Discr)); 17647 Error_Msg_N ("\cannot have defaults", Expression (Discr)); 17648 end if; 17649 17650 elsif Present (Expression (Discr)) then 17651 Error_Msg_N 17652 ("(Ada 2005) access discriminants of nonlimited types", 17653 Expression (Discr)); 17654 Error_Msg_N ("\cannot have defaults", Expression (Discr)); 17655 end if; 17656 end if; 17657 end if; 17658 17659 Next (Discr); 17660 end loop; 17661 17662 -- An element list consisting of the default expressions of the 17663 -- discriminants is constructed in the above loop and used to set 17664 -- the Discriminant_Constraint attribute for the type. If an object 17665 -- is declared of this (record or task) type without any explicit 17666 -- discriminant constraint given, this element list will form the 17667 -- actual parameters for the corresponding initialization procedure 17668 -- for the type. 17669 17670 Set_Discriminant_Constraint (Current_Scope, Elist); 17671 Set_Stored_Constraint (Current_Scope, No_Elist); 17672 17673 -- Default expressions must be provided either for all or for none 17674 -- of the discriminants of a discriminant part. (RM 3.7.1) 17675 17676 if Default_Present and then Default_Not_Present then 17677 Error_Msg_N 17678 ("incomplete specification of defaults for discriminants", N); 17679 end if; 17680 17681 -- The use of the name of a discriminant is not allowed in default 17682 -- expressions of a discriminant part if the specification of the 17683 -- discriminant is itself given in the discriminant part. (RM 3.7.1) 17684 17685 -- To detect this, the discriminant names are entered initially with an 17686 -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any 17687 -- attempt to use a void entity (for example in an expression that is 17688 -- type-checked) produces the error message: premature usage. Now after 17689 -- completing the semantic analysis of the discriminant part, we can set 17690 -- the Ekind of all the discriminants appropriately. 17691 17692 Discr := First (Discriminant_Specifications (N)); 17693 Discr_Number := Uint_1; 17694 while Present (Discr) loop 17695 Id := Defining_Identifier (Discr); 17696 Set_Ekind (Id, E_Discriminant); 17697 Init_Component_Location (Id); 17698 Init_Esize (Id); 17699 Set_Discriminant_Number (Id, Discr_Number); 17700 17701 -- Make sure this is always set, even in illegal programs 17702 17703 Set_Corresponding_Discriminant (Id, Empty); 17704 17705 -- Initialize the Original_Record_Component to the entity itself. 17706 -- Inherit_Components will propagate the right value to 17707 -- discriminants in derived record types. 17708 17709 Set_Original_Record_Component (Id, Id); 17710 17711 -- Create the discriminal for the discriminant 17712 17713 Build_Discriminal (Id); 17714 17715 Next (Discr); 17716 Discr_Number := Discr_Number + 1; 17717 end loop; 17718 17719 Set_Has_Discriminants (Current_Scope); 17720 end Process_Discriminants; 17721 17722 ----------------------- 17723 -- Process_Full_View -- 17724 ----------------------- 17725 17726 procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is 17727 Priv_Parent : Entity_Id; 17728 Full_Parent : Entity_Id; 17729 Full_Indic : Node_Id; 17730 17731 procedure Collect_Implemented_Interfaces 17732 (Typ : Entity_Id; 17733 Ifaces : Elist_Id); 17734 -- Ada 2005: Gather all the interfaces that Typ directly or 17735 -- inherently implements. Duplicate entries are not added to 17736 -- the list Ifaces. 17737 17738 ------------------------------------ 17739 -- Collect_Implemented_Interfaces -- 17740 ------------------------------------ 17741 17742 procedure Collect_Implemented_Interfaces 17743 (Typ : Entity_Id; 17744 Ifaces : Elist_Id) 17745 is 17746 Iface : Entity_Id; 17747 Iface_Elmt : Elmt_Id; 17748 17749 begin 17750 -- Abstract interfaces are only associated with tagged record types 17751 17752 if not Is_Tagged_Type (Typ) 17753 or else not Is_Record_Type (Typ) 17754 then 17755 return; 17756 end if; 17757 17758 -- Recursively climb to the ancestors 17759 17760 if Etype (Typ) /= Typ 17761 17762 -- Protect the frontend against wrong cyclic declarations like: 17763 17764 -- type B is new A with private; 17765 -- type C is new A with private; 17766 -- private 17767 -- type B is new C with null record; 17768 -- type C is new B with null record; 17769 17770 and then Etype (Typ) /= Priv_T 17771 and then Etype (Typ) /= Full_T 17772 then 17773 -- Keep separate the management of private type declarations 17774 17775 if Ekind (Typ) = E_Record_Type_With_Private then 17776 17777 -- Handle the following erroneous case: 17778 -- type Private_Type is tagged private; 17779 -- private 17780 -- type Private_Type is new Type_Implementing_Iface; 17781 17782 if Present (Full_View (Typ)) 17783 and then Etype (Typ) /= Full_View (Typ) 17784 then 17785 if Is_Interface (Etype (Typ)) then 17786 Append_Unique_Elmt (Etype (Typ), Ifaces); 17787 end if; 17788 17789 Collect_Implemented_Interfaces (Etype (Typ), Ifaces); 17790 end if; 17791 17792 -- Non-private types 17793 17794 else 17795 if Is_Interface (Etype (Typ)) then 17796 Append_Unique_Elmt (Etype (Typ), Ifaces); 17797 end if; 17798 17799 Collect_Implemented_Interfaces (Etype (Typ), Ifaces); 17800 end if; 17801 end if; 17802 17803 -- Handle entities in the list of abstract interfaces 17804 17805 if Present (Interfaces (Typ)) then 17806 Iface_Elmt := First_Elmt (Interfaces (Typ)); 17807 while Present (Iface_Elmt) loop 17808 Iface := Node (Iface_Elmt); 17809 17810 pragma Assert (Is_Interface (Iface)); 17811 17812 if not Contain_Interface (Iface, Ifaces) then 17813 Append_Elmt (Iface, Ifaces); 17814 Collect_Implemented_Interfaces (Iface, Ifaces); 17815 end if; 17816 17817 Next_Elmt (Iface_Elmt); 17818 end loop; 17819 end if; 17820 end Collect_Implemented_Interfaces; 17821 17822 -- Start of processing for Process_Full_View 17823 17824 begin 17825 -- First some sanity checks that must be done after semantic 17826 -- decoration of the full view and thus cannot be placed with other 17827 -- similar checks in Find_Type_Name 17828 17829 if not Is_Limited_Type (Priv_T) 17830 and then (Is_Limited_Type (Full_T) 17831 or else Is_Limited_Composite (Full_T)) 17832 then 17833 if In_Instance then 17834 null; 17835 else 17836 Error_Msg_N 17837 ("completion of nonlimited type cannot be limited", Full_T); 17838 Explain_Limited_Type (Full_T, Full_T); 17839 end if; 17840 17841 elsif Is_Abstract_Type (Full_T) 17842 and then not Is_Abstract_Type (Priv_T) 17843 then 17844 Error_Msg_N 17845 ("completion of nonabstract type cannot be abstract", Full_T); 17846 17847 elsif Is_Tagged_Type (Priv_T) 17848 and then Is_Limited_Type (Priv_T) 17849 and then not Is_Limited_Type (Full_T) 17850 then 17851 -- If pragma CPP_Class was applied to the private declaration 17852 -- propagate the limitedness to the full-view 17853 17854 if Is_CPP_Class (Priv_T) then 17855 Set_Is_Limited_Record (Full_T); 17856 17857 -- GNAT allow its own definition of Limited_Controlled to disobey 17858 -- this rule in order in ease the implementation. This test is safe 17859 -- because Root_Controlled is defined in a child of System that 17860 -- normal programs are not supposed to use. 17861 17862 elsif Is_RTE (Etype (Full_T), RE_Root_Controlled) then 17863 Set_Is_Limited_Composite (Full_T); 17864 else 17865 Error_Msg_N 17866 ("completion of limited tagged type must be limited", Full_T); 17867 end if; 17868 17869 elsif Is_Generic_Type (Priv_T) then 17870 Error_Msg_N ("generic type cannot have a completion", Full_T); 17871 end if; 17872 17873 -- Check that ancestor interfaces of private and full views are 17874 -- consistent. We omit this check for synchronized types because 17875 -- they are performed on the corresponding record type when frozen. 17876 17877 if Ada_Version >= Ada_2005 17878 and then Is_Tagged_Type (Priv_T) 17879 and then Is_Tagged_Type (Full_T) 17880 and then not Is_Concurrent_Type (Full_T) 17881 then 17882 declare 17883 Iface : Entity_Id; 17884 Priv_T_Ifaces : constant Elist_Id := New_Elmt_List; 17885 Full_T_Ifaces : constant Elist_Id := New_Elmt_List; 17886 17887 begin 17888 Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces); 17889 Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces); 17890 17891 -- Ada 2005 (AI-251): The partial view shall be a descendant of 17892 -- an interface type if and only if the full type is descendant 17893 -- of the interface type (AARM 7.3 (7.3/2)). 17894 17895 Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); 17896 17897 if Present (Iface) then 17898 Error_Msg_NE 17899 ("interface & not implemented by full type " & 17900 "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); 17901 end if; 17902 17903 Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); 17904 17905 if Present (Iface) then 17906 Error_Msg_NE 17907 ("interface & not implemented by partial view " & 17908 "(RM-2005 7.3 (7.3/2))", Full_T, Iface); 17909 end if; 17910 end; 17911 end if; 17912 17913 if Is_Tagged_Type (Priv_T) 17914 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 17915 and then Is_Derived_Type (Full_T) 17916 then 17917 Priv_Parent := Etype (Priv_T); 17918 17919 -- The full view of a private extension may have been transformed 17920 -- into an unconstrained derived type declaration and a subtype 17921 -- declaration (see build_derived_record_type for details). 17922 17923 if Nkind (N) = N_Subtype_Declaration then 17924 Full_Indic := Subtype_Indication (N); 17925 Full_Parent := Etype (Base_Type (Full_T)); 17926 else 17927 Full_Indic := Subtype_Indication (Type_Definition (N)); 17928 Full_Parent := Etype (Full_T); 17929 end if; 17930 17931 -- Check that the parent type of the full type is a descendant of 17932 -- the ancestor subtype given in the private extension. If either 17933 -- entity has an Etype equal to Any_Type then we had some previous 17934 -- error situation [7.3(8)]. 17935 17936 if Priv_Parent = Any_Type or else Full_Parent = Any_Type then 17937 return; 17938 17939 -- Ada 2005 (AI-251): Interfaces in the full-typ can be given in 17940 -- any order. Therefore we don't have to check that its parent must 17941 -- be a descendant of the parent of the private type declaration. 17942 17943 elsif Is_Interface (Priv_Parent) 17944 and then Is_Interface (Full_Parent) 17945 then 17946 null; 17947 17948 -- Ada 2005 (AI-251): If the parent of the private type declaration 17949 -- is an interface there is no need to check that it is an ancestor 17950 -- of the associated full type declaration. The required tests for 17951 -- this case are performed by Build_Derived_Record_Type. 17952 17953 elsif not Is_Interface (Base_Type (Priv_Parent)) 17954 and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) 17955 then 17956 Error_Msg_N 17957 ("parent of full type must descend from parent" 17958 & " of private extension", Full_Indic); 17959 17960 -- First check a formal restriction, and then proceed with checking 17961 -- Ada rules. Since the formal restriction is not a serious error, we 17962 -- don't prevent further error detection for this check, hence the 17963 -- ELSE. 17964 17965 else 17966 17967 -- In formal mode, when completing a private extension the type 17968 -- named in the private part must be exactly the same as that 17969 -- named in the visible part. 17970 17971 if Priv_Parent /= Full_Parent then 17972 Error_Msg_Name_1 := Chars (Priv_Parent); 17973 Check_SPARK_Restriction ("% expected", Full_Indic); 17974 end if; 17975 17976 -- Check the rules of 7.3(10): if the private extension inherits 17977 -- known discriminants, then the full type must also inherit those 17978 -- discriminants from the same (ancestor) type, and the parent 17979 -- subtype of the full type must be constrained if and only if 17980 -- the ancestor subtype of the private extension is constrained. 17981 17982 if No (Discriminant_Specifications (Parent (Priv_T))) 17983 and then not Has_Unknown_Discriminants (Priv_T) 17984 and then Has_Discriminants (Base_Type (Priv_Parent)) 17985 then 17986 declare 17987 Priv_Indic : constant Node_Id := 17988 Subtype_Indication (Parent (Priv_T)); 17989 17990 Priv_Constr : constant Boolean := 17991 Is_Constrained (Priv_Parent) 17992 or else 17993 Nkind (Priv_Indic) = N_Subtype_Indication 17994 or else 17995 Is_Constrained (Entity (Priv_Indic)); 17996 17997 Full_Constr : constant Boolean := 17998 Is_Constrained (Full_Parent) 17999 or else 18000 Nkind (Full_Indic) = N_Subtype_Indication 18001 or else 18002 Is_Constrained (Entity (Full_Indic)); 18003 18004 Priv_Discr : Entity_Id; 18005 Full_Discr : Entity_Id; 18006 18007 begin 18008 Priv_Discr := First_Discriminant (Priv_Parent); 18009 Full_Discr := First_Discriminant (Full_Parent); 18010 while Present (Priv_Discr) and then Present (Full_Discr) loop 18011 if Original_Record_Component (Priv_Discr) = 18012 Original_Record_Component (Full_Discr) 18013 or else 18014 Corresponding_Discriminant (Priv_Discr) = 18015 Corresponding_Discriminant (Full_Discr) 18016 then 18017 null; 18018 else 18019 exit; 18020 end if; 18021 18022 Next_Discriminant (Priv_Discr); 18023 Next_Discriminant (Full_Discr); 18024 end loop; 18025 18026 if Present (Priv_Discr) or else Present (Full_Discr) then 18027 Error_Msg_N 18028 ("full view must inherit discriminants of the parent" 18029 & " type used in the private extension", Full_Indic); 18030 18031 elsif Priv_Constr and then not Full_Constr then 18032 Error_Msg_N 18033 ("parent subtype of full type must be constrained", 18034 Full_Indic); 18035 18036 elsif Full_Constr and then not Priv_Constr then 18037 Error_Msg_N 18038 ("parent subtype of full type must be unconstrained", 18039 Full_Indic); 18040 end if; 18041 end; 18042 18043 -- Check the rules of 7.3(12): if a partial view has neither 18044 -- known or unknown discriminants, then the full type 18045 -- declaration shall define a definite subtype. 18046 18047 elsif not Has_Unknown_Discriminants (Priv_T) 18048 and then not Has_Discriminants (Priv_T) 18049 and then not Is_Constrained (Full_T) 18050 then 18051 Error_Msg_N 18052 ("full view must define a constrained type if partial view" 18053 & " has no discriminants", Full_T); 18054 end if; 18055 18056 -- ??????? Do we implement the following properly ????? 18057 -- If the ancestor subtype of a private extension has constrained 18058 -- discriminants, then the parent subtype of the full view shall 18059 -- impose a statically matching constraint on those discriminants 18060 -- [7.3(13)]. 18061 end if; 18062 18063 else 18064 -- For untagged types, verify that a type without discriminants 18065 -- is not completed with an unconstrained type. 18066 18067 if not Is_Indefinite_Subtype (Priv_T) 18068 and then Is_Indefinite_Subtype (Full_T) 18069 then 18070 Error_Msg_N ("full view of type must be definite subtype", Full_T); 18071 end if; 18072 end if; 18073 18074 -- AI-419: verify that the use of "limited" is consistent 18075 18076 declare 18077 Orig_Decl : constant Node_Id := Original_Node (N); 18078 18079 begin 18080 if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 18081 and then not Limited_Present (Parent (Priv_T)) 18082 and then not Synchronized_Present (Parent (Priv_T)) 18083 and then Nkind (Orig_Decl) = N_Full_Type_Declaration 18084 and then Nkind 18085 (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition 18086 and then Limited_Present (Type_Definition (Orig_Decl)) 18087 then 18088 Error_Msg_N 18089 ("full view of non-limited extension cannot be limited", N); 18090 end if; 18091 end; 18092 18093 -- Ada 2005 (AI-443): A synchronized private extension must be 18094 -- completed by a task or protected type. 18095 18096 if Ada_Version >= Ada_2005 18097 and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration 18098 and then Synchronized_Present (Parent (Priv_T)) 18099 and then not Is_Concurrent_Type (Full_T) 18100 then 18101 Error_Msg_N ("full view of synchronized extension must " & 18102 "be synchronized type", N); 18103 end if; 18104 18105 -- Ada 2005 AI-363: if the full view has discriminants with 18106 -- defaults, it is illegal to declare constrained access subtypes 18107 -- whose designated type is the current type. This allows objects 18108 -- of the type that are declared in the heap to be unconstrained. 18109 18110 if not Has_Unknown_Discriminants (Priv_T) 18111 and then not Has_Discriminants (Priv_T) 18112 and then Has_Discriminants (Full_T) 18113 and then 18114 Present (Discriminant_Default_Value (First_Discriminant (Full_T))) 18115 then 18116 Set_Has_Constrained_Partial_View (Full_T); 18117 Set_Has_Constrained_Partial_View (Priv_T); 18118 end if; 18119 18120 -- Create a full declaration for all its subtypes recorded in 18121 -- Private_Dependents and swap them similarly to the base type. These 18122 -- are subtypes that have been define before the full declaration of 18123 -- the private type. We also swap the entry in Private_Dependents list 18124 -- so we can properly restore the private view on exit from the scope. 18125 18126 declare 18127 Priv_Elmt : Elmt_Id; 18128 Priv : Entity_Id; 18129 Full : Entity_Id; 18130 18131 begin 18132 Priv_Elmt := First_Elmt (Private_Dependents (Priv_T)); 18133 while Present (Priv_Elmt) loop 18134 Priv := Node (Priv_Elmt); 18135 18136 if Ekind_In (Priv, E_Private_Subtype, 18137 E_Limited_Private_Subtype, 18138 E_Record_Subtype_With_Private) 18139 then 18140 Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); 18141 Set_Is_Itype (Full); 18142 Set_Parent (Full, Parent (Priv)); 18143 Set_Associated_Node_For_Itype (Full, N); 18144 18145 -- Now we need to complete the private subtype, but since the 18146 -- base type has already been swapped, we must also swap the 18147 -- subtypes (and thus, reverse the arguments in the call to 18148 -- Complete_Private_Subtype). 18149 18150 Copy_And_Swap (Priv, Full); 18151 Complete_Private_Subtype (Full, Priv, Full_T, N); 18152 Replace_Elmt (Priv_Elmt, Full); 18153 end if; 18154 18155 Next_Elmt (Priv_Elmt); 18156 end loop; 18157 end; 18158 18159 -- If the private view was tagged, copy the new primitive operations 18160 -- from the private view to the full view. 18161 18162 if Is_Tagged_Type (Full_T) then 18163 declare 18164 Disp_Typ : Entity_Id; 18165 Full_List : Elist_Id; 18166 Prim : Entity_Id; 18167 Prim_Elmt : Elmt_Id; 18168 Priv_List : Elist_Id; 18169 18170 function Contains 18171 (E : Entity_Id; 18172 L : Elist_Id) return Boolean; 18173 -- Determine whether list L contains element E 18174 18175 -------------- 18176 -- Contains -- 18177 -------------- 18178 18179 function Contains 18180 (E : Entity_Id; 18181 L : Elist_Id) return Boolean 18182 is 18183 List_Elmt : Elmt_Id; 18184 18185 begin 18186 List_Elmt := First_Elmt (L); 18187 while Present (List_Elmt) loop 18188 if Node (List_Elmt) = E then 18189 return True; 18190 end if; 18191 18192 Next_Elmt (List_Elmt); 18193 end loop; 18194 18195 return False; 18196 end Contains; 18197 18198 -- Start of processing 18199 18200 begin 18201 if Is_Tagged_Type (Priv_T) then 18202 Priv_List := Primitive_Operations (Priv_T); 18203 Prim_Elmt := First_Elmt (Priv_List); 18204 18205 -- In the case of a concurrent type completing a private tagged 18206 -- type, primitives may have been declared in between the two 18207 -- views. These subprograms need to be wrapped the same way 18208 -- entries and protected procedures are handled because they 18209 -- cannot be directly shared by the two views. 18210 18211 if Is_Concurrent_Type (Full_T) then 18212 declare 18213 Conc_Typ : constant Entity_Id := 18214 Corresponding_Record_Type (Full_T); 18215 Curr_Nod : Node_Id := Parent (Conc_Typ); 18216 Wrap_Spec : Node_Id; 18217 18218 begin 18219 while Present (Prim_Elmt) loop 18220 Prim := Node (Prim_Elmt); 18221 18222 if Comes_From_Source (Prim) 18223 and then not Is_Abstract_Subprogram (Prim) 18224 then 18225 Wrap_Spec := 18226 Make_Subprogram_Declaration (Sloc (Prim), 18227 Specification => 18228 Build_Wrapper_Spec 18229 (Subp_Id => Prim, 18230 Obj_Typ => Conc_Typ, 18231 Formals => 18232 Parameter_Specifications ( 18233 Parent (Prim)))); 18234 18235 Insert_After (Curr_Nod, Wrap_Spec); 18236 Curr_Nod := Wrap_Spec; 18237 18238 Analyze (Wrap_Spec); 18239 end if; 18240 18241 Next_Elmt (Prim_Elmt); 18242 end loop; 18243 18244 return; 18245 end; 18246 18247 -- For non-concurrent types, transfer explicit primitives, but 18248 -- omit those inherited from the parent of the private view 18249 -- since they will be re-inherited later on. 18250 18251 else 18252 Full_List := Primitive_Operations (Full_T); 18253 18254 while Present (Prim_Elmt) loop 18255 Prim := Node (Prim_Elmt); 18256 18257 if Comes_From_Source (Prim) 18258 and then not Contains (Prim, Full_List) 18259 then 18260 Append_Elmt (Prim, Full_List); 18261 end if; 18262 18263 Next_Elmt (Prim_Elmt); 18264 end loop; 18265 end if; 18266 18267 -- Untagged private view 18268 18269 else 18270 Full_List := Primitive_Operations (Full_T); 18271 18272 -- In this case the partial view is untagged, so here we locate 18273 -- all of the earlier primitives that need to be treated as 18274 -- dispatching (those that appear between the two views). Note 18275 -- that these additional operations must all be new operations 18276 -- (any earlier operations that override inherited operations 18277 -- of the full view will already have been inserted in the 18278 -- primitives list, marked by Check_Operation_From_Private_View 18279 -- as dispatching. Note that implicit "/=" operators are 18280 -- excluded from being added to the primitives list since they 18281 -- shouldn't be treated as dispatching (tagged "/=" is handled 18282 -- specially). 18283 18284 Prim := Next_Entity (Full_T); 18285 while Present (Prim) and then Prim /= Priv_T loop 18286 if Ekind_In (Prim, E_Procedure, E_Function) then 18287 Disp_Typ := Find_Dispatching_Type (Prim); 18288 18289 if Disp_Typ = Full_T 18290 and then (Chars (Prim) /= Name_Op_Ne 18291 or else Comes_From_Source (Prim)) 18292 then 18293 Check_Controlling_Formals (Full_T, Prim); 18294 18295 if not Is_Dispatching_Operation (Prim) then 18296 Append_Elmt (Prim, Full_List); 18297 Set_Is_Dispatching_Operation (Prim, True); 18298 Set_DT_Position (Prim, No_Uint); 18299 end if; 18300 18301 elsif Is_Dispatching_Operation (Prim) 18302 and then Disp_Typ /= Full_T 18303 then 18304 18305 -- Verify that it is not otherwise controlled by a 18306 -- formal or a return value of type T. 18307 18308 Check_Controlling_Formals (Disp_Typ, Prim); 18309 end if; 18310 end if; 18311 18312 Next_Entity (Prim); 18313 end loop; 18314 end if; 18315 18316 -- For the tagged case, the two views can share the same primitive 18317 -- operations list and the same class-wide type. Update attributes 18318 -- of the class-wide type which depend on the full declaration. 18319 18320 if Is_Tagged_Type (Priv_T) then 18321 Set_Direct_Primitive_Operations (Priv_T, Full_List); 18322 Set_Class_Wide_Type 18323 (Base_Type (Full_T), Class_Wide_Type (Priv_T)); 18324 18325 Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T)); 18326 end if; 18327 end; 18328 end if; 18329 18330 -- Ada 2005 AI 161: Check preelaboratable initialization consistency 18331 18332 if Known_To_Have_Preelab_Init (Priv_T) then 18333 18334 -- Case where there is a pragma Preelaborable_Initialization. We 18335 -- always allow this in predefined units, which is a bit of a kludge, 18336 -- but it means we don't have to struggle to meet the requirements in 18337 -- the RM for having Preelaborable Initialization. Otherwise we 18338 -- require that the type meets the RM rules. But we can't check that 18339 -- yet, because of the rule about overriding Initialize, so we simply 18340 -- set a flag that will be checked at freeze time. 18341 18342 if not In_Predefined_Unit (Full_T) then 18343 Set_Must_Have_Preelab_Init (Full_T); 18344 end if; 18345 end if; 18346 18347 -- If pragma CPP_Class was applied to the private type declaration, 18348 -- propagate it now to the full type declaration. 18349 18350 if Is_CPP_Class (Priv_T) then 18351 Set_Is_CPP_Class (Full_T); 18352 Set_Convention (Full_T, Convention_CPP); 18353 18354 -- Check that components of imported CPP types do not have default 18355 -- expressions. 18356 18357 Check_CPP_Type_Has_No_Defaults (Full_T); 18358 end if; 18359 18360 -- If the private view has user specified stream attributes, then so has 18361 -- the full view. 18362 18363 -- Why the test, how could these flags be already set in Full_T ??? 18364 18365 if Has_Specified_Stream_Read (Priv_T) then 18366 Set_Has_Specified_Stream_Read (Full_T); 18367 end if; 18368 18369 if Has_Specified_Stream_Write (Priv_T) then 18370 Set_Has_Specified_Stream_Write (Full_T); 18371 end if; 18372 18373 if Has_Specified_Stream_Input (Priv_T) then 18374 Set_Has_Specified_Stream_Input (Full_T); 18375 end if; 18376 18377 if Has_Specified_Stream_Output (Priv_T) then 18378 Set_Has_Specified_Stream_Output (Full_T); 18379 end if; 18380 18381 -- Propagate invariants to full type 18382 18383 if Has_Invariants (Priv_T) then 18384 Set_Has_Invariants (Full_T); 18385 Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T)); 18386 end if; 18387 18388 if Has_Inheritable_Invariants (Priv_T) then 18389 Set_Has_Inheritable_Invariants (Full_T); 18390 end if; 18391 18392 -- Propagate predicates to full type 18393 18394 if Has_Predicates (Priv_T) then 18395 Set_Predicate_Function (Priv_T, Predicate_Function (Full_T)); 18396 Set_Has_Predicates (Full_T); 18397 end if; 18398 end Process_Full_View; 18399 18400 ----------------------------------- 18401 -- Process_Incomplete_Dependents -- 18402 ----------------------------------- 18403 18404 procedure Process_Incomplete_Dependents 18405 (N : Node_Id; 18406 Full_T : Entity_Id; 18407 Inc_T : Entity_Id) 18408 is 18409 Inc_Elmt : Elmt_Id; 18410 Priv_Dep : Entity_Id; 18411 New_Subt : Entity_Id; 18412 18413 Disc_Constraint : Elist_Id; 18414 18415 begin 18416 if No (Private_Dependents (Inc_T)) then 18417 return; 18418 end if; 18419 18420 -- Itypes that may be generated by the completion of an incomplete 18421 -- subtype are not used by the back-end and not attached to the tree. 18422 -- They are created only for constraint-checking purposes. 18423 18424 Inc_Elmt := First_Elmt (Private_Dependents (Inc_T)); 18425 while Present (Inc_Elmt) loop 18426 Priv_Dep := Node (Inc_Elmt); 18427 18428 if Ekind (Priv_Dep) = E_Subprogram_Type then 18429 18430 -- An Access_To_Subprogram type may have a return type or a 18431 -- parameter type that is incomplete. Replace with the full view. 18432 18433 if Etype (Priv_Dep) = Inc_T then 18434 Set_Etype (Priv_Dep, Full_T); 18435 end if; 18436 18437 declare 18438 Formal : Entity_Id; 18439 18440 begin 18441 Formal := First_Formal (Priv_Dep); 18442 while Present (Formal) loop 18443 if Etype (Formal) = Inc_T then 18444 Set_Etype (Formal, Full_T); 18445 end if; 18446 18447 Next_Formal (Formal); 18448 end loop; 18449 end; 18450 18451 elsif Is_Overloadable (Priv_Dep) then 18452 18453 -- If a subprogram in the incomplete dependents list is primitive 18454 -- for a tagged full type then mark it as a dispatching operation, 18455 -- check whether it overrides an inherited subprogram, and check 18456 -- restrictions on its controlling formals. Note that a protected 18457 -- operation is never dispatching: only its wrapper operation 18458 -- (which has convention Ada) is. 18459 18460 if Is_Tagged_Type (Full_T) 18461 and then Is_Primitive (Priv_Dep) 18462 and then Convention (Priv_Dep) /= Convention_Protected 18463 then 18464 Check_Operation_From_Incomplete_Type (Priv_Dep, Inc_T); 18465 Set_Is_Dispatching_Operation (Priv_Dep); 18466 Check_Controlling_Formals (Full_T, Priv_Dep); 18467 end if; 18468 18469 elsif Ekind (Priv_Dep) = E_Subprogram_Body then 18470 18471 -- Can happen during processing of a body before the completion 18472 -- of a TA type. Ignore, because spec is also on dependent list. 18473 18474 return; 18475 18476 -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a 18477 -- corresponding subtype of the full view. 18478 18479 elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then 18480 Set_Subtype_Indication 18481 (Parent (Priv_Dep), New_Reference_To (Full_T, Sloc (Priv_Dep))); 18482 Set_Etype (Priv_Dep, Full_T); 18483 Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); 18484 Set_Analyzed (Parent (Priv_Dep), False); 18485 18486 -- Reanalyze the declaration, suppressing the call to 18487 -- Enter_Name to avoid duplicate names. 18488 18489 Analyze_Subtype_Declaration 18490 (N => Parent (Priv_Dep), 18491 Skip => True); 18492 18493 -- Dependent is a subtype 18494 18495 else 18496 -- We build a new subtype indication using the full view of the 18497 -- incomplete parent. The discriminant constraints have been 18498 -- elaborated already at the point of the subtype declaration. 18499 18500 New_Subt := Create_Itype (E_Void, N); 18501 18502 if Has_Discriminants (Full_T) then 18503 Disc_Constraint := Discriminant_Constraint (Priv_Dep); 18504 else 18505 Disc_Constraint := No_Elist; 18506 end if; 18507 18508 Build_Discriminated_Subtype (Full_T, New_Subt, Disc_Constraint, N); 18509 Set_Full_View (Priv_Dep, New_Subt); 18510 end if; 18511 18512 Next_Elmt (Inc_Elmt); 18513 end loop; 18514 end Process_Incomplete_Dependents; 18515 18516 -------------------------------- 18517 -- Process_Range_Expr_In_Decl -- 18518 -------------------------------- 18519 18520 procedure Process_Range_Expr_In_Decl 18521 (R : Node_Id; 18522 T : Entity_Id; 18523 Check_List : List_Id := Empty_List; 18524 R_Check_Off : Boolean := False; 18525 In_Iter_Schm : Boolean := False) 18526 is 18527 Lo, Hi : Node_Id; 18528 R_Checks : Check_Result; 18529 Insert_Node : Node_Id; 18530 Def_Id : Entity_Id; 18531 18532 begin 18533 Analyze_And_Resolve (R, Base_Type (T)); 18534 18535 if Nkind (R) = N_Range then 18536 18537 -- In SPARK, all ranges should be static, with the exception of the 18538 -- discrete type definition of a loop parameter specification. 18539 18540 if not In_Iter_Schm 18541 and then not Is_Static_Range (R) 18542 then 18543 Check_SPARK_Restriction ("range should be static", R); 18544 end if; 18545 18546 Lo := Low_Bound (R); 18547 Hi := High_Bound (R); 18548 18549 -- We need to ensure validity of the bounds here, because if we 18550 -- go ahead and do the expansion, then the expanded code will get 18551 -- analyzed with range checks suppressed and we miss the check. 18552 18553 Validity_Check_Range (R); 18554 18555 -- If there were errors in the declaration, try and patch up some 18556 -- common mistakes in the bounds. The cases handled are literals 18557 -- which are Integer where the expected type is Real and vice versa. 18558 -- These corrections allow the compilation process to proceed further 18559 -- along since some basic assumptions of the format of the bounds 18560 -- are guaranteed. 18561 18562 if Etype (R) = Any_Type then 18563 18564 if Nkind (Lo) = N_Integer_Literal and then Is_Real_Type (T) then 18565 Rewrite (Lo, 18566 Make_Real_Literal (Sloc (Lo), UR_From_Uint (Intval (Lo)))); 18567 18568 elsif Nkind (Hi) = N_Integer_Literal and then Is_Real_Type (T) then 18569 Rewrite (Hi, 18570 Make_Real_Literal (Sloc (Hi), UR_From_Uint (Intval (Hi)))); 18571 18572 elsif Nkind (Lo) = N_Real_Literal and then Is_Integer_Type (T) then 18573 Rewrite (Lo, 18574 Make_Integer_Literal (Sloc (Lo), UR_To_Uint (Realval (Lo)))); 18575 18576 elsif Nkind (Hi) = N_Real_Literal and then Is_Integer_Type (T) then 18577 Rewrite (Hi, 18578 Make_Integer_Literal (Sloc (Hi), UR_To_Uint (Realval (Hi)))); 18579 end if; 18580 18581 Set_Etype (Lo, T); 18582 Set_Etype (Hi, T); 18583 end if; 18584 18585 -- If the bounds of the range have been mistakenly given as string 18586 -- literals (perhaps in place of character literals), then an error 18587 -- has already been reported, but we rewrite the string literal as a 18588 -- bound of the range's type to avoid blowups in later processing 18589 -- that looks at static values. 18590 18591 if Nkind (Lo) = N_String_Literal then 18592 Rewrite (Lo, 18593 Make_Attribute_Reference (Sloc (Lo), 18594 Attribute_Name => Name_First, 18595 Prefix => New_Reference_To (T, Sloc (Lo)))); 18596 Analyze_And_Resolve (Lo); 18597 end if; 18598 18599 if Nkind (Hi) = N_String_Literal then 18600 Rewrite (Hi, 18601 Make_Attribute_Reference (Sloc (Hi), 18602 Attribute_Name => Name_First, 18603 Prefix => New_Reference_To (T, Sloc (Hi)))); 18604 Analyze_And_Resolve (Hi); 18605 end if; 18606 18607 -- If bounds aren't scalar at this point then exit, avoiding 18608 -- problems with further processing of the range in this procedure. 18609 18610 if not Is_Scalar_Type (Etype (Lo)) then 18611 return; 18612 end if; 18613 18614 -- Resolve (actually Sem_Eval) has checked that the bounds are in 18615 -- then range of the base type. Here we check whether the bounds 18616 -- are in the range of the subtype itself. Note that if the bounds 18617 -- represent the null range the Constraint_Error exception should 18618 -- not be raised. 18619 18620 -- ??? The following code should be cleaned up as follows 18621 18622 -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it 18623 -- is done in the call to Range_Check (R, T); below 18624 18625 -- 2. The use of R_Check_Off should be investigated and possibly 18626 -- removed, this would clean up things a bit. 18627 18628 if Is_Null_Range (Lo, Hi) then 18629 null; 18630 18631 else 18632 -- Capture values of bounds and generate temporaries for them 18633 -- if needed, before applying checks, since checks may cause 18634 -- duplication of the expression without forcing evaluation. 18635 18636 -- The forced evaluation removes side effects from expressions, 18637 -- which should occur also in Alfa mode. Otherwise, we end up with 18638 -- unexpected insertions of actions at places where this is not 18639 -- supposed to occur, e.g. on default parameters of a call. 18640 18641 if Expander_Active then 18642 Force_Evaluation (Lo); 18643 Force_Evaluation (Hi); 18644 end if; 18645 18646 -- We use a flag here instead of suppressing checks on the 18647 -- type because the type we check against isn't necessarily 18648 -- the place where we put the check. 18649 18650 if not R_Check_Off then 18651 R_Checks := Get_Range_Checks (R, T); 18652 18653 -- Look up tree to find an appropriate insertion point. We 18654 -- can't just use insert_actions because later processing 18655 -- depends on the insertion node. Prior to Ada 2012 the 18656 -- insertion point could only be a declaration or a loop, but 18657 -- quantified expressions can appear within any context in an 18658 -- expression, and the insertion point can be any statement, 18659 -- pragma, or declaration. 18660 18661 Insert_Node := Parent (R); 18662 while Present (Insert_Node) loop 18663 exit when 18664 Nkind (Insert_Node) in N_Declaration 18665 and then 18666 not Nkind_In 18667 (Insert_Node, N_Component_Declaration, 18668 N_Loop_Parameter_Specification, 18669 N_Function_Specification, 18670 N_Procedure_Specification); 18671 18672 exit when Nkind (Insert_Node) in N_Later_Decl_Item 18673 or else Nkind (Insert_Node) in 18674 N_Statement_Other_Than_Procedure_Call 18675 or else Nkind_In (Insert_Node, N_Procedure_Call_Statement, 18676 N_Pragma); 18677 18678 Insert_Node := Parent (Insert_Node); 18679 end loop; 18680 18681 -- Why would Type_Decl not be present??? Without this test, 18682 -- short regression tests fail. 18683 18684 if Present (Insert_Node) then 18685 18686 -- Case of loop statement. Verify that the range is part 18687 -- of the subtype indication of the iteration scheme. 18688 18689 if Nkind (Insert_Node) = N_Loop_Statement then 18690 declare 18691 Indic : Node_Id; 18692 18693 begin 18694 Indic := Parent (R); 18695 while Present (Indic) 18696 and then Nkind (Indic) /= N_Subtype_Indication 18697 loop 18698 Indic := Parent (Indic); 18699 end loop; 18700 18701 if Present (Indic) then 18702 Def_Id := Etype (Subtype_Mark (Indic)); 18703 18704 Insert_Range_Checks 18705 (R_Checks, 18706 Insert_Node, 18707 Def_Id, 18708 Sloc (Insert_Node), 18709 R, 18710 Do_Before => True); 18711 end if; 18712 end; 18713 18714 -- Insertion before a declaration. If the declaration 18715 -- includes discriminants, the list of applicable checks 18716 -- is given by the caller. 18717 18718 elsif Nkind (Insert_Node) in N_Declaration then 18719 Def_Id := Defining_Identifier (Insert_Node); 18720 18721 if (Ekind (Def_Id) = E_Record_Type 18722 and then Depends_On_Discriminant (R)) 18723 or else 18724 (Ekind (Def_Id) = E_Protected_Type 18725 and then Has_Discriminants (Def_Id)) 18726 then 18727 Append_Range_Checks 18728 (R_Checks, 18729 Check_List, Def_Id, Sloc (Insert_Node), R); 18730 18731 else 18732 Insert_Range_Checks 18733 (R_Checks, 18734 Insert_Node, Def_Id, Sloc (Insert_Node), R); 18735 18736 end if; 18737 18738 -- Insertion before a statement. Range appears in the 18739 -- context of a quantified expression. Insertion will 18740 -- take place when expression is expanded. 18741 18742 else 18743 null; 18744 end if; 18745 end if; 18746 end if; 18747 end if; 18748 18749 -- Case of other than an explicit N_Range node 18750 18751 -- The forced evaluation removes side effects from expressions, which 18752 -- should occur also in Alfa mode. Otherwise, we end up with unexpected 18753 -- insertions of actions at places where this is not supposed to occur, 18754 -- e.g. on default parameters of a call. 18755 18756 elsif Expander_Active then 18757 Get_Index_Bounds (R, Lo, Hi); 18758 Force_Evaluation (Lo); 18759 Force_Evaluation (Hi); 18760 end if; 18761 end Process_Range_Expr_In_Decl; 18762 18763 -------------------------------------- 18764 -- Process_Real_Range_Specification -- 18765 -------------------------------------- 18766 18767 procedure Process_Real_Range_Specification (Def : Node_Id) is 18768 Spec : constant Node_Id := Real_Range_Specification (Def); 18769 Lo : Node_Id; 18770 Hi : Node_Id; 18771 Err : Boolean := False; 18772 18773 procedure Analyze_Bound (N : Node_Id); 18774 -- Analyze and check one bound 18775 18776 ------------------- 18777 -- Analyze_Bound -- 18778 ------------------- 18779 18780 procedure Analyze_Bound (N : Node_Id) is 18781 begin 18782 Analyze_And_Resolve (N, Any_Real); 18783 18784 if not Is_OK_Static_Expression (N) then 18785 Flag_Non_Static_Expr 18786 ("bound in real type definition is not static!", N); 18787 Err := True; 18788 end if; 18789 end Analyze_Bound; 18790 18791 -- Start of processing for Process_Real_Range_Specification 18792 18793 begin 18794 if Present (Spec) then 18795 Lo := Low_Bound (Spec); 18796 Hi := High_Bound (Spec); 18797 Analyze_Bound (Lo); 18798 Analyze_Bound (Hi); 18799 18800 -- If error, clear away junk range specification 18801 18802 if Err then 18803 Set_Real_Range_Specification (Def, Empty); 18804 end if; 18805 end if; 18806 end Process_Real_Range_Specification; 18807 18808 --------------------- 18809 -- Process_Subtype -- 18810 --------------------- 18811 18812 function Process_Subtype 18813 (S : Node_Id; 18814 Related_Nod : Node_Id; 18815 Related_Id : Entity_Id := Empty; 18816 Suffix : Character := ' ') return Entity_Id 18817 is 18818 P : Node_Id; 18819 Def_Id : Entity_Id; 18820 Error_Node : Node_Id; 18821 Full_View_Id : Entity_Id; 18822 Subtype_Mark_Id : Entity_Id; 18823 18824 May_Have_Null_Exclusion : Boolean; 18825 18826 procedure Check_Incomplete (T : Entity_Id); 18827 -- Called to verify that an incomplete type is not used prematurely 18828 18829 ---------------------- 18830 -- Check_Incomplete -- 18831 ---------------------- 18832 18833 procedure Check_Incomplete (T : Entity_Id) is 18834 begin 18835 -- Ada 2005 (AI-412): Incomplete subtypes are legal 18836 18837 if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type 18838 and then 18839 not (Ada_Version >= Ada_2005 18840 and then 18841 (Nkind (Parent (T)) = N_Subtype_Declaration 18842 or else 18843 (Nkind (Parent (T)) = N_Subtype_Indication 18844 and then Nkind (Parent (Parent (T))) = 18845 N_Subtype_Declaration))) 18846 then 18847 Error_Msg_N ("invalid use of type before its full declaration", T); 18848 end if; 18849 end Check_Incomplete; 18850 18851 -- Start of processing for Process_Subtype 18852 18853 begin 18854 -- Case of no constraints present 18855 18856 if Nkind (S) /= N_Subtype_Indication then 18857 Find_Type (S); 18858 Check_Incomplete (S); 18859 P := Parent (S); 18860 18861 -- Ada 2005 (AI-231): Static check 18862 18863 if Ada_Version >= Ada_2005 18864 and then Present (P) 18865 and then Null_Exclusion_Present (P) 18866 and then Nkind (P) /= N_Access_To_Object_Definition 18867 and then not Is_Access_Type (Entity (S)) 18868 then 18869 Error_Msg_N ("`NOT NULL` only allowed for an access type", S); 18870 end if; 18871 18872 -- The following is ugly, can't we have a range or even a flag??? 18873 18874 May_Have_Null_Exclusion := 18875 Nkind_In (P, N_Access_Definition, 18876 N_Access_Function_Definition, 18877 N_Access_Procedure_Definition, 18878 N_Access_To_Object_Definition, 18879 N_Allocator, 18880 N_Component_Definition) 18881 or else 18882 Nkind_In (P, N_Derived_Type_Definition, 18883 N_Discriminant_Specification, 18884 N_Formal_Object_Declaration, 18885 N_Object_Declaration, 18886 N_Object_Renaming_Declaration, 18887 N_Parameter_Specification, 18888 N_Subtype_Declaration); 18889 18890 -- Create an Itype that is a duplicate of Entity (S) but with the 18891 -- null-exclusion attribute. 18892 18893 if May_Have_Null_Exclusion 18894 and then Is_Access_Type (Entity (S)) 18895 and then Null_Exclusion_Present (P) 18896 18897 -- No need to check the case of an access to object definition. 18898 -- It is correct to define double not-null pointers. 18899 18900 -- Example: 18901 -- type Not_Null_Int_Ptr is not null access Integer; 18902 -- type Acc is not null access Not_Null_Int_Ptr; 18903 18904 and then Nkind (P) /= N_Access_To_Object_Definition 18905 then 18906 if Can_Never_Be_Null (Entity (S)) then 18907 case Nkind (Related_Nod) is 18908 when N_Full_Type_Declaration => 18909 if Nkind (Type_Definition (Related_Nod)) 18910 in N_Array_Type_Definition 18911 then 18912 Error_Node := 18913 Subtype_Indication 18914 (Component_Definition 18915 (Type_Definition (Related_Nod))); 18916 else 18917 Error_Node := 18918 Subtype_Indication (Type_Definition (Related_Nod)); 18919 end if; 18920 18921 when N_Subtype_Declaration => 18922 Error_Node := Subtype_Indication (Related_Nod); 18923 18924 when N_Object_Declaration => 18925 Error_Node := Object_Definition (Related_Nod); 18926 18927 when N_Component_Declaration => 18928 Error_Node := 18929 Subtype_Indication (Component_Definition (Related_Nod)); 18930 18931 when N_Allocator => 18932 Error_Node := Expression (Related_Nod); 18933 18934 when others => 18935 pragma Assert (False); 18936 Error_Node := Related_Nod; 18937 end case; 18938 18939 Error_Msg_NE 18940 ("`NOT NULL` not allowed (& already excludes null)", 18941 Error_Node, 18942 Entity (S)); 18943 end if; 18944 18945 Set_Etype (S, 18946 Create_Null_Excluding_Itype 18947 (T => Entity (S), 18948 Related_Nod => P)); 18949 Set_Entity (S, Etype (S)); 18950 end if; 18951 18952 return Entity (S); 18953 18954 -- Case of constraint present, so that we have an N_Subtype_Indication 18955 -- node (this node is created only if constraints are present). 18956 18957 else 18958 Find_Type (Subtype_Mark (S)); 18959 18960 if Nkind (Parent (S)) /= N_Access_To_Object_Definition 18961 and then not 18962 (Nkind (Parent (S)) = N_Subtype_Declaration 18963 and then Is_Itype (Defining_Identifier (Parent (S)))) 18964 then 18965 Check_Incomplete (Subtype_Mark (S)); 18966 end if; 18967 18968 P := Parent (S); 18969 Subtype_Mark_Id := Entity (Subtype_Mark (S)); 18970 18971 -- Explicit subtype declaration case 18972 18973 if Nkind (P) = N_Subtype_Declaration then 18974 Def_Id := Defining_Identifier (P); 18975 18976 -- Explicit derived type definition case 18977 18978 elsif Nkind (P) = N_Derived_Type_Definition then 18979 Def_Id := Defining_Identifier (Parent (P)); 18980 18981 -- Implicit case, the Def_Id must be created as an implicit type. 18982 -- The one exception arises in the case of concurrent types, array 18983 -- and access types, where other subsidiary implicit types may be 18984 -- created and must appear before the main implicit type. In these 18985 -- cases we leave Def_Id set to Empty as a signal that Create_Itype 18986 -- has not yet been called to create Def_Id. 18987 18988 else 18989 if Is_Array_Type (Subtype_Mark_Id) 18990 or else Is_Concurrent_Type (Subtype_Mark_Id) 18991 or else Is_Access_Type (Subtype_Mark_Id) 18992 then 18993 Def_Id := Empty; 18994 18995 -- For the other cases, we create a new unattached Itype, 18996 -- and set the indication to ensure it gets attached later. 18997 18998 else 18999 Def_Id := 19000 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 19001 end if; 19002 end if; 19003 19004 -- If the kind of constraint is invalid for this kind of type, 19005 -- then give an error, and then pretend no constraint was given. 19006 19007 if not Is_Valid_Constraint_Kind 19008 (Ekind (Subtype_Mark_Id), Nkind (Constraint (S))) 19009 then 19010 Error_Msg_N 19011 ("incorrect constraint for this kind of type", Constraint (S)); 19012 19013 Rewrite (S, New_Copy_Tree (Subtype_Mark (S))); 19014 19015 -- Set Ekind of orphan itype, to prevent cascaded errors 19016 19017 if Present (Def_Id) then 19018 Set_Ekind (Def_Id, Ekind (Any_Type)); 19019 end if; 19020 19021 -- Make recursive call, having got rid of the bogus constraint 19022 19023 return Process_Subtype (S, Related_Nod, Related_Id, Suffix); 19024 end if; 19025 19026 -- Remaining processing depends on type. Select on Base_Type kind to 19027 -- ensure getting to the concrete type kind in the case of a private 19028 -- subtype (needed when only doing semantic analysis). 19029 19030 case Ekind (Base_Type (Subtype_Mark_Id)) is 19031 when Access_Kind => 19032 Constrain_Access (Def_Id, S, Related_Nod); 19033 19034 if Expander_Active 19035 and then Is_Itype (Designated_Type (Def_Id)) 19036 and then Nkind (Related_Nod) = N_Subtype_Declaration 19037 and then not Is_Incomplete_Type (Designated_Type (Def_Id)) 19038 then 19039 Build_Itype_Reference 19040 (Designated_Type (Def_Id), Related_Nod); 19041 end if; 19042 19043 when Array_Kind => 19044 Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); 19045 19046 when Decimal_Fixed_Point_Kind => 19047 Constrain_Decimal (Def_Id, S); 19048 19049 when Enumeration_Kind => 19050 Constrain_Enumeration (Def_Id, S); 19051 19052 when Ordinary_Fixed_Point_Kind => 19053 Constrain_Ordinary_Fixed (Def_Id, S); 19054 19055 when Float_Kind => 19056 Constrain_Float (Def_Id, S); 19057 19058 when Integer_Kind => 19059 Constrain_Integer (Def_Id, S); 19060 19061 when E_Record_Type | 19062 E_Record_Subtype | 19063 Class_Wide_Kind | 19064 E_Incomplete_Type => 19065 Constrain_Discriminated_Type (Def_Id, S, Related_Nod); 19066 19067 if Ekind (Def_Id) = E_Incomplete_Type then 19068 Set_Private_Dependents (Def_Id, New_Elmt_List); 19069 end if; 19070 19071 when Private_Kind => 19072 Constrain_Discriminated_Type (Def_Id, S, Related_Nod); 19073 Set_Private_Dependents (Def_Id, New_Elmt_List); 19074 19075 -- In case of an invalid constraint prevent further processing 19076 -- since the type constructed is missing expected fields. 19077 19078 if Etype (Def_Id) = Any_Type then 19079 return Def_Id; 19080 end if; 19081 19082 -- If the full view is that of a task with discriminants, 19083 -- we must constrain both the concurrent type and its 19084 -- corresponding record type. Otherwise we will just propagate 19085 -- the constraint to the full view, if available. 19086 19087 if Present (Full_View (Subtype_Mark_Id)) 19088 and then Has_Discriminants (Subtype_Mark_Id) 19089 and then Is_Concurrent_Type (Full_View (Subtype_Mark_Id)) 19090 then 19091 Full_View_Id := 19092 Create_Itype (E_Void, Related_Nod, Related_Id, Suffix); 19093 19094 Set_Entity (Subtype_Mark (S), Full_View (Subtype_Mark_Id)); 19095 Constrain_Concurrent (Full_View_Id, S, 19096 Related_Nod, Related_Id, Suffix); 19097 Set_Entity (Subtype_Mark (S), Subtype_Mark_Id); 19098 Set_Full_View (Def_Id, Full_View_Id); 19099 19100 -- Introduce an explicit reference to the private subtype, 19101 -- to prevent scope anomalies in gigi if first use appears 19102 -- in a nested context, e.g. a later function body. 19103 -- Should this be generated in other contexts than a full 19104 -- type declaration? 19105 19106 if Is_Itype (Def_Id) 19107 and then 19108 Nkind (Parent (P)) = N_Full_Type_Declaration 19109 then 19110 Build_Itype_Reference (Def_Id, Parent (P)); 19111 end if; 19112 19113 else 19114 Prepare_Private_Subtype_Completion (Def_Id, Related_Nod); 19115 end if; 19116 19117 when Concurrent_Kind => 19118 Constrain_Concurrent (Def_Id, S, 19119 Related_Nod, Related_Id, Suffix); 19120 19121 when others => 19122 Error_Msg_N ("invalid subtype mark in subtype indication", S); 19123 end case; 19124 19125 -- Size and Convention are always inherited from the base type 19126 19127 Set_Size_Info (Def_Id, (Subtype_Mark_Id)); 19128 Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); 19129 19130 return Def_Id; 19131 end if; 19132 end Process_Subtype; 19133 19134 --------------------------------------- 19135 -- Check_Anonymous_Access_Components -- 19136 --------------------------------------- 19137 19138 procedure Check_Anonymous_Access_Components 19139 (Typ_Decl : Node_Id; 19140 Typ : Entity_Id; 19141 Prev : Entity_Id; 19142 Comp_List : Node_Id) 19143 is 19144 Loc : constant Source_Ptr := Sloc (Typ_Decl); 19145 Anon_Access : Entity_Id; 19146 Acc_Def : Node_Id; 19147 Comp : Node_Id; 19148 Comp_Def : Node_Id; 19149 Decl : Node_Id; 19150 Type_Def : Node_Id; 19151 19152 procedure Build_Incomplete_Type_Declaration; 19153 -- If the record type contains components that include an access to the 19154 -- current record, then create an incomplete type declaration for the 19155 -- record, to be used as the designated type of the anonymous access. 19156 -- This is done only once, and only if there is no previous partial 19157 -- view of the type. 19158 19159 function Designates_T (Subt : Node_Id) return Boolean; 19160 -- Check whether a node designates the enclosing record type, or 'Class 19161 -- of that type 19162 19163 function Mentions_T (Acc_Def : Node_Id) return Boolean; 19164 -- Check whether an access definition includes a reference to 19165 -- the enclosing record type. The reference can be a subtype mark 19166 -- in the access definition itself, a 'Class attribute reference, or 19167 -- recursively a reference appearing in a parameter specification 19168 -- or result definition of an access_to_subprogram definition. 19169 19170 -------------------------------------- 19171 -- Build_Incomplete_Type_Declaration -- 19172 -------------------------------------- 19173 19174 procedure Build_Incomplete_Type_Declaration is 19175 Decl : Node_Id; 19176 Inc_T : Entity_Id; 19177 H : Entity_Id; 19178 19179 -- Is_Tagged indicates whether the type is tagged. It is tagged if 19180 -- it's "is new ... with record" or else "is tagged record ...". 19181 19182 Is_Tagged : constant Boolean := 19183 (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition 19184 and then 19185 Present 19186 (Record_Extension_Part (Type_Definition (Typ_Decl)))) 19187 or else 19188 (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition 19189 and then Tagged_Present (Type_Definition (Typ_Decl))); 19190 19191 begin 19192 -- If there is a previous partial view, no need to create a new one 19193 -- If the partial view, given by Prev, is incomplete, If Prev is 19194 -- a private declaration, full declaration is flagged accordingly. 19195 19196 if Prev /= Typ then 19197 if Is_Tagged then 19198 Make_Class_Wide_Type (Prev); 19199 Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev)); 19200 Set_Etype (Class_Wide_Type (Typ), Typ); 19201 end if; 19202 19203 return; 19204 19205 elsif Has_Private_Declaration (Typ) then 19206 19207 -- If we refer to T'Class inside T, and T is the completion of a 19208 -- private type, then we need to make sure the class-wide type 19209 -- exists. 19210 19211 if Is_Tagged then 19212 Make_Class_Wide_Type (Typ); 19213 end if; 19214 19215 return; 19216 19217 -- If there was a previous anonymous access type, the incomplete 19218 -- type declaration will have been created already. 19219 19220 elsif Present (Current_Entity (Typ)) 19221 and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type 19222 and then Full_View (Current_Entity (Typ)) = Typ 19223 then 19224 if Is_Tagged 19225 and then Comes_From_Source (Current_Entity (Typ)) 19226 and then not Is_Tagged_Type (Current_Entity (Typ)) 19227 then 19228 Make_Class_Wide_Type (Typ); 19229 Error_Msg_N 19230 ("incomplete view of tagged type should be declared tagged??", 19231 Parent (Current_Entity (Typ))); 19232 end if; 19233 return; 19234 19235 else 19236 Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); 19237 Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); 19238 19239 -- Type has already been inserted into the current scope. Remove 19240 -- it, and add incomplete declaration for type, so that subsequent 19241 -- anonymous access types can use it. The entity is unchained from 19242 -- the homonym list and from immediate visibility. After analysis, 19243 -- the entity in the incomplete declaration becomes immediately 19244 -- visible in the record declaration that follows. 19245 19246 H := Current_Entity (Typ); 19247 19248 if H = Typ then 19249 Set_Name_Entity_Id (Chars (Typ), Homonym (Typ)); 19250 else 19251 while Present (H) 19252 and then Homonym (H) /= Typ 19253 loop 19254 H := Homonym (Typ); 19255 end loop; 19256 19257 Set_Homonym (H, Homonym (Typ)); 19258 end if; 19259 19260 Insert_Before (Typ_Decl, Decl); 19261 Analyze (Decl); 19262 Set_Full_View (Inc_T, Typ); 19263 19264 if Is_Tagged then 19265 19266 -- Create a common class-wide type for both views, and set the 19267 -- Etype of the class-wide type to the full view. 19268 19269 Make_Class_Wide_Type (Inc_T); 19270 Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); 19271 Set_Etype (Class_Wide_Type (Typ), Typ); 19272 end if; 19273 end if; 19274 end Build_Incomplete_Type_Declaration; 19275 19276 ------------------ 19277 -- Designates_T -- 19278 ------------------ 19279 19280 function Designates_T (Subt : Node_Id) return Boolean is 19281 Type_Id : constant Name_Id := Chars (Typ); 19282 19283 function Names_T (Nam : Node_Id) return Boolean; 19284 -- The record type has not been introduced in the current scope 19285 -- yet, so we must examine the name of the type itself, either 19286 -- an identifier T, or an expanded name of the form P.T, where 19287 -- P denotes the current scope. 19288 19289 ------------- 19290 -- Names_T -- 19291 ------------- 19292 19293 function Names_T (Nam : Node_Id) return Boolean is 19294 begin 19295 if Nkind (Nam) = N_Identifier then 19296 return Chars (Nam) = Type_Id; 19297 19298 elsif Nkind (Nam) = N_Selected_Component then 19299 if Chars (Selector_Name (Nam)) = Type_Id then 19300 if Nkind (Prefix (Nam)) = N_Identifier then 19301 return Chars (Prefix (Nam)) = Chars (Current_Scope); 19302 19303 elsif Nkind (Prefix (Nam)) = N_Selected_Component then 19304 return Chars (Selector_Name (Prefix (Nam))) = 19305 Chars (Current_Scope); 19306 else 19307 return False; 19308 end if; 19309 19310 else 19311 return False; 19312 end if; 19313 19314 else 19315 return False; 19316 end if; 19317 end Names_T; 19318 19319 -- Start of processing for Designates_T 19320 19321 begin 19322 if Nkind (Subt) = N_Identifier then 19323 return Chars (Subt) = Type_Id; 19324 19325 -- Reference can be through an expanded name which has not been 19326 -- analyzed yet, and which designates enclosing scopes. 19327 19328 elsif Nkind (Subt) = N_Selected_Component then 19329 if Names_T (Subt) then 19330 return True; 19331 19332 -- Otherwise it must denote an entity that is already visible. 19333 -- The access definition may name a subtype of the enclosing 19334 -- type, if there is a previous incomplete declaration for it. 19335 19336 else 19337 Find_Selected_Component (Subt); 19338 return 19339 Is_Entity_Name (Subt) 19340 and then Scope (Entity (Subt)) = Current_Scope 19341 and then 19342 (Chars (Base_Type (Entity (Subt))) = Type_Id 19343 or else 19344 (Is_Class_Wide_Type (Entity (Subt)) 19345 and then 19346 Chars (Etype (Base_Type (Entity (Subt)))) = 19347 Type_Id)); 19348 end if; 19349 19350 -- A reference to the current type may appear as the prefix of 19351 -- a 'Class attribute. 19352 19353 elsif Nkind (Subt) = N_Attribute_Reference 19354 and then Attribute_Name (Subt) = Name_Class 19355 then 19356 return Names_T (Prefix (Subt)); 19357 19358 else 19359 return False; 19360 end if; 19361 end Designates_T; 19362 19363 ---------------- 19364 -- Mentions_T -- 19365 ---------------- 19366 19367 function Mentions_T (Acc_Def : Node_Id) return Boolean is 19368 Param_Spec : Node_Id; 19369 19370 Acc_Subprg : constant Node_Id := 19371 Access_To_Subprogram_Definition (Acc_Def); 19372 19373 begin 19374 if No (Acc_Subprg) then 19375 return Designates_T (Subtype_Mark (Acc_Def)); 19376 end if; 19377 19378 -- Component is an access_to_subprogram: examine its formals, 19379 -- and result definition in the case of an access_to_function. 19380 19381 Param_Spec := First (Parameter_Specifications (Acc_Subprg)); 19382 while Present (Param_Spec) loop 19383 if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition 19384 and then Mentions_T (Parameter_Type (Param_Spec)) 19385 then 19386 return True; 19387 19388 elsif Designates_T (Parameter_Type (Param_Spec)) then 19389 return True; 19390 end if; 19391 19392 Next (Param_Spec); 19393 end loop; 19394 19395 if Nkind (Acc_Subprg) = N_Access_Function_Definition then 19396 if Nkind (Result_Definition (Acc_Subprg)) = 19397 N_Access_Definition 19398 then 19399 return Mentions_T (Result_Definition (Acc_Subprg)); 19400 else 19401 return Designates_T (Result_Definition (Acc_Subprg)); 19402 end if; 19403 end if; 19404 19405 return False; 19406 end Mentions_T; 19407 19408 -- Start of processing for Check_Anonymous_Access_Components 19409 19410 begin 19411 if No (Comp_List) then 19412 return; 19413 end if; 19414 19415 Comp := First (Component_Items (Comp_List)); 19416 while Present (Comp) loop 19417 if Nkind (Comp) = N_Component_Declaration 19418 and then Present 19419 (Access_Definition (Component_Definition (Comp))) 19420 and then 19421 Mentions_T (Access_Definition (Component_Definition (Comp))) 19422 then 19423 Comp_Def := Component_Definition (Comp); 19424 Acc_Def := 19425 Access_To_Subprogram_Definition 19426 (Access_Definition (Comp_Def)); 19427 19428 Build_Incomplete_Type_Declaration; 19429 Anon_Access := Make_Temporary (Loc, 'S'); 19430 19431 -- Create a declaration for the anonymous access type: either 19432 -- an access_to_object or an access_to_subprogram. 19433 19434 if Present (Acc_Def) then 19435 if Nkind (Acc_Def) = N_Access_Function_Definition then 19436 Type_Def := 19437 Make_Access_Function_Definition (Loc, 19438 Parameter_Specifications => 19439 Parameter_Specifications (Acc_Def), 19440 Result_Definition => Result_Definition (Acc_Def)); 19441 else 19442 Type_Def := 19443 Make_Access_Procedure_Definition (Loc, 19444 Parameter_Specifications => 19445 Parameter_Specifications (Acc_Def)); 19446 end if; 19447 19448 else 19449 Type_Def := 19450 Make_Access_To_Object_Definition (Loc, 19451 Subtype_Indication => 19452 Relocate_Node 19453 (Subtype_Mark 19454 (Access_Definition (Comp_Def)))); 19455 19456 Set_Constant_Present 19457 (Type_Def, Constant_Present (Access_Definition (Comp_Def))); 19458 Set_All_Present 19459 (Type_Def, All_Present (Access_Definition (Comp_Def))); 19460 end if; 19461 19462 Set_Null_Exclusion_Present 19463 (Type_Def, 19464 Null_Exclusion_Present (Access_Definition (Comp_Def))); 19465 19466 Decl := 19467 Make_Full_Type_Declaration (Loc, 19468 Defining_Identifier => Anon_Access, 19469 Type_Definition => Type_Def); 19470 19471 Insert_Before (Typ_Decl, Decl); 19472 Analyze (Decl); 19473 19474 -- If an access to subprogram, create the extra formals 19475 19476 if Present (Acc_Def) then 19477 Create_Extra_Formals (Designated_Type (Anon_Access)); 19478 19479 -- If an access to object, preserve entity of designated type, 19480 -- for ASIS use, before rewriting the component definition. 19481 19482 else 19483 declare 19484 Desig : Entity_Id; 19485 19486 begin 19487 Desig := Entity (Subtype_Indication (Type_Def)); 19488 19489 -- If the access definition is to the current record, 19490 -- the visible entity at this point is an incomplete 19491 -- type. Retrieve the full view to simplify ASIS queries 19492 19493 if Ekind (Desig) = E_Incomplete_Type then 19494 Desig := Full_View (Desig); 19495 end if; 19496 19497 Set_Entity 19498 (Subtype_Mark (Access_Definition (Comp_Def)), Desig); 19499 end; 19500 end if; 19501 19502 Rewrite (Comp_Def, 19503 Make_Component_Definition (Loc, 19504 Subtype_Indication => 19505 New_Occurrence_Of (Anon_Access, Loc))); 19506 19507 if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then 19508 Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); 19509 else 19510 Set_Ekind (Anon_Access, E_Anonymous_Access_Type); 19511 end if; 19512 19513 Set_Is_Local_Anonymous_Access (Anon_Access); 19514 end if; 19515 19516 Next (Comp); 19517 end loop; 19518 19519 if Present (Variant_Part (Comp_List)) then 19520 declare 19521 V : Node_Id; 19522 begin 19523 V := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 19524 while Present (V) loop 19525 Check_Anonymous_Access_Components 19526 (Typ_Decl, Typ, Prev, Component_List (V)); 19527 Next_Non_Pragma (V); 19528 end loop; 19529 end; 19530 end if; 19531 end Check_Anonymous_Access_Components; 19532 19533 ---------------------------------- 19534 -- Preanalyze_Assert_Expression -- 19535 ---------------------------------- 19536 19537 procedure Preanalyze_Assert_Expression (N : Node_Id; T : Entity_Id) is 19538 begin 19539 In_Assertion_Expr := In_Assertion_Expr + 1; 19540 Preanalyze_Spec_Expression (N, T); 19541 In_Assertion_Expr := In_Assertion_Expr - 1; 19542 end Preanalyze_Assert_Expression; 19543 19544 -------------------------------- 19545 -- Preanalyze_Spec_Expression -- 19546 -------------------------------- 19547 19548 procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id) is 19549 Save_In_Spec_Expression : constant Boolean := In_Spec_Expression; 19550 begin 19551 In_Spec_Expression := True; 19552 Preanalyze_And_Resolve (N, T); 19553 In_Spec_Expression := Save_In_Spec_Expression; 19554 end Preanalyze_Spec_Expression; 19555 19556 ----------------------------- 19557 -- Record_Type_Declaration -- 19558 ----------------------------- 19559 19560 procedure Record_Type_Declaration 19561 (T : Entity_Id; 19562 N : Node_Id; 19563 Prev : Entity_Id) 19564 is 19565 Def : constant Node_Id := Type_Definition (N); 19566 Is_Tagged : Boolean; 19567 Tag_Comp : Entity_Id; 19568 19569 begin 19570 -- These flags must be initialized before calling Process_Discriminants 19571 -- because this routine makes use of them. 19572 19573 Set_Ekind (T, E_Record_Type); 19574 Set_Etype (T, T); 19575 Init_Size_Align (T); 19576 Set_Interfaces (T, No_Elist); 19577 Set_Stored_Constraint (T, No_Elist); 19578 19579 -- Normal case 19580 19581 if Ada_Version < Ada_2005 19582 or else not Interface_Present (Def) 19583 then 19584 if Limited_Present (Def) then 19585 Check_SPARK_Restriction ("limited is not allowed", N); 19586 end if; 19587 19588 if Abstract_Present (Def) then 19589 Check_SPARK_Restriction ("abstract is not allowed", N); 19590 end if; 19591 19592 -- The flag Is_Tagged_Type might have already been set by 19593 -- Find_Type_Name if it detected an error for declaration T. This 19594 -- arises in the case of private tagged types where the full view 19595 -- omits the word tagged. 19596 19597 Is_Tagged := 19598 Tagged_Present (Def) 19599 or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T)); 19600 19601 Set_Is_Tagged_Type (T, Is_Tagged); 19602 Set_Is_Limited_Record (T, Limited_Present (Def)); 19603 19604 -- Type is abstract if full declaration carries keyword, or if 19605 -- previous partial view did. 19606 19607 Set_Is_Abstract_Type (T, Is_Abstract_Type (T) 19608 or else Abstract_Present (Def)); 19609 19610 else 19611 Check_SPARK_Restriction ("interface is not allowed", N); 19612 19613 Is_Tagged := True; 19614 Analyze_Interface_Declaration (T, Def); 19615 19616 if Present (Discriminant_Specifications (N)) then 19617 Error_Msg_N 19618 ("interface types cannot have discriminants", 19619 Defining_Identifier 19620 (First (Discriminant_Specifications (N)))); 19621 end if; 19622 end if; 19623 19624 -- First pass: if there are self-referential access components, 19625 -- create the required anonymous access type declarations, and if 19626 -- need be an incomplete type declaration for T itself. 19627 19628 Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def)); 19629 19630 if Ada_Version >= Ada_2005 19631 and then Present (Interface_List (Def)) 19632 then 19633 Check_Interfaces (N, Def); 19634 19635 declare 19636 Ifaces_List : Elist_Id; 19637 19638 begin 19639 -- Ada 2005 (AI-251): Collect the list of progenitors that are not 19640 -- already in the parents. 19641 19642 Collect_Interfaces 19643 (T => T, 19644 Ifaces_List => Ifaces_List, 19645 Exclude_Parents => True); 19646 19647 Set_Interfaces (T, Ifaces_List); 19648 end; 19649 end if; 19650 19651 -- Records constitute a scope for the component declarations within. 19652 -- The scope is created prior to the processing of these declarations. 19653 -- Discriminants are processed first, so that they are visible when 19654 -- processing the other components. The Ekind of the record type itself 19655 -- is set to E_Record_Type (subtypes appear as E_Record_Subtype). 19656 19657 -- Enter record scope 19658 19659 Push_Scope (T); 19660 19661 -- If an incomplete or private type declaration was already given for 19662 -- the type, then this scope already exists, and the discriminants have 19663 -- been declared within. We must verify that the full declaration 19664 -- matches the incomplete one. 19665 19666 Check_Or_Process_Discriminants (N, T, Prev); 19667 19668 Set_Is_Constrained (T, not Has_Discriminants (T)); 19669 Set_Has_Delayed_Freeze (T, True); 19670 19671 -- For tagged types add a manually analyzed component corresponding 19672 -- to the component _tag, the corresponding piece of tree will be 19673 -- expanded as part of the freezing actions if it is not a CPP_Class. 19674 19675 if Is_Tagged then 19676 19677 -- Do not add the tag unless we are in expansion mode 19678 19679 if Expander_Active then 19680 Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag); 19681 Enter_Name (Tag_Comp); 19682 19683 Set_Ekind (Tag_Comp, E_Component); 19684 Set_Is_Tag (Tag_Comp); 19685 Set_Is_Aliased (Tag_Comp); 19686 Set_Etype (Tag_Comp, RTE (RE_Tag)); 19687 Set_DT_Entry_Count (Tag_Comp, No_Uint); 19688 Set_Original_Record_Component (Tag_Comp, Tag_Comp); 19689 Init_Component_Location (Tag_Comp); 19690 19691 -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the 19692 -- implemented interfaces. 19693 19694 if Has_Interfaces (T) then 19695 Add_Interface_Tag_Components (N, T); 19696 end if; 19697 end if; 19698 19699 Make_Class_Wide_Type (T); 19700 Set_Direct_Primitive_Operations (T, New_Elmt_List); 19701 end if; 19702 19703 -- We must suppress range checks when processing record components in 19704 -- the presence of discriminants, since we don't want spurious checks to 19705 -- be generated during their analysis, but Suppress_Range_Checks flags 19706 -- must be reset the after processing the record definition. 19707 19708 -- Note: this is the only use of Kill_Range_Checks, and is a bit odd, 19709 -- couldn't we just use the normal range check suppression method here. 19710 -- That would seem cleaner ??? 19711 19712 if Has_Discriminants (T) and then not Range_Checks_Suppressed (T) then 19713 Set_Kill_Range_Checks (T, True); 19714 Record_Type_Definition (Def, Prev); 19715 Set_Kill_Range_Checks (T, False); 19716 else 19717 Record_Type_Definition (Def, Prev); 19718 end if; 19719 19720 -- Exit from record scope 19721 19722 End_Scope; 19723 19724 -- Ada 2005 (AI-251 and AI-345): Derive the interface subprograms of all 19725 -- the implemented interfaces and associate them an aliased entity. 19726 19727 if Is_Tagged 19728 and then not Is_Empty_List (Interface_List (Def)) 19729 then 19730 Derive_Progenitor_Subprograms (T, T); 19731 end if; 19732 19733 Check_Function_Writable_Actuals (N); 19734 end Record_Type_Declaration; 19735 19736 ---------------------------- 19737 -- Record_Type_Definition -- 19738 ---------------------------- 19739 19740 procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is 19741 Component : Entity_Id; 19742 Ctrl_Components : Boolean := False; 19743 Final_Storage_Only : Boolean; 19744 T : Entity_Id; 19745 19746 begin 19747 if Ekind (Prev_T) = E_Incomplete_Type then 19748 T := Full_View (Prev_T); 19749 else 19750 T := Prev_T; 19751 end if; 19752 19753 -- In SPARK, tagged types and type extensions may only be declared in 19754 -- the specification of library unit packages. 19755 19756 if Present (Def) and then Is_Tagged_Type (T) then 19757 declare 19758 Typ : Node_Id; 19759 Ctxt : Node_Id; 19760 19761 begin 19762 if Nkind (Parent (Def)) = N_Full_Type_Declaration then 19763 Typ := Parent (Def); 19764 else 19765 pragma Assert 19766 (Nkind (Parent (Def)) = N_Derived_Type_Definition); 19767 Typ := Parent (Parent (Def)); 19768 end if; 19769 19770 Ctxt := Parent (Typ); 19771 19772 if Nkind (Ctxt) = N_Package_Body 19773 and then Nkind (Parent (Ctxt)) = N_Compilation_Unit 19774 then 19775 Check_SPARK_Restriction 19776 ("type should be defined in package specification", Typ); 19777 19778 elsif Nkind (Ctxt) /= N_Package_Specification 19779 or else Nkind (Parent (Parent (Ctxt))) /= N_Compilation_Unit 19780 then 19781 Check_SPARK_Restriction 19782 ("type should be defined in library unit package", Typ); 19783 end if; 19784 end; 19785 end if; 19786 19787 Final_Storage_Only := not Is_Controlled (T); 19788 19789 -- Ada 2005: check whether an explicit Limited is present in a derived 19790 -- type declaration. 19791 19792 if Nkind (Parent (Def)) = N_Derived_Type_Definition 19793 and then Limited_Present (Parent (Def)) 19794 then 19795 Set_Is_Limited_Record (T); 19796 end if; 19797 19798 -- If the component list of a record type is defined by the reserved 19799 -- word null and there is no discriminant part, then the record type has 19800 -- no components and all records of the type are null records (RM 3.7) 19801 -- This procedure is also called to process the extension part of a 19802 -- record extension, in which case the current scope may have inherited 19803 -- components. 19804 19805 if No (Def) 19806 or else No (Component_List (Def)) 19807 or else Null_Present (Component_List (Def)) 19808 then 19809 if not Is_Tagged_Type (T) then 19810 Check_SPARK_Restriction ("non-tagged record cannot be null", Def); 19811 end if; 19812 19813 else 19814 Analyze_Declarations (Component_Items (Component_List (Def))); 19815 19816 if Present (Variant_Part (Component_List (Def))) then 19817 Check_SPARK_Restriction ("variant part is not allowed", Def); 19818 Analyze (Variant_Part (Component_List (Def))); 19819 end if; 19820 end if; 19821 19822 -- After completing the semantic analysis of the record definition, 19823 -- record components, both new and inherited, are accessible. Set their 19824 -- kind accordingly. Exclude malformed itypes from illegal declarations, 19825 -- whose Ekind may be void. 19826 19827 Component := First_Entity (Current_Scope); 19828 while Present (Component) loop 19829 if Ekind (Component) = E_Void 19830 and then not Is_Itype (Component) 19831 then 19832 Set_Ekind (Component, E_Component); 19833 Init_Component_Location (Component); 19834 end if; 19835 19836 if Has_Task (Etype (Component)) then 19837 Set_Has_Task (T); 19838 end if; 19839 19840 if Ekind (Component) /= E_Component then 19841 null; 19842 19843 -- Do not set Has_Controlled_Component on a class-wide equivalent 19844 -- type. See Make_CW_Equivalent_Type. 19845 19846 elsif not Is_Class_Wide_Equivalent_Type (T) 19847 and then (Has_Controlled_Component (Etype (Component)) 19848 or else (Chars (Component) /= Name_uParent 19849 and then Is_Controlled (Etype (Component)))) 19850 then 19851 Set_Has_Controlled_Component (T, True); 19852 Final_Storage_Only := 19853 Final_Storage_Only 19854 and then Finalize_Storage_Only (Etype (Component)); 19855 Ctrl_Components := True; 19856 end if; 19857 19858 Next_Entity (Component); 19859 end loop; 19860 19861 -- A Type is Finalize_Storage_Only only if all its controlled components 19862 -- are also. 19863 19864 if Ctrl_Components then 19865 Set_Finalize_Storage_Only (T, Final_Storage_Only); 19866 end if; 19867 19868 -- Place reference to end record on the proper entity, which may 19869 -- be a partial view. 19870 19871 if Present (Def) then 19872 Process_End_Label (Def, 'e', Prev_T); 19873 end if; 19874 end Record_Type_Definition; 19875 19876 ------------------------ 19877 -- Replace_Components -- 19878 ------------------------ 19879 19880 procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id) is 19881 function Process (N : Node_Id) return Traverse_Result; 19882 19883 ------------- 19884 -- Process -- 19885 ------------- 19886 19887 function Process (N : Node_Id) return Traverse_Result is 19888 Comp : Entity_Id; 19889 19890 begin 19891 if Nkind (N) = N_Discriminant_Specification then 19892 Comp := First_Discriminant (Typ); 19893 while Present (Comp) loop 19894 if Chars (Comp) = Chars (Defining_Identifier (N)) then 19895 Set_Defining_Identifier (N, Comp); 19896 exit; 19897 end if; 19898 19899 Next_Discriminant (Comp); 19900 end loop; 19901 19902 elsif Nkind (N) = N_Component_Declaration then 19903 Comp := First_Component (Typ); 19904 while Present (Comp) loop 19905 if Chars (Comp) = Chars (Defining_Identifier (N)) then 19906 Set_Defining_Identifier (N, Comp); 19907 exit; 19908 end if; 19909 19910 Next_Component (Comp); 19911 end loop; 19912 end if; 19913 19914 return OK; 19915 end Process; 19916 19917 procedure Replace is new Traverse_Proc (Process); 19918 19919 -- Start of processing for Replace_Components 19920 19921 begin 19922 Replace (Decl); 19923 end Replace_Components; 19924 19925 ------------------------------- 19926 -- Set_Completion_Referenced -- 19927 ------------------------------- 19928 19929 procedure Set_Completion_Referenced (E : Entity_Id) is 19930 begin 19931 -- If in main unit, mark entity that is a completion as referenced, 19932 -- warnings go on the partial view when needed. 19933 19934 if In_Extended_Main_Source_Unit (E) then 19935 Set_Referenced (E); 19936 end if; 19937 end Set_Completion_Referenced; 19938 19939 --------------------- 19940 -- Set_Fixed_Range -- 19941 --------------------- 19942 19943 -- The range for fixed-point types is complicated by the fact that we 19944 -- do not know the exact end points at the time of the declaration. This 19945 -- is true for three reasons: 19946 19947 -- A size clause may affect the fudging of the end-points. 19948 -- A small clause may affect the values of the end-points. 19949 -- We try to include the end-points if it does not affect the size. 19950 19951 -- This means that the actual end-points must be established at the 19952 -- point when the type is frozen. Meanwhile, we first narrow the range 19953 -- as permitted (so that it will fit if necessary in a small specified 19954 -- size), and then build a range subtree with these narrowed bounds. 19955 -- Set_Fixed_Range constructs the range from real literal values, and 19956 -- sets the range as the Scalar_Range of the given fixed-point type entity. 19957 19958 -- The parent of this range is set to point to the entity so that it is 19959 -- properly hooked into the tree (unlike normal Scalar_Range entries for 19960 -- other scalar types, which are just pointers to the range in the 19961 -- original tree, this would otherwise be an orphan). 19962 19963 -- The tree is left unanalyzed. When the type is frozen, the processing 19964 -- in Freeze.Freeze_Fixed_Point_Type notices that the range is not 19965 -- analyzed, and uses this as an indication that it should complete 19966 -- work on the range (it will know the final small and size values). 19967 19968 procedure Set_Fixed_Range 19969 (E : Entity_Id; 19970 Loc : Source_Ptr; 19971 Lo : Ureal; 19972 Hi : Ureal) 19973 is 19974 S : constant Node_Id := 19975 Make_Range (Loc, 19976 Low_Bound => Make_Real_Literal (Loc, Lo), 19977 High_Bound => Make_Real_Literal (Loc, Hi)); 19978 begin 19979 Set_Scalar_Range (E, S); 19980 Set_Parent (S, E); 19981 19982 -- Before the freeze point, the bounds of a fixed point are universal 19983 -- and carry the corresponding type. 19984 19985 Set_Etype (Low_Bound (S), Universal_Real); 19986 Set_Etype (High_Bound (S), Universal_Real); 19987 end Set_Fixed_Range; 19988 19989 ---------------------------------- 19990 -- Set_Scalar_Range_For_Subtype -- 19991 ---------------------------------- 19992 19993 procedure Set_Scalar_Range_For_Subtype 19994 (Def_Id : Entity_Id; 19995 R : Node_Id; 19996 Subt : Entity_Id) 19997 is 19998 Kind : constant Entity_Kind := Ekind (Def_Id); 19999 20000 begin 20001 -- Defend against previous error 20002 20003 if Nkind (R) = N_Error then 20004 return; 20005 end if; 20006 20007 Set_Scalar_Range (Def_Id, R); 20008 20009 -- We need to link the range into the tree before resolving it so 20010 -- that types that are referenced, including importantly the subtype 20011 -- itself, are properly frozen (Freeze_Expression requires that the 20012 -- expression be properly linked into the tree). Of course if it is 20013 -- already linked in, then we do not disturb the current link. 20014 20015 if No (Parent (R)) then 20016 Set_Parent (R, Def_Id); 20017 end if; 20018 20019 -- Reset the kind of the subtype during analysis of the range, to 20020 -- catch possible premature use in the bounds themselves. 20021 20022 Set_Ekind (Def_Id, E_Void); 20023 Process_Range_Expr_In_Decl (R, Subt); 20024 Set_Ekind (Def_Id, Kind); 20025 end Set_Scalar_Range_For_Subtype; 20026 20027 -------------------------------------------------------- 20028 -- Set_Stored_Constraint_From_Discriminant_Constraint -- 20029 -------------------------------------------------------- 20030 20031 procedure Set_Stored_Constraint_From_Discriminant_Constraint 20032 (E : Entity_Id) 20033 is 20034 begin 20035 -- Make sure set if encountered during Expand_To_Stored_Constraint 20036 20037 Set_Stored_Constraint (E, No_Elist); 20038 20039 -- Give it the right value 20040 20041 if Is_Constrained (E) and then Has_Discriminants (E) then 20042 Set_Stored_Constraint (E, 20043 Expand_To_Stored_Constraint (E, Discriminant_Constraint (E))); 20044 end if; 20045 end Set_Stored_Constraint_From_Discriminant_Constraint; 20046 20047 ------------------------------------- 20048 -- Signed_Integer_Type_Declaration -- 20049 ------------------------------------- 20050 20051 procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is 20052 Implicit_Base : Entity_Id; 20053 Base_Typ : Entity_Id; 20054 Lo_Val : Uint; 20055 Hi_Val : Uint; 20056 Errs : Boolean := False; 20057 Lo : Node_Id; 20058 Hi : Node_Id; 20059 20060 function Can_Derive_From (E : Entity_Id) return Boolean; 20061 -- Determine whether given bounds allow derivation from specified type 20062 20063 procedure Check_Bound (Expr : Node_Id); 20064 -- Check bound to make sure it is integral and static. If not, post 20065 -- appropriate error message and set Errs flag 20066 20067 --------------------- 20068 -- Can_Derive_From -- 20069 --------------------- 20070 20071 -- Note we check both bounds against both end values, to deal with 20072 -- strange types like ones with a range of 0 .. -12341234. 20073 20074 function Can_Derive_From (E : Entity_Id) return Boolean is 20075 Lo : constant Uint := Expr_Value (Type_Low_Bound (E)); 20076 Hi : constant Uint := Expr_Value (Type_High_Bound (E)); 20077 begin 20078 return Lo <= Lo_Val and then Lo_Val <= Hi 20079 and then 20080 Lo <= Hi_Val and then Hi_Val <= Hi; 20081 end Can_Derive_From; 20082 20083 ----------------- 20084 -- Check_Bound -- 20085 ----------------- 20086 20087 procedure Check_Bound (Expr : Node_Id) is 20088 begin 20089 -- If a range constraint is used as an integer type definition, each 20090 -- bound of the range must be defined by a static expression of some 20091 -- integer type, but the two bounds need not have the same integer 20092 -- type (Negative bounds are allowed.) (RM 3.5.4) 20093 20094 if not Is_Integer_Type (Etype (Expr)) then 20095 Error_Msg_N 20096 ("integer type definition bounds must be of integer type", Expr); 20097 Errs := True; 20098 20099 elsif not Is_OK_Static_Expression (Expr) then 20100 Flag_Non_Static_Expr 20101 ("non-static expression used for integer type bound!", Expr); 20102 Errs := True; 20103 20104 -- The bounds are folded into literals, and we set their type to be 20105 -- universal, to avoid typing difficulties: we cannot set the type 20106 -- of the literal to the new type, because this would be a forward 20107 -- reference for the back end, and if the original type is user- 20108 -- defined this can lead to spurious semantic errors (e.g. 2928-003). 20109 20110 else 20111 if Is_Entity_Name (Expr) then 20112 Fold_Uint (Expr, Expr_Value (Expr), True); 20113 end if; 20114 20115 Set_Etype (Expr, Universal_Integer); 20116 end if; 20117 end Check_Bound; 20118 20119 -- Start of processing for Signed_Integer_Type_Declaration 20120 20121 begin 20122 -- Create an anonymous base type 20123 20124 Implicit_Base := 20125 Create_Itype (E_Signed_Integer_Type, Parent (Def), T, 'B'); 20126 20127 -- Analyze and check the bounds, they can be of any integer type 20128 20129 Lo := Low_Bound (Def); 20130 Hi := High_Bound (Def); 20131 20132 -- Arbitrarily use Integer as the type if either bound had an error 20133 20134 if Hi = Error or else Lo = Error then 20135 Base_Typ := Any_Integer; 20136 Set_Error_Posted (T, True); 20137 20138 -- Here both bounds are OK expressions 20139 20140 else 20141 Analyze_And_Resolve (Lo, Any_Integer); 20142 Analyze_And_Resolve (Hi, Any_Integer); 20143 20144 Check_Bound (Lo); 20145 Check_Bound (Hi); 20146 20147 if Errs then 20148 Hi := Type_High_Bound (Standard_Long_Long_Integer); 20149 Lo := Type_Low_Bound (Standard_Long_Long_Integer); 20150 end if; 20151 20152 -- Find type to derive from 20153 20154 Lo_Val := Expr_Value (Lo); 20155 Hi_Val := Expr_Value (Hi); 20156 20157 if Can_Derive_From (Standard_Short_Short_Integer) then 20158 Base_Typ := Base_Type (Standard_Short_Short_Integer); 20159 20160 elsif Can_Derive_From (Standard_Short_Integer) then 20161 Base_Typ := Base_Type (Standard_Short_Integer); 20162 20163 elsif Can_Derive_From (Standard_Integer) then 20164 Base_Typ := Base_Type (Standard_Integer); 20165 20166 elsif Can_Derive_From (Standard_Long_Integer) then 20167 Base_Typ := Base_Type (Standard_Long_Integer); 20168 20169 elsif Can_Derive_From (Standard_Long_Long_Integer) then 20170 Base_Typ := Base_Type (Standard_Long_Long_Integer); 20171 20172 else 20173 Base_Typ := Base_Type (Standard_Long_Long_Integer); 20174 Error_Msg_N ("integer type definition bounds out of range", Def); 20175 Hi := Type_High_Bound (Standard_Long_Long_Integer); 20176 Lo := Type_Low_Bound (Standard_Long_Long_Integer); 20177 end if; 20178 end if; 20179 20180 -- Complete both implicit base and declared first subtype entities 20181 20182 Set_Etype (Implicit_Base, Base_Typ); 20183 Set_Size_Info (Implicit_Base, (Base_Typ)); 20184 Set_RM_Size (Implicit_Base, RM_Size (Base_Typ)); 20185 Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); 20186 20187 Set_Ekind (T, E_Signed_Integer_Subtype); 20188 Set_Etype (T, Implicit_Base); 20189 20190 -- In formal verification mode, restrict the base type's range to the 20191 -- minimum allowed by RM 3.5.4, namely the smallest symmetric range 20192 -- around zero with a possible extra negative value that contains the 20193 -- subtype range. Keep Size, RM_Size and First_Rep_Item info, which 20194 -- should not be relied upon in formal verification. 20195 20196 if Strict_Alfa_Mode then 20197 declare 20198 Sym_Hi_Val : Uint; 20199 Sym_Lo_Val : Uint; 20200 Dloc : constant Source_Ptr := Sloc (Def); 20201 Lbound : Node_Id; 20202 Ubound : Node_Id; 20203 Bounds : Node_Id; 20204 20205 begin 20206 -- If the subtype range is empty, the smallest base type range 20207 -- is the symmetric range around zero containing Lo_Val and 20208 -- Hi_Val. 20209 20210 if UI_Gt (Lo_Val, Hi_Val) then 20211 Sym_Hi_Val := UI_Max (UI_Abs (Lo_Val), UI_Abs (Hi_Val)); 20212 Sym_Lo_Val := UI_Negate (Sym_Hi_Val); 20213 20214 -- Otherwise, if the subtype range is not empty and Hi_Val has 20215 -- the largest absolute value, Hi_Val is non negative and the 20216 -- smallest base type range is the symmetric range around zero 20217 -- containing Hi_Val. 20218 20219 elsif UI_Le (UI_Abs (Lo_Val), UI_Abs (Hi_Val)) then 20220 Sym_Hi_Val := Hi_Val; 20221 Sym_Lo_Val := UI_Negate (Hi_Val); 20222 20223 -- Otherwise, the subtype range is not empty, Lo_Val has the 20224 -- strictly largest absolute value, Lo_Val is negative and the 20225 -- smallest base type range is the symmetric range around zero 20226 -- with an extra negative value Lo_Val. 20227 20228 else 20229 Sym_Lo_Val := Lo_Val; 20230 Sym_Hi_Val := UI_Sub (UI_Negate (Lo_Val), Uint_1); 20231 end if; 20232 20233 Lbound := Make_Integer_Literal (Dloc, Sym_Lo_Val); 20234 Ubound := Make_Integer_Literal (Dloc, Sym_Hi_Val); 20235 Set_Is_Static_Expression (Lbound); 20236 Set_Is_Static_Expression (Ubound); 20237 Analyze_And_Resolve (Lbound, Any_Integer); 20238 Analyze_And_Resolve (Ubound, Any_Integer); 20239 20240 Bounds := Make_Range (Dloc, Lbound, Ubound); 20241 Set_Etype (Bounds, Base_Typ); 20242 20243 Set_Scalar_Range (Implicit_Base, Bounds); 20244 end; 20245 20246 else 20247 Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); 20248 end if; 20249 20250 Set_Size_Info (T, (Implicit_Base)); 20251 Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base)); 20252 Set_Scalar_Range (T, Def); 20253 Set_RM_Size (T, UI_From_Int (Minimum_Size (T))); 20254 Set_Is_Constrained (T); 20255 end Signed_Integer_Type_Declaration; 20256 20257end Sem_Ch3; 20258